rakudo-2013.12/blib/Perl6/.gitignore0000664000175000017500000000002612242026101016457 0ustar moritzmoritz*.pbc *.class *.moarvmrakudo-2013.12/Configure.pl0000664000175000017500000002203712255236631015072 0ustar moritzmoritz#! perl # Copyright (C) 2009 The Perl Foundation use 5.008; use strict; use warnings; use Text::ParseWords; use Getopt::Long; use File::Spec; use Cwd; use lib 'tools/lib'; use NQP::Configure qw(sorry slurp cmp_rev gen_nqp read_config fill_template_text fill_template_file system_or_die verify_install); my $lang = 'Rakudo'; my $lclang = lc $lang; my $uclang = uc $lang; my $slash = $^O eq 'MSWin32' ? '\\' : '/'; MAIN: { if (-r 'config.default') { unshift @ARGV, shellwords(slurp('config.default')); } my %config = (perl => $^X); my $config_status = "${lclang}_config_status"; $config{$config_status} = join ' ', map { qq("$_") } @ARGV; my $exe = $NQP::Configure::exe; my %options; GetOptions(\%options, 'help!', 'prefix=s', 'backends=s', 'no-clean!', 'gen-nqp:s', 'gen-parrot:s', 'parrot-option=s@', 'parrot-make-option=s@', 'make-install!', 'makefile-timing!', ) or do { print_help(); exit(1); }; # Print help if it's requested if ($options{'help'}) { print_help(); exit(0); } $options{prefix} ||= 'install'; $options{prefix} = File::Spec->rel2abs($options{prefix}); my $prefix = $options{'prefix'}; my %known_backends = (parrot => 1, jvm => 1); my %letter_to_backend; my $default_backend; for (keys %known_backends) { $letter_to_backend{ substr($_, 0, 1) } = $_; } my %backends; if (defined $options{backends}) { for my $b (split /,\s*/, $options{backends}) { $b = lc $b; unless ($known_backends{$b}) { die "Unknown backend '$b'; Supported backends are: " . join(", ", sort keys %known_backends) . "\n"; } $backends{$b} = 1; $default_backend ||= $b; } unless (%backends) { die "--prefix given, but no valid backend?!\n"; } } else { for my $l (sort keys %letter_to_backend) { # TODO: needs .exe/.bat magic on windows? if (-x "$prefix/bin/nqp-$l") { my $b = $letter_to_backend{$l}; print "Found $prefix/bin/nqp-$l (backend $b)\n"; $backends{$b} = 1; $default_backend ||= $b; } } $backends{parrot} = 1 if exists $options{'gen-parrot'}; unless (%backends) { die "No suitable nqp executables found! Please specify some --backends, or a --prefix that contains nqp-{p,j} executables\n"; } } # Save options in config.status unlink('config.status'); if (open(my $CONFIG_STATUS, '>', 'config.status')) { print $CONFIG_STATUS "$^X Configure.pl $config{$config_status} \$*\n"; close($CONFIG_STATUS); } $config{prefix} = $prefix; $config{slash} = $slash; $config{'makefile-timing'} = $options{'makefile-timing'}; $config{'stagestats'} = '--stagestats' if $options{'makefile-timing'}; $config{'cpsep'} = $^O eq 'MSWin32' ? ';' : ':'; $config{'shell'} = $^O eq 'MSWin32' ? 'cmd' : 'sh'; my $make = $config{'make'} = $^O eq 'MSWin32' ? 'nmake' : 'make'; open my $MAKEFILE, '>', 'Makefile' or die "Cannot open 'Makefile' for writing: $!"; my @prefixes = sort map substr($_, 0, 1), keys %backends; print $MAKEFILE "\n# Makefile code generated by Configure.pl:\n"; my $launcher = substr($default_backend, 0, 1) . '-runner-default'; print $MAKEFILE "all: ", join(' ', map("$_-all", @prefixes), $launcher), "\n"; print $MAKEFILE "install: ", join(' ', map("$_-install", @prefixes), $launcher . '-install'), "\n"; for my $t (qw/clean test spectest coretest/) { print $MAKEFILE "$t: ", join(' ', map "$_-$t", @prefixes), "\n"; } fill_template_file('tools/build/Makefile-common.in', $MAKEFILE, %config); # determine the version of NQP we want my ($nqp_want) = split(' ', slurp('tools/build/NQP_REVISION')); my %binaries; my %impls = gen_nqp($nqp_want, prefix => $prefix, backends => join(',', sort keys %backends), %options); my @errors; if ($backends{parrot}) { my %nqp_config; if ($impls{parrot}{ok}) { %nqp_config = %{ $impls{parrot}{config} }; } elsif ($impls{parrot}{config}) { push @errors, "The nqp-p is too old"; } else { push @errors, "Cannot obtain configuration from NQP on parrot"; } my $nqp_have = $nqp_config{'nqp::version'} || ''; if ($nqp_have && cmp_rev($nqp_have, $nqp_want) < 0) { push @errors, "NQP revision $nqp_want required (currently $nqp_have)."; } if (!@errors) { push @errors, verify_install([ @NQP::Configure::required_parrot_files, @NQP::Configure::required_nqp_files ], %config, %nqp_config); push @errors, "(Perhaps you need to 'make install', 'make install-dev',", "or install the 'devel' package for NQP or Parrot?)" if @errors; } if (@errors && !defined $options{'gen-nqp'}) { push @errors, "\nTo automatically clone (git) and build a copy of NQP $nqp_want,", "try re-running Configure.pl with the '--gen-nqp' or '--gen-parrot'", "options. Or, use '--prefix=' to explicitly", "specify the path where the NQP and Parrot executable can be found that are use to build $lang."; } sorry(@errors) if @errors; print "Using $impls{parrot}{bin} (version $nqp_config{'nqp::version'}).\n"; if ($^O eq 'MSWin32' or $^O eq 'cygwin') { $config{'dll'} = '$(PARROT_BIN_DIR)/$(PARROT_LIB_SHARED)'; $config{'dllcopy'} = '$(PARROT_LIB_SHARED)'; $config{'make_dllcopy'} = '$(PARROT_DLL_COPY): $(PARROT_DLL)'."\n\t".'$(CP) $(PARROT_DLL) .'; } my $make = fill_template_text('@make@', %config, %nqp_config); fill_template_file('tools/build/Makefile-Parrot.in', $MAKEFILE, %config, %nqp_config); } if ($backends{jvm}) { $config{j_nqp} = $impls{jvm}{bin}; $config{j_nqp} =~ s{/}{\\}g if $^O eq 'MSWin32'; my %nqp_config; if ( $impls{jvm}{ok} ) { %nqp_config = %{ $impls{jvm}{config} }; } elsif ( $impls{jvm}{config} ) { push @errors, "nqp-j is too old"; } else { push @errors, "Unable to read configuration from NQP on the JVM"; } my $bin = $impls{jvm}{bin}; if (!@errors && !defined $nqp_config{'jvm::runtime.jars'}) { push @errors, "jvm::runtime.jars value not available from $bin --show-config."; } sorry(@errors) if @errors; print "Using $bin.\n"; $config{'nqp_prefix'} = $nqp_config{'jvm::runtime.prefix'}; $config{'nqp_jars'} = $nqp_config{'jvm::runtime.jars'}; $config{'nqp_classpath'} = $nqp_config{'jvm::runtime.classpath'}; $config{'j_runner'} = $^O eq 'MSWin32' ? 'perl6-j.bat' : 'perl6-j'; fill_template_file('tools/build/Makefile-JVM.in', $MAKEFILE, %config); } my $l = uc substr($default_backend, 0, 1); print $MAKEFILE qq[\nt/*/*.t t/*.t t/*/*/*.t: all\n\t\$(${l}_HARNESS_WITH_FUDGE) --verbosity=1 \$\@\n]; close $MAKEFILE or die "Cannot write 'Makefile': $!"; unless ($options{'no-clean'}) { no warnings; print "Cleaning up ...\n"; if (open my $CLEAN, '-|', "$make clean") { my @slurp = <$CLEAN>; close($CLEAN); } } if ($options{'make-install'}) { system_or_die($make); system_or_die($make, 'install'); print "\n$lang has been built and installed.\n"; } else { print "\nYou can now use '$make' to build $lang.\n"; print "After that, '$make test' will run some tests and\n"; print "'$make install' will install $lang.\n"; } exit 0; } # Print some help text. sub print_help { print <<"END"; Configure.pl - $lang Configure General Options: --help Show this text --prefix=dir Install files in dir; also look for executables there --backends=parrot,jvm Which backend(s) to use --gen-nqp[=branch] Download and build a copy of NQP --gen-parrot[=branch] Download and build a copy of Parrot --parrot-option='--option' Options to pass to Parrot's Configure.pl --parrot-make-option='--option' Options to pass to Parrot's make, for example: --parrot-make-option='--jobs=4' --makefile-timing Enable timing of individual makefile commands Configure.pl also reads options from 'config.default' in the current directory. END return; } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: rakudo-2013.12/CREDITS0000664000175000017500000001514612224263172013633 0ustar moritzmoritz=pod Following in the steps of other open source projects that eventually take over the world, here is the partial list of people who have contributed to Rakudo and its supporting works. It is sorted by name and formatted to allow easy grepping and beautification by scripts. The fields are: name (N), email (E), web-address (W), description (D), Subversion or GitHub username (U) and snail-mail address (S). Thanks, The Rakudo Team PS: Yes, this looks remarkably like the Linux CREDITS format PPS: This file is encoded in UTF-8 ---------- N: Alberto Manuel Brandao Simoes U: ambs E: ambs@cpan.org S: Braga, Portugal W: http://alfarrabio.di.uminho.pt/~albie/ N: Alex Elsayed U: eternaleye E: eternaleye@gmail.com N: Allison Randal D: Parrot Architect (0.4.6...) E: allison@parrot.org U: allison N: Ahmad M. Zawawi U: azawawi E: ahmad.zawawi@gmail.com D: Rakudo builtins, win32 patches N: Andrew Whitworth E: wknight8111@gmail.com U: Whiteknight N: Andy Lester E: andy@petdance.com W: http://perlbuzz.com/ S: McHenry, IL, USA U: petdance U: ask N: Ask Bjørn Hansen D: Keeps us running E: ask@develooper.com N: Audrey Tang U: au E: audreyt@audreyt.org D: Pugs, a Perl6->Parrot implementation. N: Вячеслав Матюхин U: mmcleric E: me@berekuk.ru D: Whatever-currying, colonpair fixes N: Bernhard Schmalhofer U: bernhard E: Bernhard.Schmalhofer@gmx.de N: Bob Rogers D: Random small bug fixes E: rogers-perl6@rgrjr.dyndns.org U: rgrjr N: Brent Laabs U: labster E: bslaabs@gmail.com N: Bruce Gray U: util E: bruce.gray@acm.org N: Bruce Keeler U: bkeeler D: variable interpolation into regexes N: Bryan C. Warnock D: The First Perl 6 Summarizer D: Little things here and there in pre-Parrot days. D: And, yes, {sigh}, *that* Warnock. E: bwarnock@raba.com N: Carl Mäsak E: cmasak@gmail.com U: masak N: Chip Salzenberg D: Release manager emeritus D: Architect emeritus (0.1.2-0.4.5) U: chip E: chip@pobox.com N: Chris Davaz D: Rakudo builtins E: cdavaz@gmail.com N: Chris Dolan U: cdolan D: Rakudo patches E: cdolan@cpan.org N: Chris Fields U: cjfields D: Rakudo patches N: Christoph Otto a.k.a. cotto U: cotto E: christoph@mksig.org N: chromatic U: chromatic E: chromatic@wgz.org W: http://wgz.org/chromatic/ N: Colin Kuskie U: colink E: ckuskie@sterling.net N: Cory Spencer U: cspencer D: Rakudo builtins E: cspencer@sprocket.org N: Curtis 'Ovid' Poe U: Ovid D: docs/test cleanups/Makefile fixes D: Rename 'pbc_to_c' to 'pbc_to_exe' E: ovid@cpan.org N: Dan Sugalski U: dan D: Architect emeritus (0.0.1-0.1.1) E: dan@sidhe.org W: http://www.sidhe.org/~dan/blog/ N: David Romano D: PGE tests and fixes E: david.romano+p6i@gmail.com N: Dino Morelli D: PGE tests E: dmorelli@reactorweb.net N: Donald Hunter U: donaldh E: donald@sealgair.com N: Elizabeth Mattijsen U: lizmat E: liz@dijkmat.nl N: Florian Ragwitz U: rafl U: flora E: rafl@debianforum.de W: http://www.tu-chemnitz.de/~rafl/ S: Chemnitz, Germany N: François Perrad E: francois.perrad@gadz.org W: http://fperrad.googlepages.com/home U: fperrad N: Geoff Broadwell U: japhb E: geoff@broadwell.org U: gregor N: Gregor N. Purdy E: gregor@focusresearch.com S: Sunnyvale, CA U: ingy N: Ingy döt Net E: ingy@ingy.net W: http://ingy.net/ S: Seattle, WA, USA D: Make is() work like Perl 5; add .pm6 to extensions searched. N: James E Keenan (Jim) E: jkeenan@cpan.org U: jkeenan W: http://thenceforward.net/parrot/ S: Brooklyn, NY, USA N: Jarkko Hietaniemi U: jhi E: jhi@iki.fi N: Jason Gloudon N: Jeff Horwitz E: jeff@smashing.org U: jhorwitz N: Jerry Gay U: particle E: Jerry.Gay@gmail.com S: Seattle, WA, USA N: Jesse Vincent U: jesse E: jesse@fsck.com N: John Harrison U: __ash__ E: ash@greaterthaninfinity.com N: Jonathan Scott Duff U: perlpilot U: PerlJam E: duff@pobox.com N: Jonathan "Duke" Leto U: leto U: dukeleto E: jonathan@leto.net W: http://leto.net S: Portland, OR N: Jonathan Worthington U: jnthn E: jnthn@jnthn.net W: http://www.jnthn.net/ N: Joshua Gatcomb N: Julian Albo U: julianalbo E: julian.notfound@gmail.com N: Kevin Tew U: tewk E: tewk@tewk.com N: Klaas-Jan Stol U: kjs E: parrotcode@gmail.com N: Kodi Arfer U: Kodi W: http://arfer.net N: Kyle Hasselbacher E: kyleha@gmail.com U: KyleHa U: kyle D: Test.pm improvements, ticket testing N: Larry Wall E: larry@wall.org U: larry N: Leopold Toetsch U: leo D: Patchmonster & release manager emeritus (0.0.13 - 0.4.5) E: lt@toetsch.at S: Herrnbaumgarten, Austria N: Luke Palmer E: luke@luqui.org U: luqui N: Mark Glines U: infinoid E: mark@glines.org S: South Lake Tahoe, CA, USA N: Mark Grimes E: mgrimes@cpan.org N: Martin Berends E: mberends@autoexec.demon.nl D: Rakudo patch(es) N: Matt Diephouse U: mdiep E: matt@diephouse.com N: Michael Schroeder U: mls D: Exception handling E: mls@suse.de N: Moritz Lenz E: moritz@faui2k3.org U: moritz U: moritz_ D: Test infrastructure, tests, various Rakudo features and built-ins N: Nicholas Clark U: nicholas E: nick@ccl4.org N: Notfound E: julian.notfound@gmail.com N: Nuno 'smash' Carvalho U: smash E: mestre.smash@gmail.com N: Patrick Abi Salloum U: patrickas E: patrick.abisalloum@gmail.com N: Patrick R. Michaud U: pmichaud D: Perl 6 (Rakudo Perl) lead developer, pumpking E: pmichaud@pobox.com N: Paul Cochrane U: paultcochrane E: paultcochrane@gmail.com N: Peter Gibbs U: petergibbs E: peter@emkel.co.za N: Piers Cawley U: pdcawley D: The Second Perl 6 Summarizer after Bryan C. Warnock E: pdcawley@bofh.org.uk W: http://www.bofh.org.uk:8080/ N: Reini Urban U: rurban E: rurban@cpan.org D: cygwin fixes N: Rob Hoelz U: hoelzro E: rob@hoelz.ro N: Robert Spier D: Keeps us running U: robert E: robert@perl.org N: Shrivatsan Sampathkumar U: isBEKaml E: nastavs@gmail.com N: Simon Cozens U: simon E: simon@simon-cozens.org N: Solomon Foster U: colomon E: colomon@gmail.com N: Stefan O'Rear U: sorear E: stefanor@cox.net N: Stéphane Payrard D: Various code fixes and improvements N: Stephen Weeks U: tene D: Minor Rakudo patches E: tene@allalone.org N: Timo Paulssen U: timo E: timonator@perpetuum-immobile.de N: Timothy Totten U: novus D: Temporal (DateTime/Date) modifications E: supernovus@gmail.com W: http://huri.net/ N: Tobias Leich U: FROGGS E: email@froggs.de N: Tyler Curtis U: tcurtis D: $*ARGFILES E: tyler.l.curtis@gmail.com N: Ujwal Reddy Malipeddi E: ujwalic@gmail.com D: Rakudo patch N: Vasily Chekalkin E: bacek@bacek.com D: Core and Rakudo patches N: Will "Coke" Coleda U: coke E: will@coleda.com N: Zach Morgan E: zpmorgan@gmail.com D: Rakudo patch N: Tadeusz Sośnierz U: tadzik E: tadzikes@gmail.com N: Arne Skjærholt U: arnsholt E: arnsholt@gmail.com N: JD Horelick U: jdhore E: jdhore1@gmail.com =cut rakudo-2013.12/docs/announce/2009-020000664000175000017500000000607112224263172016102 0ustar moritzmoritzAnnounce: Rakudo Perl development release #14 ("Vienna") On behalf of the Rakudo development team, I'm pleased to announce the February 2009 development release of Rakudo Perl #14 "Vienna". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the February 2009 release is available from http://www.pmichaud.com/perl6/rakudo-2009-02.tar.gz However, because of the rapid pace of Rakudo development and addition of new features, we still recommend that people wanting to use or work with Rakudo obtain the latest version directly from the main repository at github -- more on this in a bit. This is the fourteenth development release of Rakudo Perl, but it's the first release independent from Parrot releases. We will continue to follow a monthly release cycle, with each release to be code named after a Perl Mongers group. This release is named for Vienna.pm (http://vienna.pm.org), who have been sponsoring Jonathan Worthington's work on Rakudo since April 2008. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Rakudo Perl now uses git [2] for its version control system, hosted at http://github.com/rakudo/rakudo . The README file there is kept up-to-date with the latest instructions for obtaining and building Rakudo Perl. In this release of Rakudo Perl, we've made the following major changes and improvements: * Rakudo is now passing 7076 spectests. This is an increase of 796 passing tests since the January 2009 release. * The Configure.pl script supports a "--gen-parrot" option to automatically fetch and build the appropriate version of Parrot. * The default make target now builds a binary executable directly, either perl6 or perl6.exe. It's still a Parrot "fakecutable", but we think we've made it more reliable so that it doesn't generate segmentation faults on exits. (If you don't know what a "fakecutable" is you can safely ignore this.) * Many builtins are beginning to be written in pure Perl 6, or Perl 6 functions with inline PIR. These builtins are part of the core "setting" for Perl 6, and appear in the src/setting/ directory. Previously this was known as the "prelude". * Improved Test.pm diagnostic output. Also, Rakudo now implements the following Perl 6 features: * Anonymous classes may be specified using :: * Existing parameterized roles are now reused instead of creating new ones. * Roles pun a class when .new is invoked on them. * "proto" now marks all same-named routines as "multi". * "XopX" is now "Xop". * <-> (rw) pointy blocks. * min= and max= metaoperators. * Many many bugfixes and documentation improvements. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. The next release of Rakudo (#15) is scheduled for March 19, 2009. References: [1] Parrot, http://parrot.org/ [2] Git version control system, http://git-scm.org/ rakudo-2013.12/docs/announce/2009-030000664000175000017500000000501112224263172016074 0ustar moritzmoritzAnnounce: Rakudo Perl development release #15 ("Oslo") On behalf of the Rakudo development team, I'm pleased to announce the March 2009 development release of Rakudo Perl #15 "Oslo". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the March 2009 release is available from http://www.pmichaud.com/perl6/rakudo-2009-03.tar.gz However, because of the rapid pace of Rakudo development and addition of new features, we still recommend that people wanting to use or work with Rakudo obtain the latest version directly from the main repository at github -- more on this in a bit. Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. This release is named "Oslo" in honor of the organizers of the 2009 Nordic Perl Workshop [2], April 16-17, 2009. The 2009 Nordic Perl Workshop will have a special focus on Perl 6, Rakudo Perl, and Parrot, including Perl 6 tutorials and hackathons after the conference itself. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Rakudo Perl now uses git [3] for its version control system, hosted at http://github.com/rakudo/rakudo . The README file there is kept up-to-date with the latest instructions for obtaining and building Rakudo Perl. In this release of Rakudo Perl, we've made the following major changes and improvements: * Rakudo is now passing 7273 spectests. This is an increase of 197 passing tests since the February 2009 release. * The eval() construct now understands lexical variables from an outer scope. * More of the builtin functions ("settings") are being written in Perl 6. * Rakudo supports the "R" (reverse) metaoperator. * Parsing of if, unless, while, until, etc. statements after blocks now works correctly. * The Q quote operator is now implemented, along with several adverbial forms. In particular, the Q:PIR form allows inline PIR to be included in Perl 6 code. * Multi-method dispatch now works with inheritance also. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. The next release of Rakudo (#16) is scheduled for April 23, 2009. References: [1] Parrot, http://parrot.org/ [2] Nordic Perl Workshop 2009, http://www.perlworkshop.no/npw2009/ [3] Git version control system, http://git-scm.org/ rakudo-2013.12/docs/announce/2009-040000664000175000017500000000634312224263172016106 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #16 ("Bratislava") On behalf of the Rakudo development team, I'm pleased to announce the April 2009 development release of Rakudo Perl #16 "Bratislava". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the April 2009 release is available from http://github.com/rakudo/rakudo/downloads . Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we continue to recommend that people wanting to use or work with Rakudo obtain the latest source directly from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo . Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. This release is named "Bratislava", home to Jonathan Worthington and reportedly an excellent place to obtain beer (a key component of Jonathan's contributions to Perl). The Bratislava.pm group is quite active [2], with regular technical presentations and social gatherings. In this release of Rakudo Perl, we've made the following major changes and improvements: * Rakudo is now passing 10,467 spectests, an increase of 3,194 passing tests since the March 2009 release. With this release Rakudo is now passing approximately 65% of the available spectest suite. * About 2/3 of the increase in passing tests is due to improved Unicode support in Rakudo; constructs such as "\c[LATIN CAPITAL LETTER A]" and Unicode character properties in regexes are now supported. * The prefix:<=> operator is now gone from the Perl 6 specification (and thus from Rakudo). Use .get for reading individual items from iterators. * Rakudo now supports typed arrays and hashes (my Int @array), as well as parametric versions of the Associative, Positional, and Callable roles, and parametric role subtyping. * Rakudo now has sockets support (IO::Socket). * Subroutine return types are now enforced in some cases. * Rakudo now supports lexical sub declarations. * Rakudo now supports some P5-style regexes. * The "quantify-by-separator" feature has been added, so that one can write / [\w+] ** ',' / to get a comma-separated list of words. * More builtin functions and methods have been rewritten in Perl 6 and placed as part of the setting. * Release tar files now contain local copies of the appropriate spectests, instead of obtaining checkout copies via Subversion. * There are additional improvements and features in this release, see docs/ChangeLog for a more complete list. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#17) is scheduled for May 21, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! References: [1] Parrot, http://parrot.org/ [2] Bratislava.pm, http://bratislava.pm.org/ rakudo-2013.12/docs/announce/2009-050000664000175000017500000000564712224263172016115 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #17 ("Stockholm") On behalf of the Rakudo development team, I'm pleased to announce the May 2009 development release of Rakudo Perl #17 "Stockholm". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the May 2009 release is available from http://github.com/rakudo/rakudo/downloads . Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we continue to recommend that people wanting to use or work with Rakudo obtain the latest source directly from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo . Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. This release is named "Stockholm"; Stockholm Perl Mongers will be holding a Perl 6 hackathon on May 29 [3]. Perl 6 developer Carl Mäsak is a member of Stockholm Perl Mongers and a main author of November [4], Druid [5], proto [6], and other Perl 6-based packages. Carl also contributes patches to Rakudo, and has been stress-testing Rakudo over the past year, submitting nearly 400 bug reports. In this release of Rakudo Perl, we've made the following major changes and improvements: * Rakudo is now passing 11,342 spectests, an increase of 875 passing tests since the April 2009 release. With this release Rakudo is now passing 68% of the available spectest suite. * We now have an updated docs/ROADMAP . * Errors and stack traces now report the file name and line number in the original source code. * Some custom operators can be defined, and it's possible to refer to operators using &infix: syntax. * We can start to load libraries written in other Parrot languages. * Regexes now produce a Regex sub. * More builtin functions and methods have been rewritten in Perl 6 and placed as part of the setting. * There are many additional improvements and features in this release, see docs/ChangeLog for a more complete list. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#18) is scheduled for June 18, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! References: [1] Parrot, http://parrot.org/ [2] Stockholm.pm, http://sthlm.pm.org/ [3] Stockholm Perl 6 hackathon, http://vic20.blipp.com/pipermail/kameler/2009-May/000318.html [4] November wiki engine, http://github.com/viklund/november/ [5] Druid, http://github.com/masak/druid/ [6] Proto, http://github.com/masak/proto/ rakudo-2013.12/docs/announce/2009-060000664000175000017500000000651112224263172016105 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #18 ("Pittsburgh") On behalf of the Rakudo development team, I'm pleased to announce the June 2009 development release of Rakudo Perl #18 "Pittsburgh". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the June 2009 release is available from http://github.com/rakudo/rakudo/downloads . Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we continue to recommend that people wanting to use or work with Rakudo obtain the latest source directly from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo . Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. This release is named "Pittsburgh", which is the host for YAPC|10 (YAPC::NA 2009) [2] and the Parrot Virtual Machine Workshop [3]. Pittsburgh.pm has also sponsored hackathons for Rakudo Perl as part of the 2008 Pittsburgh Perl Workshop [4]. In this release of Rakudo Perl, we've focused our efforts on refactoring many of Rakudo's internals; these refactors improve performance, bring us closer to the Perl 6 specification, operate more cleanly with Parrot, and provide a stronger foundation for features to be implemented in the near future. Some of the specific major changes and improvements in this release include: * Rakudo is now passing 11,536 spectests, an increase of 194 passing tests since the May 2009 release. With this release Rakudo is now passing 68% of the available spectest suite. * Method dispatch has been substantially refactored; the new dispatcher is significantly faster and follows the Perl 6 specification more closely. * Object initialization via the BUILD and CREATE (sub)methods is substantially improved. * All return values are now type checked (previously only explicit 'return' statements would perform type checking). * String handling is significantly improved: fewer Unicode-related bugs exist, and parsing speed is greatly improved for some programs containing characters in the Latin-1 set. * The IO .lines and .get methods now follow the specification more closely. * User-defined operators now also receive some of their associated meta variants. * The 'is export' trait has been improved; more builtin functions and methods can be written in Perl 6 instead of PIR. * Many Parrot changes have improved performance and reduced overall memory leaks (although there's still much more improvement needed). The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#19) is scheduled for July 23, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! References: [1] Parrot, http://parrot.org/ [2] YAPC|10 http://yapc10.org/yn2009/ [3] Parrot Virtual Machine Workshop, http://yapc10.org/yn2009/talk/2045 [4] Pittsburgh Perl Workshop, http://pghpw.org/ppw2008/ rakudo-2013.12/docs/announce/2009-070000664000175000017500000000612412224263172016106 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #19 ("Chicago") On behalf of the Rakudo development team, I'm pleased to announce the June 2009 development release of Rakudo Perl #19 "Chicago". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the July 2009 release is available from http://github.com/rakudo/rakudo/downloads . Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we continue to recommend that people wanting to use or work with Rakudo obtain the latest source directly from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo . Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. The July 2009 release is named "Chicago", as chosen by Perl 6 contributor Kyle Hasselbacher. Kyle has been doing a truly outstanding job of turning open tickets in the RT queues into tests for the spectest suite. Chicago.pm has been the host for the 2006 and 2008 YAPC::NA conferences and sponsored Perl 6 hackathons at each conference. In this release of Rakudo Perl, we've focused our efforts on quality improvements and bootstrapping. We now have operators and additional builtin functions written in Perl 6. Some of the specific major changes and improvements in this release include: * Rakudo is now passing 11,876 spectests, an increase of 340 passing tests since the June 2009 release. With this release Rakudo is now passing 68% of the available spectest suite. * Operators can now be written in Perl 6, and this has been done for the series operator '...', 'eqv' and the 'leg' operator. * The multi dispatcher has been refactored extensively, and now handles many more edge cases correctly. * User defined traits now follow the specification much more closely; some built-in traits are written in Perl 6. * Improved testing: Null PMC Access exceptions are never considered "successful" by the test suite, even if the test was expecting a (different) exception to be thrown. * Improved introspection: you can now get a list of roles composed into a class, and a list of attributes. Since the Perl 6 specification is still in flux, some deprecated features will be removed from Rakudo. Prominently among those are: * '=$handle' is deprecated in favor of '$handle.get' (one line) and '$handle.lines' (all lines). * 'int $obj' is deprecated in favor of '$obj.Int'. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#20) is scheduled for August 20, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! References: [1] Parrot, http://parrot.org/ rakudo-2013.12/docs/announce/2009-080000664000175000017500000000716112224263172016111 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #20 ("PDX") On behalf of the Rakudo development team, I'm pleased to announce the August 2009 development release of Rakudo Perl #20 "PDX". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the August 2009 release is available from http://github.com/rakudo/rakudo/downloads . Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we continue to recommend that people wanting to use or work with Rakudo obtain the latest source directly from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo . Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. August 2009 is code named "PDX" for the Portland Perl Mongers. PDX.pm has been home to several Rakudo contributors (chromatic, Allison Randal, and more) and PDX.pm has held meetings that have produced feature and bugfix patches for Rakudo. Beginning with this release, Rakudo Perl builds from an "installed Parrot" instead of using Parrot's build tree. This release of Rakudo requires Parrot 1.5.0. For the latest information on building and using Rakudo Perl, see the README file section titled "Building and invoking Rakudo". (Quick note: the "--gen-parrot" option still automatically downloads and builds Parrot as before, if you prefer that approach.) Also, unlike previous versions of Rakudo Perl, the "perl6" (or "perl6.exe") executables only work when invoked from the Rakudo root directory until a "make install" is performed. Running "make install" will install Rakudo and its libraries into the Parrot installation that was used to build it, and then the executables will work when invoked from any directory. Some of the specific major changes and improvements occuring with this release include: * Rakudo is now passing 12,369 spectests, an increase of 493 passing tests since the July 2009 release. With this release Rakudo is now passing 69.98% of the available spectest suite. * We now have a much cleaner traits implementation. Many of the Perl 6 built-in traits are now implemented in Perl 6, and user-defined traits can now be defined and applied to classes and roles. * The 'hides' trait on classes can make one class hide another. * Many not-yet-implemented operators and features now provide more helpful error messages instead of simply producing parse errors. * The ROADMAP has been substantially updated and includes some details regarding the "Rakudo Star" release [2]. * Embedded comments now require backticks (Perl 6 specification change). Since the Perl 6 specification is still in flux, some deprecated features will be removed from Rakudo. Prominently among those are: * '=$handle' is deprecated in favor of '$handle.get' (one line) and '$handle.lines' (all lines). * 'int $obj' is deprecated in favor of '$obj.Int'. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#21) is scheduled for September 17, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! References: [1] Parrot, http://parrot.org/ [2] Rakudo Star, http://use.perl.org/~pmichaud/journal/39411 rakudo-2013.12/docs/announce/2009-090000664000175000017500000000665112224263172016115 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #21 ("Seattle") On behalf of the Rakudo development team, I'm pleased to announce the September 2009 development release of Rakudo Perl #21 "Seattle". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine [1]. The tarball for the September 2009 release is available from http://github.com/rakudo/rakudo/downloads . Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we recommend building Rakudo from the latest source, available from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo. Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. September 2009 is code named "Seattle" for the enthusiasm they have shown for Perl 6 during monthly meetings, and the feedback, encouragement and support given me for the past several years. Since the 2009-08 release, Rakudo Perl builds from an "installed Parrot" instead of using Parrot's build tree. This release of Rakudo requires Parrot 1.6.0. For the latest information on building and using Rakudo Perl, see the README file section titled "Building and invoking Rakudo". (Quick note: the "--gen-parrot" option still automatically downloads and builds Parrot as before, if you prefer that approach.) Also, unlike previous versions of Rakudo Perl, the "perl6" (or "perl6.exe") executables only work when invoked from the Rakudo root directory until a "make install" is performed. Running "make install" will install Rakudo and its libraries into the Parrot installation that was used to build it, and then the executables will work when invoked from any directory. Some of the specific major changes and improvements occuring with this release include: * Rakudo is now passing 15,497 spectests, an increase of 3,128 passing tests since the August 2009 release. With this release Rakudo is now passing 71.5% of the available spectest suite. * Rakudo now supports contextual variables. * Rakudo now supports the rational (Rat) data type. * Rakudo now supports overloading of many of the builtin operators, many of which are now defined in the core setting. Many have also been improved to be more faithful to the specification with respect to types and coercions. * Substantially improved support for trait handling. Most of the "built-in" traits are now defined in the core setting. * The %*ENV variable now works properly for modifying the process environment. Since the Perl 6 specification is still in flux, some deprecated features have been removed from Rakudo. Prominently among those are: * '=$handle' is deprecated in favor of '$handle.get' (one line) and '$handle.lines' (all lines). * 'int $obj' is deprecated in favor of '$obj.Int'. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#22) is scheduled for October 22, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! References: [1] Parrot, http://parrot.org/ rakudo-2013.12/docs/announce/2009-100000664000175000017500000000656012224263172016104 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #22 ("Thousand Oaks") On behalf of the Rakudo development team, I'm pleased to announce the October 2009 development release of Rakudo Perl #22 "Thousand Oaks". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the October 2009 release is available from http://github.com/rakudo/rakudo/downloads Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we recommend building Rakudo from the latest source, available from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo. Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. The October 2009 is code named "Thousand Oaks" for their amazing Perl 6 hackathon, their report at http://www.lowlevelmanager.com/2009/09/perl-6-hackathon.html, and just because I like the name :-) Since the 2009-08 release, Rakudo Perl builds from an installed Parrot instead of using Parrot's build tree. This means that, unlike previous versions of Rakudo Perl, the "perl6" (or "perl6.exe") executables only work when invoked from the Rakudo root directory until a "make install" is performed. Running "make install" will install Rakudo and its libraries into the Parrot installation that was used to build it, and then the executables will work when invoked from any directory. This release of Rakudo requires Parrot 1.7.0. For the latest information on building and using Rakudo Perl, see the readme file section titled "Building and invoking Rakudo". (Quick note: the "--gen-parrot" option still automatically downloads and builds Parrot as before, if you prefer that approach.) Some of the specific changes and improvements occuring with this release include: * Rakudo is now passing 32,582 spectests, an increase of 17,085 passing tests since the September 2009 release. With this release Rakudo is now passing 85.0% of the available spectest suite. * We have a huge increase in the number of spectests relating to the Complex and Rat numeric types. * Complex numbers are now implemented as a Perl 6 class, and supports all trigonometric functions from the specification. * Rakudo has a new signature binder which makes calling routines and operators much faster, and allows binding of positional arguments by name. * Rakudo has improved signature introspection, better errors relating to signatures and signature literals are now supported. * Rakudo now supports accessing outer lexical variables from classes and packages. * Some new variants of the series operator are now implemented. * When configuring Rakudo with --gen-parrot, the --optimize flag is now passed to Parrot's Configure.pl The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#23) is scheduled for November 19, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2009-110000664000175000017500000000603412224263172016101 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #23 ("Lisbon") On behalf of the Rakudo development team, I'm pleased to announce the November 2009 development release of Rakudo Perl #23 "Lisbon". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the November 2009 release is available from http://github.com/rakudo/rakudo/downloads Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we recommend building Rakudo from the latest source, available from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo. Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. The November 2009 release is code named "Lisbon" for Lisbon.pm, who did a marvellous job arranging this year's YAPC::EU. Shortly after the October 2009 (#22) release, the Rakudo team began a new branch of Rakudo development ("ng") that refactors the grammar to much more closely align with STD.pm as well as update some core features that have been difficult to achieve in the master branch [1, 2]. Most of our effort for the past month has been in this new branch, but as of the release date the new version had not sufficiently progressed to be the release copy. We expect to have the new version in place in the December 2009 release. This release of Rakudo requires Parrot 1.8.0. One must still perform "make install" in the Rakudo directory before the "perl6" executable will run anywhere other than the Rakudo build directory. For the latest information on building and using Rakudo Perl, see the readme file section titled "Building and invoking Rakudo". Some of the specific changes and improvements occuring with this release include: * Rakudo is now passing 32,753 spectests, an increase of 171 passing tests since the October 2009 release. With this release Rakudo is now passing 85.5% of the available spectest suite. * As mentioned above, most development effort for Rakudo in November has taken place in the "ng" branch, and will likely be reflected in the December 2009 release. * Rakudo now supports unpacking of arrays, hashes and objects in signatures * Rakudo has been updated to use Parrot's new internal calling conventions, resulting in a slight performance increase. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#24) is scheduled for December 17, 2009. A list of the other planned release dates and codenames for 2009 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://use.perl.org/~pmichaud/journal/39779 [2] http://use.perl.org/~pmichaud/journal/39874 rakudo-2013.12/docs/announce/2009-120000664000175000017500000000730612224263172016105 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #24 ("Seoul") On behalf of the Rakudo development team, I'm pleased to announce the December 2009 development release of Rakudo Perl #24 "Seoul". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the December 2009 release is available from http://github.com/rakudo/rakudo/downloads Due to the continued rapid pace of Rakudo development and the frequent addition of new Perl 6 features and bugfixes, we recommend building Rakudo from the latest source, available from the main repository at github. More details are available at http://rakudo.org/how-to-get-rakudo. Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. The December 2009 release is code named "Seoul" for Seoul.pm, who hosted Jonathan so well recently, and because they have a cake duck. Shortly after the October 2009 (#22) release, the Rakudo team began a new branch of Rakudo development ("ng") that refactors the grammar to much more closely align with STD.pm as well as update some core features that have been difficult to achieve in the master branch [1, 2]. Most of our effort for the past month has been in this new branch, but as of the release date the new version had not sufficiently progressed to be the release copy. We expect to have the new version in place in the January 2010 release, but may elect to have an interim release from the new branch before then. This release of Rakudo requires Parrot 1.9.0. One must still perform "make install" in the Rakudo directory before the "perl6" executable will run anywhere other than the Rakudo build directory. For the latest information on building and using Rakudo Perl, see the readme file section titled "Building and invoking Rakudo". Some of the specific changes and improvements occuring with this release include: * Rakudo is now passing 32,192 spectests, a "decrease" of 561 passing tests since the November 2009 release. We pass fewer tests now because specification changes caused many obsolete (but passing) tests to be removed from the suite -- from 38,318 in November to 37,376 now. The percentage of passing tests has increased, from 85.5% in November to 86.1% today. * More improvements to the Rat type and related math functions to remain aligned with the specification. The Perl 6 language specification is still in flux. Please take note of the following changes, which might affect your existing programs. In the next release of Rakudo, the deprecated features will likely be gone. * The root of the object hierarchy has been changed from 'Object' to 'Mu'. The type 'Object' goes away. * The term 'undef' is gone. You can replace it with other constructs, depending on context: - 'Nil' is undefined in item context, and the empty list in list context - 'Mu' is the most general undefined value which does not flatten in list context - as a smart matching target, you can replace '$obj ~~ undef' by '$obj ~~ *.notdef' The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#25) is scheduled for January 21, 2010. A list of the other planned release dates and codenames for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://use.perl.org/~pmichaud/journal/39779 [2] http://use.perl.org/~pmichaud/journal/39874 rakudo-2013.12/docs/announce/2010-010000664000175000017500000001000712224263172016063 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #25 ("Minneapolis") On behalf of the Rakudo development team, I'm pleased to announce the January 2010 development release of Rakudo Perl #25 "Minneapolis". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the January 2010 release is available from http://github.com/rakudo/rakudo/downloads . Rakudo Perl follows a monthly release cycle, with each release code named after a Perl Mongers group. The January 2010 release is code named "Minneapolis" for Minneapolis.pm, hosts of the annual Frozen Perl Workshop [1]. In 2009 the Frozen Perl Workshop featured a one-day hackathon for Perl 6 and Rakudo development, which ultimately informed the design and implementation of the current build system. (The 2010 Frozen Perl Workshop will be on February 6, 2010, for those interested in attending.) Shortly after the October 2009 (#22) release, the Rakudo team began a new branch of Rakudo development ("ng") that refactors the grammar to much more closely align with STD.pm as well as update some core features that have been difficult to achieve in the master branch [2, 3]. We had planned for this release to be created from the new branch, but holiday vacations and other factors conspired against us. This is absolutely the final release from the old development branch; we expect to make the new branch the official "master" branch shortly after this release. This release of Rakudo requires Parrot 2.0.0. One must still perform "make install" in the Rakudo directory before the "perl6" executable will run anywhere other than the Rakudo build directory. For the latest information on building and using Rakudo Perl, see the README file section titled "Building and invoking Rakudo". Some of the specific changes and improvements occuring with this release include: * Rakudo is now passing 31,957 spectests, or 85.7% of the available test suite. This is roughly the same level as the December 2009 release (because most effort has taken place in the "ng" branch as described above). * Rakudo's calling conventions have been updated to match changes in Parrot 2.0.0's calling and context structures. The Perl 6 language specification is still in flux. Please take note of the following changes, which might affect your existing programs. In the next release of Rakudo, the deprecated features will likely be gone. * The root of the object hierarchy has been changed from 'Object' to 'Mu'. The type 'Object' goes away. * The term 'undef' is gone. You can replace it with other constructs, depending on context: - 'Nil' is undefined in item context, and the empty list in list context - 'Mu' is the most general undefined value which does not flatten in list context - as a smart matching target, you can replace '$obj ~~ undef' by '$obj ~~ *.notdef' * Builtin classes will derive from 'Cool' (which itself derives from 'Any'). Most of the builtin methods on these classes will be defined in the 'Cool' class instead of 'Any'. See Synopsis 2 for more details. * Starting with the next release, we will likely switch to using "YYYY.MM" instead of "YYYY-MM" (dot instead of hyphen) as release identifiers. This is intended to simplify building and packaging for other distribution systems. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#26) is scheduled for February 18, 2010. A list of the other planned release dates and codenames for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://www.frozen-perl.org/ [2] http://use.perl.org/~pmichaud/journal/39779 [3] http://use.perl.org/~pmichaud/journal/39874 rakudo-2013.12/docs/announce/2010.020000664000175000017500000001016012224263172016065 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #26 ("Amsterdam") On behalf of the Rakudo development team, I'm pleased to announce the February 2010 development release of Rakudo Perl #26 "Amsterdam". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the February 2010 release is available from http://github.com/rakudo/rakudo/downloads . Rakudo Perl follows a monthly release cycle, with each release named after a Perl Mongers group. The February 2010 release is code named "Amsterdam" for the largest chapter of the Dutch Perl Mongers. Perl development enjoys considerable support from the Netherlands, with donations from NLNet, and hosting of the feather machines and several important Perl 6 web domains and sites. This release is the first release based on the new branch of Rakudo development begun in October 2009. The branch refactors the grammar, object metamodel, and a number of other key features to improve compatibility with the Perl 6 specification and give us a more solid foundation to build on. Indeed, in many ways the development of this new branch has driven important changes to the specification in the areas of lists, iterators, slices, and much more. However, this release contains a number of significant regressions from previous compiler releases. We expect to have full functionality restored in this branch in the next couple of weeks. For those looking to explore a wide variety of Perl 6 features or who have applications developed using previous releases of Rakudo, you may wish to continue to use the January 2010 (#25, "Minneapolis") release. This release of Rakudo requires Parrot 2.1.0. One must still perform "make install" in the Rakudo directory before the "perl6" executable will run anywhere other than the Rakudo build directory. For the latest information on building and using Rakudo Perl, see the README file section titled "Building and invoking Rakudo". Some of the specific changes and improvements occuring with this release include: * Now using nqp-rx for parsing and actions * Grammar is much closer to STD in many aspects, and makes use of protoregexes * Closures and lexical/contextual variable declarations in regexes work * Laziness is implemented * All class and role construction is handled through the meta-model The Perl 6 language specification is still in flux. Please take note of the following changes, which might affect your existing programs. In the next release of Rakudo, the deprecated features will likely be gone. * The root of the object hierarchy has been changed from 'Object' to 'Mu'. The type 'Object' goes away. * The term 'undef' is gone. You can replace it with other constructs, depending on context: - 'Nil' is undefined in item context, and the empty list in list context - 'Mu' is the most general undefined value which does not flatten in list context - as a smart matching target, you can replace '$obj ~~ undef' by '$obj ~~ *.notdef' * Builtin classes will derive from 'Cool' (which itself derives from 'Any'). Most of the builtin methods on these classes will be defined in the 'Cool' class instead of 'Any'. See Synopsis 2 for more details. * Starting with the this release, release identifiers are given as "YYYY.MM" instead of "YYYY-MM" (dot instead of hyphen). This is intended to simplify building and packaging for other distribution systems. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#27) is scheduled for March 18, 2010. A list of the other planned release dates and codenames for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://www.frozen-perl.org/ [2] http://use.perl.org/~pmichaud/journal/39779 [3] http://use.perl.org/~pmichaud/journal/39874 rakudo-2013.12/docs/announce/2010.030000664000175000017500000000536212224263172016076 0ustar moritzmoritzAnnounce: Rakudo Perl 6 development release #27 ("Copenhagen") On behalf of the Rakudo development team, I'm pleased to announce the March 2010 development release of Rakudo Perl #27 "Copenhagen". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the March 2010 release is available from http://github.com/rakudo/rakudo/downloads . Rakudo Perl follows a monthly release cycle, with each release named after a Perl Mongers group. The March 2010 release is code named "Copenhagen" for Copenhagen.pm, hosts of the Perl 6 Copenhagen Hackathon [1], which took place in connection with the Open Source Days Conference. The main goal of the hackathon was to raise some awareness around Perl 6, and to give everyone a chance to get their hands-on with Perl 6. The Copenhagen hackathon helped nail down a number of issues regarding module loading. During these days we also saw a heightened activity on the channel, in the Perl 6 and Rakudo repositories, and in the number of passing tests. All this was contributed by people both on location and elsewhere. The RT queue peaked at 725 new/open tickets, and then started on a downward trend. Apart from the great steps forward in productivity, it was the first time some of the core Perl 6 contributors had a chance to meet. Some of the specific changes and improvements occuring with this release include: * Numerous updates to trigonometric functions and the Rat class * Basic s/// and s[...] = '...' implemented * use improved and need/import implemented, with some basic support for versioned modules and lexical importation * Grammars work again and now include support for regexes taking parameters and proto-regexes * Series operator now has basic support for the current Spec. * User defined operators working again * Support, though with caveats, for !, R, X and Z meta-operators * Performance improvements for invocation and hash creation * Various parsing bugs fixed * Variables initialized to Any by default now, not Mu * ROADMAP updates For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#28) is scheduled for April 22, 2010. A list of the other planned release dates and codenames for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://conferences.yapceurope.org/hack2010dk/ rakudo-2013.12/docs/announce/2010.040000664000175000017500000000435712224263172016102 0ustar moritzmoritz Announce: Rakudo Perl 6 development release #28 ("Moscow") On behalf of the Rakudo development team, I'm pleased to announce the March 2010 development release of Rakudo Perl #28 "Moscow". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the April 2010 release is available from http://github.com/rakudo/rakudo/downloads . Rakudo Perl follows a monthly release cycle, with each release named after a Perl Mongers group. The April 2010 release is code named "Moscow" in recognition of Москва.пм and their invitation of Jonathan Worthington, one of our core develepors, to speak at the Russian Internet Technologies 2010 [1] conference. Some of the specific changes and improvements occuring with this release include: * Expressions that begin with a variable and end with a circumfix now properly interpolate into double-quoted strings, like "@array.sort()" or "%hash". * Item assignment now has tighter precdence than list assignment, so both 'my @a = 1, 2, 3' and '$a = 1, $b = 2' magically work. * Most of the DateTime built-in type has been backported from the "alpha" branch, and is now accompanied by a Date type for date-only calculations. * Many obsolete uses of Perl 5 constructs are now caught and give helpful error messages. * As always, many additional small features and bug fixes make working with Rakudo more pleasant. * Rakudo now passes 30,931 spectests. We estimate that there are about 39,000 tests in the test suite, so Rakudo passes about 79% of all tests. For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible. If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#29) is scheduled for May 20, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1]: http://ritconf.ru/ rakudo-2013.12/docs/announce/2010.050000664000175000017500000000500512224263172016072 0ustar moritzmoritz Announce: Rakudo Perl 6 development release #29 ("Erlangen") On behalf of the Rakudo development team, I'm pleased to announce the May 2010 development release of Rakudo Perl #29 "Erlangen". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see http://www.parrot.org). The tarball for the May 2010 release is available from http://github.com/rakudo/rakudo/downloads . Rakudo Perl follows a monthly release cycle, with each release named after a Perl Mongers group. The May 2010 release is code named "Erlangen" in recognition of Erlangen.pm and the Perl 6 talk that Moritz Lenz, one of our core developers, gave this month. Some of the specific changes and improvements occurring with this release include: * Lexical classes and roles were implemented. Additionally, anonymous classes -- which were never quite right in alpha -- are now implemented more correctly, and anonymous roles are also supported. * Basic support for named enumerations of the form 'enum Weekday ' has been restored. * First cut of use Foo:from and eval('foo', :lang); needs Blizkost[1] to be installed to work. * Numeric / Real roles much closer to the spec now. * As always, many additional small features and bug fixes make working with Rakudo more pleasant. * Rakudo now passes 32,347 spectests. We estimate that there are about 39,500 tests in the test suite, so Rakudo passes about 82% of all tests. For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Solomon Foster, Moritz Lenz, Jonathan Worthington, Martin Berends, chromatic, Carl Masak, snarkyboojum, Stefan O'Rear, Reini Urban, Jonathan Scott Duff, takadonet, Christoph Otto, isBEKaml, ash_, bubaflub, Jimmy Zhuo, Peter Lobsinger and Patrick Abi Salloum If you would like to contribute, see http://rakudo.org/how-to-help , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#30) is scheduled for June 17, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://github.com/jnthn/blizkostrakudo-2013.12/docs/announce/2010.060000664000175000017500000000567412224263172016107 0ustar moritzmoritz Announce: Rakudo Perl 6 development release #30 ("Kiev") On behalf of the Rakudo development team, I'm pleased to announce the June 2010 development release of Rakudo Perl #30 "Kiev". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the June 2010 release is available from . Rakudo Perl follows a monthly release cycle, with each release named after a Perl Mongers group. This release is named after the Perl Mongers from the beautiful Ukrainian capital, Kiev. They recently helped organize and participated in the Perl Mova + YAPC::Russia conference, the хакмит (hackathon) of which was a particular success for Rakudo. All those who joined the Rakudo hacking - from Kiev and further afield - contributed spec tests as well as patches to Rakudo, allowing various RT tickets to be closed, and making this month's release better. Дякую! Some of the specific changes and improvements occurring with this release include: * Rakudo now uses immutable iterators internally, and generally hides their existence from programmers. Many more things are now evaluated lazily. * Backtraces no longer report routines from Parrot internals. This used to be the case in the Rakudo alpha branch as well, but this time they are also very pleasant to look at. * Match objects now act like real hashes and arrays. * Regexes can now interpolate variables. * Hash and array slicing has been improved. * The REPL shell now prints results, even when not explicitly asked to print them, thus respecting the "P" part of "REPL". * Rakudo now passes 33,378 spectests. We estimate that there are about 39,900 tests in the test suite, so Rakudo passes about 83% of all tests. For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Patrick R. Michaud, Moritz Lenz, Jonathan Worthington, Solomon Foster, Patrick Abi Salloum, Carl Mäsak, Martin Berends, Will "Coke" Coleda, Vyacheslav Matjukhin, snarkyboojum, sorear, smashz, Jimmy Zhuo, Jonathan "Duke" Leto, Maxim Yemelyanov, Stéphane "cognominal" Payrard, Gerd Pokorra, Bruce Keeler, Ævar Arnfjörð Bjarmason, Shrivatsan, Hongwen Qiu, quester, Alexey Grebenschikov, Timothy Totten If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#31) is scheduled for July 22, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2010.070000664000175000017500000000557012224263172016103 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #31 ("Atlanta") On behalf of the Rakudo development team, I'm happy to announce the July 2010 development release of Rakudo Perl #31 "Atlanta". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the July 2010 release is available from . Please note: This is not the Rakudo Star release, which is scheduled for July 29, 2010 [1]. The Star release will include the compiler, an installer, modules, a book (PDF), and more. The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The July 2010 release is code named "Atlanta" in recognition of Atlanta.pm and their Perl 5 Phalanx project [2], which they selected for its benefits to Perl 6. Some of the specific changes and improvements occurring with this release include: * Rakudo now properly constructs closures in most instances. * Undefined objects can now autovivify into arrays or hashes when subscripted with .[ ] or .{ } . * Arrays can now handle infinite ranges. * Generic, multi-level Whatever-currying now works, e.g. (1, 1, *+* ... *). * The REPL shell now remembers lexical declarations in susbsequent lines. * The open() subroutine now returns a Failure instead of throwing a fatal exception. * Rakudo now provides $*ARGFILES for reading from files specified on the command line. * Added $*PERL, moved %*VM to $*VM. * Simple binding operators := and ::= now work. * Simple feed operators <== and ==> now work. For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Patrick R. Michaud, Jonathan Worthington, Moritz Lenz, Solomon Foster, Carl Masak, Bruce Gray, Martin Berends, chromatic, Will "Coke" Coleda, Matthew (lue), Timothy Totten, maard, Kodi Arfer, TimToady, Stephen Weeks, Patrick Abi Salloum, snarkyboojum, Radu Stoica, Vyacheslav Matjukhin, Andrew Whitworth, cognominal, Tyler Curtis, Alex Kapranoff, Ingy döt Net, Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯, mathw, lue, Вячеслав Матюхин If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#32) is scheduled for August 19, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://rakudo.org/node/73 [2] http://code.google.com/p/atlanta-pm-code/ rakudo-2013.12/docs/announce/2010.080000664000175000017500000000541312224263172016100 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #32 ("Pisa") On behalf of the Rakudo development team, I'm happy to announce the August 2010 release of Rakudo Perl #32 "Pisa". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the August 2010 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The August 2010 release is code named "Pisa" in recognition of its excellent work in organizing YAPC::EU 2010, "The Renaissance of Perl" [1,2]. Many Rakudo developers presented at the conference, and it was an excellent location for a hackathon and planning the next phases of Rakudo development. Some of the specific changes and improvements occurring with this release include: * Due to a specification change, Nil is now undefined, and no longer simply an empty Parcel. * Many modifiers are now recognized on the outside of regexes and substitutions, for example s:g:samecase/abc/defg/ * Improvements to the performance of integer operations * Initial implementations of .pack and .unpack methods for the Buf class * Smartmatching against True or False is now an error. Most people who did this really wanted to look at the return value of .so instead. For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Patrick R. Michaud, Solomon Foster, Will "Coke" Coleda, Carl Mäsak, Jonathan Worthington, Bruce Gray, Patrick Abi Salloum, tylercurtis, Kyle Hasselbacher, Tadeusz Sośnierz, Jonathan Scott Duff, Christopher J. Madsen, Kodi Arfer, Reini Urban, TimToady, felliott, Matt Kraai, Jan Ingvoldstad, szabgab, madsen, Andy Lester, cosimo, Fitz Elliott If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#33) is scheduled for September 23, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! [1] http://www.perl.it/ [2] http://conferences.yapceurope.org/ye2010/ rakudo-2013.12/docs/announce/2010.090000664000175000017500000000540712224263172016104 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #33 ("Milan") On behalf of the Rakudo development team, I'm happy to announce the August 2010 release of Rakudo Perl #33 "Milan". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the September 2010 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The September 2010 release is code named "Milan", because the release manager happens to like the name :-) Some of the specific changes and improvements occurring with this release include: * The specification for temporal objects (DateTime, Date, Instant and Duration) is now completely implemented in Rakudo * Several performance improvements were implemented, most notably in slurp() and reverse() functions * The series operator has been refactored, and updated to the current specification * Enumeration objects now conform much closer to the current specification * 'now' and 'time' are now terms (and not functions anymore). This means you can now write 'time - 1' and do what you mean, but 'time()' does not work anymore For a more detailed list of changes see "docs/ChangeLog". Deprecation notice: * Currently True and False evaluate as '1' and '0' in string context. The specification has changed, and in the next release they will evaluate to 'Bool::True' and 'Bool::False' in string context. To get the old behaviour, use ~+True or ~+False. The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Patrick R. Michaud, Carl Masak, Patrick Abi Salloum, Solomon Foster, Kodi Arfer, chromatic, Kyle Hasselbacher, Bruce Gray, Martin Berends, Stephane Payrard, Tyler Curtis, Shlomi Fish, Nick Wellnhofer, Nuno Carvalho, Tadeusz Sośnierz, TiMBuS, NotFound, mathw If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#34) is scheduled for October 21, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2010.100000664000175000017500000000447012224263172016073 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #34 ("Paris") On behalf of the Rakudo development team, I'm happy to announce the October 2010 release of Rakudo Perl #34 "Paris". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the October 2010 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The October 2010 release is code named "Paris", because the of the Perl love at the Open Source Developers Conference held in Paris, France earlier in the month. Some of the specific changes and improvements occurring with this release include: * we now have a simple version of require * the local timezone is available in $*TZ * samespace versions of m// and s/// were implemented as ms// and ss/// respectively. * Str.flip is now 100 times faster than it used to be * the subroutine version of Str.comb now exists * Hyperoperators can now be applied to infix:<+=> and friends. * improved diagnostic messages For a more detailed list of changes see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Kodi Arfer, Patrick R. Michaud, Bruce Gray, Carl Masak, Ronald Schmidt, Jonathan Worthington, TimToady, TimTom, PhatEddy, Patrick Abi Salloum, and your humble release manager Jonathan Scott Duff. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#35) is scheduled for November 18, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2010.110000664000175000017500000000414412224263172016072 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #35 ("Melbourne") On behalf of the Rakudo development team, I'm happy to announce the November 2010 release of Rakudo Perl #35 "Melbourne". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the November 2010 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The November 2010 release is code named "Melbourne", PM group of Damian Conway, long-time advocate/explicator of and contributor to Perl 6. Some of the specific changes and improvements occurring with this release include: * qw// is now implemented * .trans is now 5 times faster * indexing is now possible with both ranges and Whatever offsets together: @a[0 .. *-2] For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Solomon Foster, Kodi Arfer, Tadeusz Sośnierz, Nick Wellnhofer, Jonathan Scott Duff, Bruce Gray, Jonathan Worthington, Patrick R. Michaud, mikehh, flussence, Jan Ingvoldstad, and your humble release manager Carl Mäsak. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#36) is scheduled for December 23, 2010. A list of the other planned release dates and code names for 2010 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2010.120000664000175000017500000000400612224263172016070 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #36 ("New York") On behalf of the Rakudo development team, I'm happy to announce the December 2010 release of Rakudo Perl #36 "New York". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the December 2010 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The December 2010 release is code named "New York" the first PM group, created by brian d foy, in tribute to Perl's 23rd anniversary, which was celebrated on the 18th of this month. Some of the specific changes and improvements occurring with this release include: * new .trans algorithm * configuration improvements * several bug fixes For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Carl Masak, Solomon Foster, Kodi Arfer, Fernando Brito, Tomoki Aonuma, Nick Wellnhofer, Patrick R. Michaud, Abi Salloum, frettled, smashz and Jonathan Scott Duff. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#37) is scheduled for January 20, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.010000664000175000017500000000413412224263172016071 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #37 ("BristolBath") On behalf of the Rakudo development team, I'm happy to announce the January 2011 release of Rakudo Perl #37 "BristolBath". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the January 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The December 2010 release is code named after Bristol & Bath Perl Mongers group. Some of the specific changes and improvements occurring with this release include: * faster subroutine calls (type cache) * implemented 'handles Rolename' trait * 'use Devel::Trace' debugging pragma * improved parsing of keyword boundaries * faster .comb For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Kodi Arfer, smashz, Jonathan Worthington, Solomon Foster, Tadeusz Sośnierz, Kyle Hasselbacher, Patrick R. Michaud, Jonathan Scott Duff, Fitz Elliott, Adrian White, Christoph Otto, Stefan O'Rear, Michael H. Hind, Vasily Chekalkin and Hongwen Qiu. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#38) is scheduled for February 17, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.020000664000175000017500000000403012224263172016065 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #38 ("Toulouse") On behalf of the Rakudo development team, I'm happy to announce the February 2011 release of Rakudo Perl #38 "Toulouse". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the February 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The February 2011 release is code named "Toulouse". Some of the specific changes and improvements occurring with this release include: * basic IPv6 support * new --ll-backtrace command line option for low level backtraces * the negation meta operator can now only be applied to operators where it makes sense. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Solomon Foster, Kodi Arfer, Tadeusz Sośnierz, Patrick R. Michaud, Carl Masak, Jonathan Scott Duff, Jonathan Worthington, Vasily Chekalkin, Will "Coke" Coleda, Michael Stapelberg, Arne Skjærholt, Fitz Elliott If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#39) is scheduled for March 17, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.030000664000175000017500000000377212224263172016102 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #39 ("Orlando") On behalf of the Rakudo development team, I'm happy to announce the March 2011 release of Rakudo Perl #39 "Orlando". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the March 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The March 2011 release is code named "Orlando". Some of the specific changes and improvements occurring with this release include: * an improved error message on type check failure in assignment * -n and -p command line options * complex conjugation support implemented For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Tadeusz Sośnierz, Carl Masak, Arne Skjærholt, William Orr, Kyle Hasselbacher, Jonathan Scott Duff, Dave Whipp, Jonathan Worthington, martin, Solomon Foster, JD Horelick, Jimmy Zhuo, Martin Berends, Patrick Abi Salloum, JimmyZ If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#40) is scheduled for April 21, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.040000664000175000017500000000407212224263172016075 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #40 ("ZA") On behalf of the Rakudo development team, I'm happy to announce the April 2011 release of Rakudo Perl #40 "ZA". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the April 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The April 2011 release is code named "ZA" after ZA.pm in Grahamstown, Eastern Cape, South Africa because the denizens of #perl6 have an unusual facination with zebras and ZA just happens to have a "Z" and, according to my meager research, there are indeed zebras in the area. :-) Some of the specific changes and improvements occurring with this release include: * implemented Str.indent * A new, much simpler API and implemention of IO::Socket::INET For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Tadeusz Sośnierz, Martin Berends, Andy Lester, Jonathan Scott Duff, flussence, Patrick Abi Salloum, Carl Masak, Jarrod If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#41) is scheduled for May 19, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.050000664000175000017500000000357612224263172016106 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #41 ("Dahut") On behalf of the Rakudo development team, I'm happy to announce the May 2011 release of Rakudo Perl #41 "Dahut". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the May 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The May 2011 release is code named "Dahut". Some of the specific changes and improvements occurring with this release include: * added a call counter for builtins in Perl 6-level subroutines * gcd (greatest common divisor) and lcm (largest common multiple) operators * implemented Int.base For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Patrick R. Michaud, Moritz Lenz, Jonathan Scott Duff, Tadeusz Sośnierz, Carl Masak, Solomon Foster, bacek If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#42) is scheduled for June 23, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.060000664000175000017500000000457712224263172016111 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #42 ("Bruxelles") On behalf of the Rakudo development team, I'm happy to announce the June 2011 release of Rakudo Perl #42 "Bruxelles". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the June 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The June 2011 release is code named "Bruxelles". DON'T PANIC: Browsing the change log below, it might appear as though not much Rakudo development is taking place. Nearly all of the development activity is now occurring in the "nom" branch of the Rakudo repository (over 500 commits since the 2011.05 release). This new branch will shortly become the mainline branch from which monthly releases are made, and already contains many important bugfixes and performance improvements. Some of the specific changes and improvements occurring in the master branch with this release include: * Fixed a bug with &infix:<=> when used in multiple assignments to aggregate elements. * Improved parrot register handling for more efficient code. * Added take-rw and return-rw functions. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Patrick R. Michaud, Moritz Lenz, Martin Berends, Tadeusz Sośnierz, JD Horelick, and others. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#43) is scheduled for July 21, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun and don't forget your towel! rakudo-2013.12/docs/announce/2011.070000664000175000017500000000526412224263172016104 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #43 ("Beijing") On behalf of the Rakudo development team, I'm happy to announce the July 2011 release of Rakudo Perl #43 "Beijing". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for the July 2011 release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The July 2011 release is code named "Beijing" after the host of the Beijing Perl Workshop 2011, which featured several Perl 6 related talks. This will be the last compiler release made from the current "master" branch of Rakudo. For the past several months, Rakudo compiler development has primarily occurred in the "nom" branch of the Rakudo repository (over 1200 commits since the 2011.05 release). Shortly after this release, the "nom" branch will become the new "master" branch and will be the source for future releases, including the 2011.08 release. We expect there will be several releases in the near future -- watch http://rakudo.org/ for details. Some of the specific changes and improvements occurring in the master branch with this release include: * Fix bug in exponentation of negative numbers * Fix build on systems with little RAM For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Patrick R. Michaud, atrodo, Solomon Foster, bacek and others. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. Rakudo has traditionally released two days after each Parrot monthly release. Because the new version of the compiler has additional dependencies beyond Parrot, starting in August 2011 we will make releases sometime in the week following each monthly Parrot release. (Parrot releases occur on the third Tuesday of each month.) Thus the next regular release of Rakudo will occur sometime before August 23, 2011. We also expect to have additional "pre-release" versions of Rakudo and Rakudo Star prior to that date. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. rakudo-2013.12/docs/announce/2011.090000664000175000017500000000762112224263172016105 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #44 ("Riga") On behalf of the Rakudo development team, I'm happy to announce the September 2011 release of Rakudo Perl #44 "Riga". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The September 2011 release is code named after the host city of the YAPC::EU 2011 conference, which included a very successful Perl 6 track and hackathon. This is the first compiler release from the latest development branch of Rakudo. It brings many exciting improvements, but also some regressions, which we are working on. If your primary interest is that your existing code running on Rakudo Perl continues to work, we suggest sticking with the Rakudo Star distribution release for a little longer. If instead you want to play with the latest in Rakudo development - including meta-programming and performance improvements - try this release. Some of the specific changes and improvements occurring with this release include: * numerous speedups * Int, Num and Str are now far more lightweight * int/num as attributes are stored compactly in the object body * meta objects are now much easier to modify * a Pod parser capable of attaching documentation to objects * --doc command line option producing formatted documentation * much more robust handling of infinite list * basic LoL (List of Lists) support * :U and :D type modifiers * improved handling of BEGIN phasers * protos and multis now conform to the new spec * improved enum support * basic 'constant' declarator * .WHAT and friends as macros * support for .gist * run() has been renamed to shell() to conform to current spec * hyper methods now descend into nested data structures * basic safe mode (through --seting=SAFE) * many bug fixes in parametric roles * a custom BUILD does not suppress default values * undeclared attributes detected and reported at compile time * basic support for native int/num types on lexical variables * a new regex engine We briefly regress on a few features since the previous release. Most notably, new regex engine has not implemented proto regexes yet, and only integer-based enums are available. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Patrick R. Michaud, Tadeusz Sośnierz, Will "Coke" Coleda, Solomon Foster, Kodi Arfer, Carl Mäsak, Martin Berends, kboga, Jonathan Scott Duff, Michael Schröder, JD Horelick, TimToady, Arne Skjærholt, Kyle Hasselbacher, flussence, Dave Whipp, William Orr, Jimmy Zhuo, Andy Lester, Patrick Abi Salloum, Fitz Elliott, snarkyboojum, Ruslan Zakirov, Vasily Chekalkin, kristof, Stefan O'Rear, Geoff Broadwell, Martin Kjeldsen, supernovus, Timothy Totten, Felix Herrmann, Jarrod, mikehh, Michael Stapelberg, baest, Erik Johansen, bbkr If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#45) is scheduled for October 20, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur two days after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have fun! rakudo-2013.12/docs/announce/2011.100000664000175000017500000000701712224263172016074 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #45 ("Houston") On behalf of the Rakudo development team, I'm happy to announce the October 2011 release of Rakudo Perl #45 "Houston". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The October 2011 release is code named after the Houston Perl Mongers because Houston is a large city in Texas and because Perl 6 could always use more features from Texas. Oh ... and Houston also hosted YAPC::NA 2007 and had a nice Perl 6 hackathon. :-) This compiler release is from the latest development branch of Rakudo. It brings many exciting improvements, but also some regressions, which we are working on. If your primary interest is that your existing code running on Rakudo Perl continues to work, we suggest sticking with the Rakudo Star distribution release for a little longer. If instead you want to play with the latest in Rakudo development - including meta- programming and performance improvements - try this release. Some of the specific changes and improvements occurring with this release include: * Optimizations tuneable from the command line * native types on various operators * Fix start up error when $HOME environment variable isn't set * Fix C3 MRO bug * Start at implementing global matching (m:g//) * Various performance improvements We are still regressed on a few features just as in the previous release. These regressions should be rectified in coming releases. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Will "Coke" Coleda, Tadeusz Sośnierz, Patrick R. Michaud, Jonathan Scott Duff, Carl Masak, Geoffrey Broadwell, mls, snarkyboojum, gfldex, TimToady, TiMBuS, JimmyZ If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#46) is scheduled for November 17, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. As always ... Have fun! [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enchance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2011.110000664000175000017500000000720512224263172016074 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #46 ("London") On behalf of the Rakudo development team, I'm happy to announce the November 2011 release of Rakudo Perl #46 "London". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The November 2011 release is code named after the London Perl Mongers, organizers of many London Perl Workshops, including the 2011 edition that took place this month. Over 200 people showed up for this great event, which had some Perl 6 talks amongst the schedule. This compiler release is from the latest development branch of Rakudo. It brings many exciting improvements, but also some regressions compared to the compiler release shipped with the latest Rakudo Star distribution. If your primary interest is that your existing code running on Rakudo Perl continues to work, we suggest sticking with the Rakudo Star distribution release for a little longer; we are aiming to issue a Rakudo Star based on this development branch in December. If instead you want to play with the latest in Rakudo development - including meta-programming and performance improvements - try this release. Some of the specific changes and improvements occurring with this release include: * Big integer support * Basic protoregex support with NFA-driven LTM for some declarative constructs * CATCH blocks are now much closer to spec, and thus much more useful * Improved support for MAIN argument parsing We are still regressed on a few features just as in the previous release. These regressions should be rectified in coming releases. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Will "Coke" Coleda, Tadeusz Sośnierz, Geoffrey Broadwell, Solomon Foster, Jonathan Scott Duff, Michael Schroeder, Carl Masak, Geoff Broadwell, not_gerd and coto If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#47) is scheduled for December 22, 2011. A list of the other planned release dates and code names for 2011 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have a great deal of fun! [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enchance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2011.120000664000175000017500000000574212224263172016101 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #47 ("Columbus") On behalf of the Rakudo development team, I'm happy to announce the November 2011 release of Rakudo Perl #47 "Columbus". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The December 2011 release is code named after the Columbus Perl Mongers, organizers of YAPC::NA 2010, which featured a Perl 6 track and hackathon. Some of the specific changes and improvements occurring with this release include: * Many regex improvements, including escapes in character classes look-around assertions and many bug fixes * Several performance improvements * Defining new operators, flip flop operators, and the Proxy class are now supported We are still regressed on a few features compared to the 2011.07 release of Rakudo, the most notable of which is autovivification. These regressions should be rectified in coming releases. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Will "Coke" Coleda, Michael Schroeder, Tadeusz Sośnierz, Solomon Foster, Zohar Kelrich, diakopter, JimmyZ, Jonathan Scott Duff, Geoffrey Broadwell, Woodi If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#48) is scheduled for January 19, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have a great deal of fun! [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.010000664000175000017500000000555612224263172016103 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #48 ("Toronto") On behalf of the Rakudo development team, I'm happy to announce the January 2012 release of Rakudo Perl #48 "Toronto". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The January 2012 release is code named after the Toronto Perl Mongers, organizers of YAPC::NA 2005, which featured a Perl 6 hackathon. Some of the specific changes and improvements occurring with this release include: * regex backtracking into subrules and captures now works * -c (compilation check) command line option works again * better parameter introspection * many bugfixes We are still regressed on a few features compared to the 2011.07 release of Rakudo, the most notable of which is autovivification. These regressions should be rectified in coming releases. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Kris Shannon, Tadeusz Sośnierz, kboga, Carl Masak, Bruce Gray, Solomon Foster, Geoffrey Broadwell, not_gerd, wollmers. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#49) is scheduled for February 23, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. Have a great deal of fun! [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.020000664000175000017500000000574012224263172016077 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #49 ("SPb") On behalf of the Rakudo development team, I'm happy to announce the February 2012 release of Rakudo Perl #49 "SPb". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The February 2012 release is code named after the Saint Petersburg Perl Mongers, because Saint Petersburg as a city has provided unmatched inspiration and clarity to at least two Rakudo programmers. Some of the specific changes and improvements occurring with this release include: * Regex syntax: and * &rename and © functions * LHS of infix: now thunks as per spec * Improved backtraces * Rat arithmetic falling back to Num when needed; FatRat * Object hashes * Int($x)-style coercions We are still regressed on a few features compared to the 2011.07 release of Rakudo, the most notable of which is autovivification. These regressions should be rectified in coming releases. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Jonathan Worthington, Carl Masak, Tadeusz Sośnierz, kboga, Will "Coke" Coleda, TimToady, lumi, not_gerd, PerlJam, not_gerd. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#50) is scheduled for March 22, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. May a great deal of fun befall you! [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.030000664000175000017500000000646212224263172016102 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #50 ("Argentina") On behalf of the Rakudo development team, I'm happy to announce the March 2012 release of Rakudo Perl #50 "Argentina". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The March 2012 release is code named after Argentina, because that's where one of our core contributors went to relax this month after adding some significant Perl 6 features to Rakudo. Some of the specific changes and improvements occurring with this release include: * greatly reduced startup time * significantly reduced memory usage during compilation of modules and of Rakudo itself. * implemented ENTER, LEAVE, KEEP, UNDO and START phasers * basic macros We are still regressed on a few features compared to the 2011.07 release of Rakudo, the most notable of which is autovivification. These regressions should be rectified in coming releases. Note that Rakudo now dies on 'our multi' declarations, which have poorly defined semantics. Please either declare an 'our proto' that re-dispatches to individual multis, or use exporting instead of package variables. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Carl Masak, Tadeusz Sośnierz, Siddhant Saraf, not_gerd, Filip Sergot, TimToady, Michael Schroeder, Patrick R. Michaud, sisar, lumi, Felix Herrmann, flussence, felher If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#51) is scheduled for April 19, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I admonish you to try the new release, to live life to its fullest, to cherish each day, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.040000664000175000017500000000650212224263172016076 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #51 ("Brazos Valley") On behalf of the Rakudo development team, I'm happy to announce the April 2012 release of Rakudo Perl #51 "Brazos Valley". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The April 2012 release is code named after Brazos Valley, because they sponsored a Perl 6 Hackathon. Thanks! Some of the specific changes and improvements occurring with this release include: * Support for pseudo packages like MY, OUR, DYNAMIC * Support for indexing into packages like hashes, e.g. Foo::{'$x'} * Warnings now include line numbers * Assorted minor optimizations to compilation, Str methods and iteration * Now passing over 21,400 spec tests. We are still regressed on a few features compared to the 2011.07 release of Rakudo, the most notable of which is autovivification. These regressions will be rectified in coming releases. Two incompatible changes in this release are notable: * $?POD has been renamed to $?pod * 'defined' used to be a prefix operator, it is now an ordinary subroutine. Code like 'defined $a ?? $b !! $c' should be rewritten to use 'defined($a)' or '$a.defined' instead. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Jonathan Worthington, Patrick R. Michaud, Carl Mäsak, Timo Paulssen, Tadeusz Sośnierz, Felix Herrmann, spider-mario, benabik, timotimo, TimToady and Will "Coke" Coleda. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#52) is scheduled for May 17, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release. have fun, and let us know about your experience. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.04.10000664000175000017500000000575112224263172016242 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release 2012.04.1 On behalf of the Rakudo development team, I'm happy to announce an out-of-schedule release of the Rakudo Perl 6 compiler. Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . This release is a point release in addition to the regular, monthly releases. It contains some of the results of the Perl 6 Patterns hackathon in Oslo. It is intended to be used as the basis for the next Rakudo Star release. The Rakudo developers would like to thank the organizers from Oslo.pm. Some of the specific changes and improvements occurring with this release include: * Support for autovivification. * More robust module precompilation * $.foo, @.foo and %.foo style calls now properly contextualize The 'lib' directory is not in the default search path for modules anymore. Module authors and users can adjust the PERL6LIB environment variable accordingly. For a more detailed list of changes, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Jonathan Worthington, Patrick R. Michaud, Carl Mäsak, Will "Coke" Coleda, Tadeusz Sośnierz, Marcus Ramberg, Timo Paulssen, Felix Herrmann, Geir Amdal, spider-mario, benabik, timotimo, TimToady If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#52) is scheduled for May 17, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release. have fun, and let us know about your experience. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.050000664000175000017500000000610112224263172016072 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #52 ("MadMongers") On behalf of the Rakudo development team, I'm glad to announce the May 2012 release of Rakudo Perl #52 "MadMongers". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The May 2012 release is code named after MadMongers. This release includes a whole lot of changes since the last one, including: * -I and -M command-line options * support for non-Int enums * 'use' now accepts positional arguments and is able to import by tag name * 'import' now works * basic support for Version literals * %*ENV now propagates into subprocesses * basic implementation of pack and unpack ported from 'ng' branch * fff flip-flop operator is now implemented, ff has been improved * various new regex features and improvements Rakudo now also includes the lib.pm module. This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Jonathan Worthington, Patrick R. Michaud, Jonathan Scott Duff, Tadeusz Sośnierz, Carl Masak, Will "Coke" Coleda, Marcus Ramberg, kboga, TimToady, Kyle Hasselbacher, Geir Amdal, JimmyZ, benabik and gfldex. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#53) is scheduled for June 21, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release. Have fun, and let us know about your experience. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.060000664000175000017500000000565012224263172016103 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #53 ("Strasbourg") On behalf of the Rakudo development team, I'm glad to announce the June 2012 release of Rakudo Perl #53 "Strasbourg". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The June 2012 release is code named after Strasbourg, the location of the French Perl Workshop 2012. This release includes a lot of changes since the last one, including: * Longest-Token Matching for | alternations in regexes * Stricter numification of strings (fails if the string does not represent a number) * 'require' now allows argument lists * Faster .map / list handling * Improvements to typed exceptions This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Contributors to Rakudo since the release on 2012-05-17: Moritz Lenz, Jonathan Worthington, Patrick R. Michaud, kboga, Jonathan Scott Duff, Tadeusz Sośnierz, Carl Masak, Geoffrey Broadwell, diakopter, Solomon Foster, JimmyZ, TimToady If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#54) is scheduled for July 19, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release. Have fun, and let us know about your experience. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.070000664000175000017500000000575412224263172016111 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #54 ("Tallinn") On behalf of the Rakudo development team, I'm glad to announce the July 2012 release of Rakudo Perl #54 "Tallinn". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The July 2012 release is code-named after Tallinn, a fine old capital where jnthn and masak had much useful discussions about Perl 6 macro design last year. This release includes a lot of changes since the last one, including: - Built-in meta-objects (e.g. Metamodel::ClassHOW) now inherit from Any - &open now supports :enc/:encoding - Changed &dir to return IO::Path objects, not strings - Deprecated .bytes, .ucfirst, and .lcfirst on Str - recognize obosolete rand() and rand(N) forms at compile time - anonymous subset types 'subset :: of Int where { $_ > 0 }' This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Patrick R. Michaud, Moritz Lenz, Jonathan Worthington, Jonathan Scott Duff, Carl Mäsak, ronaldxs, Felix Herrmann, harmil, Gabor Szabo, sisar If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#55) is scheduled for August 23, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.080000664000175000017500000000733612224263172016110 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #55 ("Frankfurt") On behalf of the Rakudo development team, I'm glad to announce the August 2012 release of Rakudo Perl #55 "Frankfurt". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The August 2012 release is code-named after Frankfurt.pm, the group that hosted this year's YAPC::Europe conference in Frankfurt am Mein. This release brings a massive amount of changes; some of them are outlined below: - Memory usage of build stage is reduced by 35% - 40% - Sigilless variables in signatures (prefixed by | or \) - Blocks that declare variables don't turn into hash constuctors anymore - Better error reporting for traits - --> ReturnType in signatures and prefix type constraints of routine return types are now honored - Circularities in module loading are now detected - Improvements in inliner, which allow it to inline a wider range of routines Some features have been deprecated: - Parameters preceeded by a | or \ may not have a sigil anymore. sub f(\$x) { say $x } must be changed to sub f(\x) { say x } Usage of \$x will unconditionally warn in 2012.09 and be removed in 2012.10 - IO::Path.dir (which returns the directory part of the path) has been renamed to IO::Path.directory. IO::Path.dir will be removed or re-purposed in 2012.09 - The LAZY statement prefix will be removed in 2012.09. It was a non-specced experiment and did not work out well. This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Arne Skjærholt, Geoffrey Broadwell, Will "Coke" Coleda, Tadeusz Sośnierz, Patrick R. Michaud, Felix Herrmann, Carl Mäsak, kboga, thou, Brian Gernhardt, Stefan O'Rear, GlitchMr, ChoHag, Larry Wall and lumi_ If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#56) is scheduled for September 20, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.090000664000175000017500000000634512224263172016110 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #56 ("Perl") On behalf of the Rakudo development team, I'm thrilled to announce the September 2012 release of Rakudo Perl #56 "Perl". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The September 2012 release is code-named after Perl.pm, a group located in scenic Perl in Saarland, Germany, where an important meetup took place on August 16th-19th concerning the reunification of Perl 5 and Perl 6. This release brings changes; some of them are outlined below: - basic macro unquoting - basic support for m:P5/.../ regexes - support for indirect type names in routine and type declarations - support for "is export" traits on constants - Str.wordcase implemented - slightly faster compilation (thanks to switching NQP over to QAST) - tie-breaking with constraints now picks the first matching one rather than demanding they be mutually exclusive A possibly breaking change: - class Iterable does not inherit from class Cool anymore This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Carl Mäsak, Salve J. Nilsen, Patrick R. Michaud, Gerhard R, Tadeusz Sośnierz, Will "Coke" Coleda, Geoffrey Broadwell, diakopter, PerlJam, cognominal, Larry Wall If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#57) is scheduled for October 18, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.09.10000664000175000017500000000624112224263172016242 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release 2012.09.1 On behalf of the Rakudo development team, I'm announcing an out-of-schedule release of the Rakudo Perl 6 compiler. Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . This release is a point release in addition to the regular, monthly releases. Rakudo 2012.09 (no .1) required Parrot 4.8.0, which was recently discovered to have some unfortunate regressions in standard input/output buffering for many environments. This interim release restores the compiler back to using Parrot 4.4.0 to allow more time to resolve I/O issues. This also means we revert to 2012.08's version of socket encoding (where sockets all assume utf8 encoding of data), but this reversion is considered of lesser harm than the regressions in standard I/O. Other changes since the 2012.09 release are also included in this point release: - add 'is-prime' and 'expmod' operations - enable smart matching against Signature literals - enable binding to signatures in declarators - add the 'is hidden' and base traits - temporarily remove the ability to change socket encodings (reverts to 2012.08's behavior) Both 2012.09 and 2012.09.1 contain a possibly breaking change from 2012.08: - class Iterable does not inherit from class Cool anymore This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Patrick R. Michaud, Jonathan Scott Duff, Solomon Foster If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#57) is scheduled for October 18, 2012. A list of the other planned release dates and code names for 2012 is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.100000664000175000017500000000556212224263172016100 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #57 ("Tokyo") On behalf of the Rakudo development team, I'm thrilled to announce the October 2012 release of Rakudo Perl #57 "Tokyo". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The October 2012 release is code-named after Tokyo.pm, hosts of YAPC::Asia 2012. This release brings changes; some of them are outlined below: - delegation to methods using the handles trait - improved handling of :P5 regexes - reduced memory usage for Match objects - each REPL line no longer implies a fresh GLOBAL - import of custom meta-objects only affects the scope they are imported into - can now parse nested pairs of quote delimeters, like q{ foo q{ bar } baz } This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Patrick R. Michaud, Solomon Foster, diakopter, Timothy Totten If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#58) is scheduled for November 22, 2012. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.110000664000175000017500000000601312224263172016071 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #58 ("Walnut") On behalf of the Rakudo development team, I'm thrilled to announce the November 2012 release of Rakudo Perl #58 "Walnut". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The November 2012 release is code-named after Walnut, home of "Yet Another Society" aka "The Perl Foundation". This release brings changes; some of them are outlined below: + implemented precedence related traits (equiv, looser, tighter, assoc) + Perl 6 grammar NFAs are pre-computed, saving some work on each invocation; this shaved around 10% off the time needed to run the spectests + regexes and quotes have better support for user-selected delimiters + heredocs + FIRST/NEXT/LAST can now be used in all types of loop (previously limited to for) This is only a small peek at the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Carl M�sak, Jonathan Scott Duff, Will "Coke" Coleda, Tobias Leich, Geoffrey Broadwell, Nicholas Clark, Konrad Borowski, flussence If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#59) is scheduled for December 20, 2012. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2012.120000664000175000017500000000644412224263172016102 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #59 ("Warszawa") On behalf of the Rakudo development team, I'm proud to announce the December 2012 release of Rakudo Perl #59 "Warszawa". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The December 2012 release is code-named after Warszawa, home of Tadeusz Sośnierz (tadzik), whose contributions to Rakudo and the Perl 6 ecosystem during 2012 have been significant. Some of the changes in this release are outlined below: + The .indent method now has better handling of empty lines + Parse errors are much improved, and follow STD, the standard parser, much more closely; they are more accurate and more information is given + Rakudo now keeps parsing after some less serious errors + Better errors for various parse failures + The junction autothreader is now an order of magnitude faster + Texas versions of the Set and Bag operators implemented + Nested Pairs now give correct .perl output + { a => $_ } now correctly considered a block, not a hash as before This is only a small subset of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Tobias Leich, Solomon Foster, Timo Paulssen, Will "Coke" Coleda, Patrick R. Michaud, Amir E. Aharoni, Carl Mäsak, Geoff Broadwell, Shrivatsan Sampathkumar If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#60), assuming the world doesn't end today, is scheduled for January 17, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.010000664000175000017500000000705212230162701016066 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #60 ("Sonoma") On behalf of the Rakudo development team, I'm proud to announce the January 2013 release of Rakudo Perl #60 "Sonoma". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The January 2013 release is code-named after Sonoma.pm, home of Geoff Broadwell (japhb), whose contributions to Rakudo and the Perl 6 ecosystem during 2012/2013 have been significant. Some of the changes in this release are outlined below: + sink context; for-loops are now lazy by default + first mentioning a variable from outer scope and then redeclaring it in the same scope (my $a; { $a; my $a }) is now an error. + the long-deprecated "SAFE" setting has been removed + 'require' now works with indirect module names + restored socket read semantics to returning the requested number of bytes + $obj.Some::Role::meth() now passes the correct $obj + try/CATCH now returns Nil when the CATCH is triggered, rather than the exception; this brings it in line with try without a CATCH + whatever-star cases of splice now implemented + sequences with Junction endpoints now work + corrected precedence of various set operators + fixed binding of non-Any things into hashes and arrays + can now import multis with the same name from different modules, provided all dispatchers are onlystar This is only a small subset of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Moritz Lenz, Carl Masak, Tobias Leich, Shrivatsan Sampathkumar If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#61), is scheduled for February 21, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. (And, have a good laugh at conspiracy theorists for their doomed end-of-world predictions!) [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.020000664000175000017500000000610512230162701016065 0ustar moritzmoritz Announce: Rakudo Perl 6 compiler development release #61 ("drinkers") On behalf of the Rakudo development team, I'm proud to announce the February 2013 release of Rakudo Perl #61 "drinkers". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[*] -- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The February 2013 release is code-named after drinkers.pm, as even a camel needs to have a drink from time to time. Some of the changes in this release are outlined below: + "Did you mean ..." suggestions for symbol-not-found errors + Compile-time optimization of some cases of junctions in boolean context + IO::Socket.get now works again with non-Unicode characters + constant folding for routines marked as 'is pure' + natively typed variables and better error reporting in the REPL + speed up eqv-comparison of Bufs + warnings for useless use of (some) literals, variables and constant expressions in sink context This is only a small subset of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Timo Paulssen, Moritz Lenz, Jonathan Worthington, Tobias Leich, Arne Skjærholt, Carl Mäsak, Tadeusz Sośnierz, Will Coleda, Christoph Otto and Solomon Foster. If you would like to contribute, see , ask on the perl6-compiler@perl.org mailing list, or ask on IRC #perl6 on freenode. The next release of Rakudo (#62), is scheduled for March 21, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [*] What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.03.md0000664000175000017500000000602712224263172016477 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #62 ("Singapore") On behalf of the Rakudo development team, I'm proud to announce the March 2013 release of Rakudo Perl #62 "Singapore". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The March 2013 release is code-named after Singapore.pm. Some of the changes in this release are outlined below: * Rakudo warns when pure expressions are used in sink context * .substr(...) now correctly accepts whatever-star closures * Implemented shellwords postcircumfix (%h<< $x 'foo bar' >>) * Defining operators spelled like the empty string is now illegal * Array interpolations now properly do LTM * Autothread "none" and "all" junctions before "any" and "one" * Helpful error if you write "else if"/"elif" instead of "elsif" * Throw exception if a Range is used as a Range endpoint * Corrected argument order in IO.seek This is only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, kboga, Tobias Leich, Moritz Lenz, Patrick R. Michaud, Timo Paulssen, Carl Mäsak, Tadeusz Sośnierz, Gerhard R, thundergnat, TimToady If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#63), is scheduled for April 18, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.04.md0000664000175000017500000000551012224263172016474 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #63 ("Albany") On behalf of the Rakudo development team, I'm proud to announce the April 2013 release of Rakudo Perl #63 "Albany". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The April 2013 release is code-named after Albany.pm. Some of the changes in this release are outlined below: * wrap low level VM objects in ForeignCode, allowing perl6 OO calls on them * for loops are eager again * add link and symlink to IO * add Capture.Bool() * improvements to DUMP() * various optimizations in the optimizer and the runtime * smartmatch against list now supports Whatever wildcards This is only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Geoffrey Broadwell, Jonathan Worthington, Moritz Lenz, Tobias Leich, Timo Paulssen, Will "Coke" Coleda, Carl Masak, Rob Hoelz, Tadeusz Sośnierz, Carl Mäsak, Brent Laabs, diakopter If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#64), is scheduled for May 23, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release. Take a deep breath. Write some new code. Don't forget to be awesome. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.05.md0000664000175000017500000000650312224263172016500 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #64 ("Austin") On behalf of the Rakudo development team, I'm proud to announce the May 2013 release of Rakudo Perl #64 "Austin". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ). The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The May 2013 release is code-named after Austin.pm. You'll see that this release is pure destiny. Its release number is 2**6, its codename has 6 chars, it is named after the place where the next YAPC::NA will happen on the sixth month of this year, a year with a crossfoot of 6. Some of the changes in this release are outlined below: * IO::Spec, a port of Perl 5's File::Spec * speedup of repeated shifts of large lists and arrays by 70%+ * regex special characters can be used as delimiters * allow slice with :exists adverb on hashes * fix regex interpolation slowdown * fix exporting of subroutines * fix reporting of errors in gather/take. * added 125 extra opening/closing bracket-pairs * fix build failure on SPARC and PowerPC * underlying nqp layer supports parrot and JVM as backend, in preparation for JVM support in a future Rakudo release This is only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Brent Laabs, Moritz Lenz, Patrick R. Michaud, Tobias Leich, Jonathan Worthington, Will "Coke" Coleda, Elizabeth Mattijsen, dagurval, Carl Mäsak, Solomon Foster, Larry Wall, Tadeusz Sośnierz, Timo Paulssen, Arne Skjærholt, Timothy Totten If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#65), is scheduled for June 20, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release. Take a deep breath. Write some new code. Don't forget to be awesome. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.06.md0000664000175000017500000000622312224263172016500 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #65 ("Poznan") On behalf of the Rakudo development team, I'm proud to announce the June 2013 release of Rakudo Perl #65 "Poznan". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ) and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The June 2013 release is code-named after Poznan.pm, a mongers group that was founded after two Perl developers visiting this year's PLPW realized they lived in the same city. Some of the changes in this release are outlined below: + JVM backend added - passes initial sanity tests + type captures in signature binder implemented + IO::Handle methods gist, perl, path added + Int.msb and Int.lsb implemented + dir() is now lazy + $/ and $! now visible in eval/REPL + .{} adverb combinations all implemented + &first now returns Nil instead of failing + IO::Path.chmod implemented + Cool.path implemented + div and / fail with X::Numeric::DivisionByZero (rather than dying) This is only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Elizabeth Mattijsen, Stefan O'Rear, Brent Laabs, Tobias Leich, Timo Paulssen, Patrick R. Michaud, Will "Coke" Coleda, Moritz Lenz, thundergnat, Carl Mäsak, dagurval, bbkr If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#66), is scheduled for July 18, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.07.md0000664000175000017500000000600212224263172016474 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #66 ("Edinburgh") On behalf of the Rakudo development team, I'm proud to announce the July 2013 release of Rakudo Perl #66 "Edinburgh". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ) and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The July 2013 release is code-named after Edinburgh.pm, 'twas there that a now core hacker lived when he got involved with Perl 6. Some of the changes in this release are outlined below: + Huge progress in JVM backend (feature-wise almost on par with Parrot) + fixed handling of indented heredocs + basic support for threads and promises (JVM only) + implemented canonpath for Win32 IO::Spec + implemented squish + made []:(kv|p|k|v) work according to spec These are only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Elizabeth Mattijsen, Stefan O'Rear, Timo Paulssen, Solomon Foster, Brent Laabs, Tobias Leich, Will "Coke" Coleda, Carl Masak, Moritz Lenz, Donald Hunter, Stéphane Payrard, Patrick R. Michaud, Tadeusz Sośnierz, Larry Wall, GlitchMr If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#67), is scheduled for August 22, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.08.md0000664000175000017500000000633212224263172016503 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #67 ("Bicycle") On behalf of the Rakudo development team, I'm proud to announce the August 2013 release of Rakudo Perl #67 "Bicycle". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine (see ) and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The August 2013 release is code-named after Bicycle.pm, probably the Perl Mongers group with the coolest t-shirts. Some of the changes in this release are outlined below: + "is default", "is dynamic", "of" and "will" traits on variables + assigning Nil restores the default value + CALLER::<$var> now only works on dynamic variables, as per spec. + improvements to concurrency/parallelism support, including Channel, select, KeyReducer and basic asynchronous file reading (JVM only) + "once" phaser implemented + reimplementation of Buf as a role, and addition of Blob and other sized Buf/Blob related types + ConfigureJVM.pl now takes --gen-nqp, easing the Rakudo on JVM build + printf now correctly handles big integers These are only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Elizabeth Mattijsen, Jonathan Worthington, Moritz Lenz, Donald Hunter, Tobias Leich, Timo Paulssen, Solomon Foster, Tadeusz Sośnierz, Marton Papp, ivanoff, TimToady, Mouq, Patrick R. Michaud, awwaiid If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#68), is scheduled for September 19, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. In general, Rakudo development releases are scheduled to occur soon after each Parrot monthly release. Parrot releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.09.md0000664000175000017500000000563512224263172016511 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #68 ("Shanghai") On behalf of the Rakudo development team, I'm proud to announce the September 2013 release of Rakudo Perl #68 "Shanghai". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The September 2013 release is code-named after Shanghai.pm, a Perl Mongers group in a city visited by at least two Rakudo core developers. Some of the changes in this release are outlined below: + candidate argument to bless removed (per spec change) + @a.VAR.name and %h.VAR.name implemented + The $var.++ and $var.() syntaxes work + tr/// implemented + Sockets on JVM implemented These are only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Elizabeth Mattijsen, Moritz Lenz, Donald Hunter, Tobias Leich, Jonathan Worthington, Carl Mäsak, Geoffrey Broadwell, Paweł Murias, Solomon Foster, Will "Coke" Coleda, Dagur Valberg Johannsson, Tadeusz Sośnierz, BenGoldberg, GlitchMr, Mouq, timotimo If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#69), is scheduled for October 17, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. A Rakudo development release occurs soon after each Parrot monthly release is scheduled to occur. Parrot usually releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, to live life to its fullest, to cherish each moment, and to have fun. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.10.md0000664000175000017500000000603512231261357016475 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #69 ("Roederbergweg") On behalf of the Rakudo development team, I'm happy to announce the October 2013 release of Rakudo Perl #69 "Roederbergweg". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The October 2013 release is code-named after Roederbergweg.pm, a Perl Mongers group very near the recent Perl 6 Internals Workshop Some of the changes in this release are outlined below: + postcircumfix {} and [] are now implemented as multi subs rather than multi methods. This should allow for better optimization in the future. + Add support for "is deprecated", making it easy for early adopters to stay current. + Track multiple spec changes for various container classes. + Greatly reduce object creation during Regex parsing. + Various portability fixes. These are only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Jonathan Worthington, Arne Skjærholt, Timo Paulssen, Carl Masak, Moritz Lenz, Tobias Leich, Alexander Moquin, Patrick R. Michaud, Elizabeth Mattijsen, grondilu, Jonathan Scott Duff, Will "Coke" Coleda If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#70), is scheduled for November 21, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. A Rakudo development release occurs soon after each Parrot monthly release is scheduled to occur. Parrot usually releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, step out of your comfort zone, and get a library card. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.11.md0000664000175000017500000000624112250627156016501 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #70 ("Malmö") On behalf of the Rakudo development team, I'm happy to announce the November 2013 release of Rakudo Perl #70 "Malmö". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The November 2013 release is code-named after Malmö, from which this release has been launched. Some of the changes in this release are outlined below: + Many concurrency primitives harmonized with new S17, but still pretty fluid + Refactored build system that allows building rakudo on rakudo/JVM in the same place + Order::Increase/Decrease are deprecated. Please use Order::Less/More. + Leading whitespace is ignored for :sigspace + Better null pattern detection in regexes + improved run()/shell(), these return Proc::Status-objects now + The "gethostname" function implemented + Performance optimization: unfold junctions in 'when' clauses + various other bug fixes, optimisations and additional tests These are only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Moritz Lenz, Tobias Leich, Jonathan Worthington, Timo Paulssen, Will "Coke" Coleda, Mouq, Brian Gernhardt, Arne Skjærholt, L. Grondin, Geoffrey Broadwell, Steve Mynott, Andrew Egeler, Elizabeth Mattijsen If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#71), is scheduled for December 19, 2013. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. A Rakudo development release occurs soon after each Parrot monthly release is scheduled to occur. Parrot usually releases the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, step out of your comfort zone, and get a library card. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/announce/2013.12.md0000664000175000017500000000552612255237202016501 0ustar moritzmoritz# Announce: Rakudo Perl 6 compiler, Development Release #71 ("Advent") On behalf of the Rakudo development team, I'm happy to announce the December 2013 release of Rakudo Perl #71 "Advent". Rakudo is an implementation of Perl 6 on the Parrot Virtual Machine and the Java Virtual Machine. The tarball for this release is available from . Please note: This announcement is not for the Rakudo Star distribution[^1] --- it's announcing a new release of the compiler only. For the latest Rakudo Star release, see . The Rakudo Perl compiler follows a monthly release cycle, with each release named after a Perl Mongers group. The December 2013 release is code-named after Advent, the non-geographical group which fits this time of year. Some of the changes in this release are outlined below: + The Whatever Star now works inside chain operators like comparisons + Private attributes from roles are now visible in the classes they apply to + Use invokedynamic in some places on the JVM. + Memory improvements in ListIter + Faster method List.combinations + Simple lookahead assertions in regexes are optimized + Regexes do less superfluous scanning These are only some of the changes in this release. For a more detailed list, see "docs/ChangeLog". The development team thanks all of our contributors and sponsors for making Rakudo Perl possible, as well as those people who worked on Parrot, the Perl 6 test suite and the specification. The following people contributed to this release: Elizabeth Mattijsen, Timo Paulssen, Jonathan Worthington, Moritz Lenz, Tobias Leich, Larry Wall, Carl Mäsak If you would like to contribute, see , ask on the mailing list, or ask on IRC \#perl6 on freenode. The next release of Rakudo (#72), is scheduled for January 23, 2014. A list of the other planned release dates and code names for future releases is available in the "docs/release_guide.pod" file. A Rakudo development release typically occurs a few days (often two) after the third Tuesday of each month. On behalf of the development team, I encourage you to try the new release, step out of your comfort zone, and get a library card. [^1]: What's the difference between the Rakudo compiler and the Rakudo Star distribution? The Rakudo compiler is a compiler for the Perl 6 language. Nothing else. The Rakudo Star distribution is the Rakudo compiler plus a selection of useful Perl 6 modules, a module installer, the most recent incarnation of the "Using Perl 6" book, and other software that can be used with the Rakudo compiler to enhance its utility. Rakudo Star is meant for early adopters who wish to explore what's possible with Rakudo Perl 6 and provide feedback on what works, what doesn't, and what else they would like to see included in the distribution. rakudo-2013.12/docs/architecture.html0000664000175000017500000001223312224263172017105 0ustar moritzmoritz How Rakudo compiles a Perl 6 program

How Rakudo compiles a Perl 6 program

Parser and Action Methods

The Perl 6 source code is transformed in various stages, of which the first two are the Parser and Action Method stages. The Parser creates a parse tree out of the Perl 6 source code and then gives control to appropriate action methods that annotate the parse tree, incrementally turning it into an Abstract Syntax Tree (AST). When an action method is done annotating, control is handed back to the parser, which then continues parsing the Perl 6 code and "fire off" new action methods as it goes.

The result of these two stages interacting is an "improved PAST" (Perl 6 Abstract Syntax Tree) called QAST. This tree is then passed on to the QAST compiler.

The parser and action methods are implemented in "Not Quite Perl 6" (NQP) and are part of Rakudo and hosted in the Rakudo repository at src/Perl6/Grammar.pm and src/Perl6/Actions.pm.

The World

The World is where the parser and the action methods store any declarations they encouter during their runs, including Classes, Types, Signatures, Constants, Subs and Methods.

QAST compiler

The QAST compiler transforms the abstract syntax tree into a PIRT (Parrot Intermediate Representation Tree). To do this, the QAST compiler does a series of translations on the AST, creating PIRT nodes that implement the operations specified by the QAST nodes.

In addition, the QAST compiler is responsible for serializing The World in such a way that later stages can get access to the declarations stored there during the parser and action methods stages.

There's also opportunity to apply some VM-specific optimizations at this point. When this is done, the resulting PIRT is passed to the PIRT serializer.

This stage is described in the different files in the nqp/src/QAST/ directory.

PIRT serializer

The PIRT serializer "squashes" the PIR Tree into a format that can be passed to Parrot itself and it's IMCC (InterMediate Code Compiler) stage.

You can read more about this at nqp/src/QAST/PIRT.nqp.

IMCC and Parrot runtime

The IMCC (InterMediate Code Compiler) receives the PIR code from the PIRT serializer and then transforms it into Parrot Byte Code (PBC). IMCC is parrot's PIR compiler, written in C and statically linked into parrot. The byte code can then be stored to disk or executed in memory by one of the run cores availabe as part of the Parrot runtime. This is in some sense the heart of Parrot - or one of the hearts; There are several different cores available, including one for just-in-time compilation (JIT), one for debugging and others.

You can find out more about the IMCC in the parrot/docs/imcc/ directory, and about the different run cores in the parrot/docs/running.pod

PMCs and dynops

There are also some supporting custom types and operations in Rakudo called dynamic PMCs and dynamic ops (dynops) which are written in C, and helper functions written in NQP and PIR. These supporting libraries exist for adding features to Parrot that are needed to handle special features in Perl 6.

Core setting library

The core settings library is the library containing the methods, classes and almost all other features that make up the Rakudo Perl 6 implementation. This library is tightly coupled with the perl6 binary, and loaded by default every time perl6 is run.

Glossary

NQP
Not Quite Perl 6, a small subset of Perl 6 that is used for tree transformations in compilers.
PIR
Parrot Intermediate Representation, the most commonly used for of parrot assembly (which is still high-level enough to be written by humans).
IMCC
InterMediate Code Compiler, the part of parrot that compiles PIR into byte code.
PBC
Parrot Byte Code, the binary form to which all parrot programs are compiled in the end.
Core setting
The core setting is the Perl 6 standard library. It is part of the perl6 executable, and contains all the standard features available in Perl 6.
QAST
The "improved" Abstract Syntax Tree used in Rakudo Perl 6. It contains information about how the program is structured, and what it is supposed to do.
PIRT
Parrot Intermediate Representation Tree.
rakudo-2013.12/docs/architecture.svg0000664000175000017500000006343212242026101016734 0ustar moritzmoritz Rakudo Perl 6 Architecture image/svg+xml Rakudo Perl 6 Architecture rakudo architecture Mortiz Lentz The Perl Foundation https://raw.github.com/rakudo/rakudo/nom/docs/architecture.svg https://raw.github.com/rakudo/rakudo/nom/docs/architecture.html en-US Core setting(Perl 6) The Perl 6 source code is transformed in various stages. The first one is the parser stage, which creates a parse tree out of the Perl 6 source code. The parser stage is implemented in "Not Quite Perl 6" (NQP) and is part of Rakudo and hosted in the Rakudo repository. Parser (NQP) Parser (NQP) The action methods are applied to the parse tree at the same time as the parser builds it. The result of this process is the Abstract Syntax Tree that is sent to the QAST compiler. Action methods (NQP) Action methods (NQP) Perl 6source QAST PIRT serializer (NQP) QAST compiler (NQP) IMCC (C) PIRT PIR The POST compiler emits PIR, which IMCC transforms into byte code. IMCC is parrot's PIR compiler, written in C and statically linked into parrot. The byte code (PBC) can then be stored to disk, or executed in memory by a so-called run core or run loop, which is in some sense the heart of parrot - or one of the hearts, because there are several different ones available (one for just-in-time compilation (JIT), one for debugging etc.). There are also some supporting custom types and operations in Rakudo called dynamic PMCs and dynamic ops which are written in C, and helper functions written in other languages (namely NQP and PIR). Those do not show up in the flow chart. Parrot runtime (C) Parrot runtime (C) PBC PMC &dynops (C) JAST serializer (NQP) QAST compiler (NQP) Java Virtual Machine JAST JVM Perl6::World(NQP) MAST serializer (NQP) QAST compiler (NQP) MoarVM MAST moar rakudo-2013.12/docs/ChangeLog0000664000175000017500000014346212255230276015323 0ustar moritzmoritzNew in 2013.12 + The Whatever Star now works inside chain operators like comparisons + Private attributes from roles are now visible in the classes they apply to + Use invokedynamic in some places on the JVM. + Memory improvements in ListIter + Faster method List.combinations + Simple lookahead assertions in regexes are optimized + Regexes do less superfluous scanning New in 2013.11 + Many concurrency primitives harmonized with new S17, but still pretty fluid + Refactored build system that allows building rakudo on both backends in the same place + Order::Increase/Decrease are deprecated. Please use Order::Less/More. + Leading whitespace is ignored for :sigspace + Better null pattern detection in regexes + The "gethostname" function implemented + Warn when private attributes are a marked rw or readonly + "is DEPRECATED" trait now produces report when process finished + Parcel.rotate implemented + Performance optimization: unfold junctions in 'when' clauses + capitalize/.capitalize have been removed, as per docs/deprecations + improved run()/shell(), these return Proc::Status-objects now + The ... range operator can now be chained: 1,2,3 ... 10,15,20 ... 100 + various other bug fixes, optimisations and additional tests New in 2013.10 + postcircumfix {} and [] are now implemented as multi subs rather than multi methods. This should allow for better optimization in the future. + Add support for "is DEPRECATED", making it easy for early adopters to stay current. + Track multiple spec changes for various container classes. + Greatly reduce object creation during Regex parsing. + Various portability fixes. + qx// and run() now auto-quote correctly + Allow #`[...]-style comments in regexes + unlink() behaves like P5's, it deletes write-protected files on windows New in 2013.09 + candidate argument to bless removed (per spec change) + @a.VAR.name and %h.VAR.name implemented + The $var.++ and $var.() syntaxes work + Lots of improvements on the Set and Bag types + [op]() with relational operators vacuously return True + tr/// implemented + Sockets on JVM implemented + sleep(), sleep-time() and sleep-till() updated to spec New in 2013.08 + "is default" traits on variables, $/, $!, $_ are default Nil + "is dynamic" traits on variables, $/, $!, $_ are dynamic + "of TypeObject" trait on variables + .VAR.default/dynamic/of return the state of these traits + Assigning Nil, calling undefine() restores the default value + .WHAT more accurately returns a type object for specifically typed cases + Option --gen-nqp for ConfigureJVM.pl + Include file name in parser errors + Parse labels, tr/// (both don't do anything useful under the hood yet) + CALLER::<$var> now only works on dynamic variables, as per spec. + Improvements to Threads, including Channel and KeyReducer (JVM only) + Asynchronous file reading (JVM only) + Improved JVM interop, including 'use :from' (JVM only) + Fixed subroutine inlining on JVM + Fixed %*CUSTOM_LIB on JVM * Fixed sink context handling on JVM + Reimplementation of Buf as a role + Implemented Blob role + Implemented sized/encoded Buf/Blob types (buf8, blob8, utf8, etc.) + Str.encode now returns most specific appropriate type + "once" phaser fully implemented + Named parameters "with" and "as" on uniq/squish + "samewith()" for calling method on same dispatcher again + "will" variable trait partially implemented ($_ not set yet) + Interpolating strings into heredocs now dedents properly + Solved a slowdown when declaring custom operators + Improved P5-regexes (backslash sequences, code blocks) + Make type objects appear as Nil in non-scalar contexts + Placeholder variables $^A .. $^Z no longer allowed, as per spec + printf %d now supports bigints also on Parrot + my and our scoped methods no longer go into the method table + Implemented keybag(), KeyBag.push, KeyBag.categorize + Re-implemented hash iteration for a performance win + Various optimizations, code cleanups and error message enhancements New in 2013.07 + Huge progress in JVM backend (feature-wise almost on par with Parrot) + List.first is now lazy + unspace before argument lists is now supported + fixed handling of indented heredocs + basic support for threads and promises (JVM only) + improved sprintf and other formatting routines + keyof method for typed hashes to get key type + Hash.perl nows works for typed hashes + 'is parcel' and 'is default' traits (work in progress) + Parcel.new now works + slight optimization to join of many items + implemented canonpath for Win32 IO::Spec + implemented squish + made []:(kv|p|k|v) work according to spec + properly parse Pod formatting codes with brackets other than <...> + the POD_TO_TEXT_ANSI environment variable now leads to some formatting being applied by Pod::To::Text + declaration of multiple operators in a scope now generates much smaller serialized output + Int.round method now takes a scale argument + implemented Complex.ceiling, Complex.floor, Complex.round New in 2013.06 + JVM backend added - passes initial sanity tests + type captures in signature binder implemented + IO::Spec::Unix.canonpath made more efficient + IO::Handle methods gist, perl, path added + Int.msb and Int.lsb implemented + dir() is now lazy + lines($limit) now doesn't read an extra line + .^mro methods added to a few role metaclasses + $/ and $! now visible in eval/REPL + IO::Handle.copy moved to IO::Path.copy + .{} adverb combinations all implemented + :$ colonpair syntax implemented + 'my &foo; multi foo() { }' gives better error message + reduce() more aware of fiddliness + &first now returns Nil instead of failing + $*CWD and $*TMPDIR now contain IO::Path objects + REPL bug fixed when same line issued twice + pick/pop/push/roll/reverse/rotate/sort/classify/categorize now fail immediately if the list is infinite + categorize now returns a Hash, not a Parcel of Pairs + "undef" warning now refers to Any, not Mu + improved error messages for hash shapes + Hash.(classify|categorize) implemented + IO::Path.chmod implemented + IO::Path.succ and .pred implemented + syntax parser now allows a dot before hyper postfix + Str.succ added for codepoints \x2581..\x2588 + Cool.path implemented + sequences between 1-codepoint strings implemented + div and / fail with X::Numeric::DivisionByZero (rather than dying) + doing .perl on Rat with denominator 0 doesn't go into an infinite loop anymore + Capture.exists implemented New in 2013.05 + IO::Spec, a port of Perl 5's File::Spec + support for exporting things form EXPORT subroutine + ?-quantifier in regexes doesn't create arrays in the Match object anymore + speedup of repeated shifts of large lists and arrays by 70%+ + implemented Cool.lines + renamed IO to IO::Handle; IO is now a tag role, as per spec + simplify timezone handling + .Set and .Bag methods for List and Parcel + regex special characters can be used as delimiters + allow slice with :exists adverb on hashes … + .hash now accepts optional :type and :of named parameters + Make :exists and :delete up to spec … + fix for autoviv Typed hash problem + constant-fold infix:<~> + make decl and init of our-scoped arrays/hashes work + fix regex interpolation slowdown + fix exporting of subroutines + fix slurpy is-rw array-parameters + failed regex matches return Nil + add support for IO::Path:: + fix reporting of errors in gather/take. + added 125 extra opening/closing bracket-pairs + fix build failure on SPARC and PowerPC + underlying nqp layer supports parrot and JVM as backend, in preparation for JVM support in a future Rakudo release > more than 100 not listed changes New in 2013.04 + add Capture.Bool() + optimize getting size of numeric Range + for loops are eager again + improvements to DUMP() + wrap NQP objects in ForeignCode, allowing perl6 OO calls on them + improve some messages on parsefail. + add link and symlink to IO + reduce compile-time autothreading to avoid issues with !== + improve optimizer - caching, constants + fix List.ACCEPTS() for Whatever special case + bring 'require' closer to spec, esp. by taking paths + bring 'IO::Path' closer to spec + remove parrot dynops already provided as nqp ops + translate a dynop to nqp code + update from pir:: calls to nqp:: New in 2013.03 + Type names now gist as (Any) rather than Any() + Warn when pure expressions are used in sink context + Cool.substr(...) now correctly accepts whatever-star closures + Fix character class subtraction bugs + Correctly detect undeclared variables in regex assertions + :i now respected in character classes + Improved output of Rat.perl + Implemented shellwords postcircumfix (%h<< $x 'foo bar' >>) + User-defined circumfixes now parse a semilist rather than just an expression and handle whitespace correctly + Forbid null operators + Warn about leading 0 not indicating octal in Perl 6 + Fix some automatic end of statement on "}" parse bugs + Better error message on for(...) {} being interpreted as a function call + Array interpolations now properly do LTM + Respect :i in constructs like /:i <$var>/ + Autothread "none" and "all" junctions before "any" and "one" + Helpful error if you write "else if"/"elif" instead of "elsif" + Throw exception if a Range is used as a Range endpoint + Corrected argument order in IO.seek + Multi-dispatch now mostly implemented in NQP, not C + Fixed LEAVE (and thus UNDO/KEEP/temp) not firing in multis or upon 'next' in a for loop New in 2013.02 + "Did you mean ..." suggestions for symbol-not-found errors + Compile-time optimization of some cases of junctions in boolean context + Date and DateTime now support a .delta method + IO::Socket.get now works again with non-Unicode characters + $() now takes $/.ast into account + proper return value for smartmatching against a substitution + better error reporting when a parent class does not exist + constant folding for routines marked as 'is pure' + natively typed variables now work in the REPL + better error reporting in the REPL + writable $_ in -p and -e one-liner + speed up eqv-comparison of Bufs + warnings for useless use of (some) literals, variables and constant expressions in sink context + /../ and rx/.../ literals match against $_ in sink context + array variable interpolation into regexes New in 2013.01 + sink context; for-loops are now lazy by default + first mentioning a variable from outer scope and then redeclaring it in the same scope (my $a; { $a; my $a }) is now an error. + the long-deprecated "SAFE" setting has been removed + 'require' now works with indirect module names + restored socket read semantics to returning the requested number of bytes + $obj.Some::Role::meth() now passes the correct $obj + try/CATCH now returns Nil when the CATCH is triggered, rather than the exception; this brings it in line with try without a CATCH + whatever-star cases of splice now implemented + sequences with Junction endpoints now work + corrected precedence of various set operators + fixed binding of non-Any things into hashes and arrays + can now import multis with the same name from different modules, provided all dispatchers are onlystar New in 2012.12 + ~/.perl6/lib is gone from the default include path + fixed indent method's handling of empty lines + fixed .indent(*) + parse errors now formatted like in STD, with color + location of parse error now indicated with context + highwater algorithm implemented, greatly improving accuracy of parse error line numbers and locations in a range of cases + some parse errors now report what the parser was looking for at the time the parse failed + better errors for unmatched closing brackets and two terms in a row + uniq now has === semantics as specified, not eq semantics + junction auto-threader optimized and is an order of magnitude faster + implemented sub term: + implemented texas versions of the Set and Bag operators + good error for use of . to concatenate strings + flattening large lists of Parcels now happens in about half the time + adopted STD panic/sorry/worry model, meaning that we now keep parsing further and can report multiple issues in a range of cases + we now catch and complain about post-declared type names + variable redeclarations are now just a warning, not an error + a mention of an &foo that is never defined is now an error + fixed .perl output for a Pair with a Pair key + interpolation of undeclared arrays, hashes and functions now detected + { a => $_ } now correctly considered a block, not a hash as before New in 2012.11 + user-defined operators only affect the parser in the scope they are declared in + fixed pre-compilation of modules containing user-defined operators + implemented precedence related traits (equiv, looser, tighter, assoc) + Perl 6 grammar NFAs are pre-computed, saving some work on each invocation; this shaved around 10% off the time needed to run the spectests + redeclaring a class as a role now gives a better error + the < foo bar > syntax in regexes now respects :i + << ... >> now interpolates, respecting quoting and pairs + fix error reporting for not-found dynamic variables + many protos now have much narrower signatures + quote parsing implementation aligned with the approach STD uses + regexes and quotes have better support for user-selected delimiters + quote adverbs + heredocs + carry out IO::Path.dir deprecation + implement infix: + macro arguments now carry their lexical environment properly + postfix operators of the form '.FOO' take precedence over method calls + version control markers detected and gracefully complained over + INIT phasers now work as r-values + our ($x, $y) style declarations fixed + take and take-rw now evaluate to the taken value + implemented cando method on Routine + FIRST/NEXT/LAST can now be used in all types of loop (previously limited to for) + implemented operator adverbs + implemented :exists and :delete subscript adverbs and on hashes + implemented :p, :k, :v and :kv subscript adverbs on arrays and hashes + fixed shell words post-processing like << foo "bar $baz" >> + byte-order mark at the beginning of a file is now ignored + fixed bug that could lead to disappearing symbols when loading pre-compiled modules + Configure no longer passes --optimize to Parrot if --parrot-option is specified + deprecated current &foo semantics + fixed #`foo and friends at start of statementlist + simplify setting line number of compile-time exceptions + made :($a, $b) := \(1, 2) update $a and $b New in 2012.10 + :60[24, 59, 59] radix form + delegation to methods using the handles trait + fixed serialization of Buf + improved handling of :P5 regexes (more features, less bugs) + determining that an object lacks a method is usually now much faster + reduced memory usage of Match objects and optimized their construction a little + some code-generation improvements related to void context + implemented :dba('...') modifier in regexes + various error messages improved through use of :dba('...') in the Perl 6 grammar + implemented 'x' in pack + added $*CUSTOM-LIB + eval in a method can now see self, attributes and $?PACKAGE + each REPL line no longer implies a fresh GLOBAL + fixed some Pod parsing issues with Windows newlines + fixed interaction of :i and LTM (alternations and protoregexes now respect it) + import of custom meta-objects only affects the scope they are imported into + made <-> lambdas work + can now parse nested pairs of quote delimeters, like q{ foo q{ bar } baz } New in 2012.09.1 + is-prime and expmod + smart matching against Signature literals + binding to signatures in declarators + the is hidden and base traits + ability to set encoding on sockets temporarily removed (reverts to 2012.08 behavior) New in 2012.09 + class Iterable does not inherit from class Cool anymore + basic macro unquoting + basic support for m:P5/.../ regexes + support for indirect type names in routine and type declarations + compiler now built with QAST-based NQP, which generates better code, thus making the compiler a little faster + support for "is export" traits on constants + implemented Str.wordcase + can now write more complex proto subs and methods, using {*} to enter the dispatcher + tie-breaking with constraints now picks the first matching one rather than demanding they be mutually exclusive New in 2012.08 + tclc implemented + --> ReturnType in signatures and prefix type constraints of routine return types are honored + reduced memory usage at build time by around 35% - 40% + the argument to IO::Socket.recv is now interpreted as a number of characters + enum lists and arguments to parametric roles are now evaluated at compile time + switched to new internal AST and backend representations (QAST and PIRT) + removed deprecated routines Str.bytes and Str.lcfirst/&lcfirst + errors from traits now contain file name and line number + IO::File and IO::Dir have been removed + inliner has been improved and can inline a wider range of routines + simple implementation of the 'soft' pragma + fixed over-eager treatment of numeric literals as int rather than Int in cases where they appeared each side of an infix operator + detect circularities in module loading + sigilless variables in signatures when proeceed by | or \ + prevented blocks that declare variables turning into hash constructors + made pre-compilation complain if dependencies are not pre-compiled yet + fixed interpolation of double-quoted strings in regexes + fixed issue with Num.new not being friendly to subclassing + implemented handling of complex numbers in Str.Numeric New in 2012.07 + Deprecated SAFE.setting in favor of RESTRICTED.setting + Ranges can now interpolate in argument lists + The built-in meta-objects (such as Metamodel::ClassHOW) now inherit from Any + &open now supports :enc/:encoding + Exception.fail, .resumable and .resume + Changed &dir to return IO::Path objects, not strings + Deprecated .bytes, .ucfirst, and .lcfirst + &slurp now supports :bin + &spurt implemented + cleaned up Version implementation + fixed :s file test + recognize obosolete rand() and rand(N) forms at compile time + anonymous subset types 'subset :: of Int where { $_ > 0 }' New in 2012.06 + Rakudo is now compiled with the same regex engine as user-space regexes use + transitive longest-token matching in protoregexes + changed the output of Match.gist + string to number conversion now fails for non-numbers + string to number conversion now recognizes radix notation + string incrementation is now aware of more scripts + <|w> word boundary in regexes implemented + more errors from within the meta model now contain line number and file name + &push and &unshift functions can now autovivify + user-defined operators properly participate in LTM + Rakudo's C code is now compiled with optimization switches turned on + basic module loading tracing with the RAKUDO_MODULE_DEBUG=1 env variable + longest token matching with alternations + require with argument list + compile time errors in loaded modules now show a module loading backtrace + improved list and .map handling + can now use | to flatten a pair into an argument list as a named argument New in 2012.05 + meta ops //=, ||= and &&= now short-circuit properly + Failure objects don't blow up the REPL anymore + allow case insensitive regex matches without ICU in limited cases + %*ENV now propagates into subprocesses + RAKUDOLIB env variable supported in addition to PERL6LIB + -I and -M command line options + $?LINE and $?FILE variables + warnings now include line number from program, not from CORE.setting + reduction meta-operator on list-associative ops now has correct semantics + now have :th alias for :nth in Str.match + import collisions now report the name of the module that is to blame + ms// fixed + <$x> in regexes caches the compiled regex, which can be a big performance win + implemented temp and let + 'use' can now import by tag name + 'use' with positional arguments + lib.pm + updated calling conventions for traits + implemented fff flip-flop operator; improvements to ff form also + removed current directory from default library search path + 'import' works + symbols installed in EXPORT in all nested packages, not just UNIT::EXPORT + enumeration types can be used as roles + END phasers now run when program ends with exit or an exception + fix Rat.floor and .ceiling to work for large numbers + improved Rat stringification + Real is now a role, as it should be + implemented < foo bar baz > syntax for alternations in regexes + implemented <( and )> syntax for setting from/to of match in regexes + support for non-Int enums + basic support for Version literals + chmod now available as a function + roundrobin implemented + fixed a bug in precompilation of modules that use roles from other modules + basic implementation of pack and unpack + implemented substr-rw, which provides an l-value (assignable) substring + implemented <~~> (recursive call into self) syntax in regexes + 'LAZY' statement prefix New in 2012.04.1 + autvivification for arrays and hashes + more robust module precompilation + improved infrastructure for calling C code + $.foo style calls now contextualize correctly + &infix: now return members of the Order enum in all cases + --doc=format now loads Pod::To::format and uses it for rendering + 'lib/' is no longer in the default include path + improved Parameter.perl + add .changed, .modified and .accessed methods to IO + improved --help output + install precompiled test module for speedup + fixed printing of backtraces when regexes are in the call chain + case insensitive regex matches now also work for interpolated variables New in 2012.04 + 'defined' is now a listop instead of a prefix op + fixed :16('0d...') + implemented simple interpolation in names in type declarations (class ::(const) { }) + $=POD renamed to $=pod + fixed slicing of non-lists with infinite ranges + fixed accidental over-serialization, cutting ~300KB off each pre-compiled module + scalar positionals no longer treated as slices + implemented Routine.package + join will now always reify at least 4 elements of a list if possible + warnings now have line numbers + brought back Str.indent + ban declaring pseudo-packages, with a helpful error + a name followed by :: now returns .WHO, so Foo::<&bar> style lookups work + Exception.Bool now returns true + avoided re-parsing of longname, which speeds up the parse a bit overall + implemented MY, CALLER, OUTER, UNIT, CORE, SETTING and DYNAMIC pseudo-packages + implemented ::<$x> and ::{'$x'} style lookups + some small optimizations to various Str built-ins and MapIter + improved --doc output + added $*PERL + implemented IO::ArgFiles.slurp New in 2012.03 + updated to dyncall 0.7 + infix: now autothreads over junctions + more typed exceptions + pre-compiled modules/settings are now serialized, not re-built on load + startup time is now about 25% of what it once was + significant memory and time reduction (~40%) when pre-compiling modules/settings + BEGIN and CHECK now work in r-value context + constant declarator now works with non-literals on the RHS + implemented Set, Bag, KeySet and KeyBag types + implemented :exhaustive and :nth match adverbs + implemented ENTER, LEAVE, KEEP and UNDO phasers + implemented FIRST, NEXT and LAST phasers in for loops + implemented START phaser, including use of it in r-value context + implemented also syntax for adding traits inside a block/package + implemented macro declarations and quasi quotes (sans placeholders) + implemented anonymous enums + 'our multi' now dies (used to ignore the 'our') + implemented PRE and POST phasers + ~25% performance improvement to array indexing New in 2012.02 + catch duplicate accessor generation required of "has $.x; has @.x;" + many more typed exceptions thrown + undeclared attributes mentioned in signatures now caught at compile time + empty Buf is now False in boolean context + implemented + implemented // syntax + // can call a predeclared lexical regex x + conjugate is now called conj + enumeration values .gist to just the key, not the full name + in regexes fixed + implemented Match.make(...) method + better error reporting for improper use of nextsame and friends + initializers now parsed as part of a variable declarator + trailing whitespace now removed from Pod declarator blocks + List.tree made more useful + implemented rename and copy functions + ().pick and ().roll now return Nil + default MAIN usage message includes .WHY of the candidates + X::Base eliminated in favor of Exception + various range iteration fixes; Num ranges now produce Num lists + LHS of the xx operator is now thunked + can now declare state/constant/our in regexes (before, only :my worked) + improved backtraces + catch constructs that require an invocant but don't have one + catch uses of virtual method calls in submethods and attribute initializers + improved parsing and performance of reduction meta operators + Rat arithmetic now properly defaults to Num if the denominator is too big + FatRat implemented + implemented long forms of regex adverbs (e.g. "ignorecase" maps to "i") + fixed "but True" and "but False" + object hashes, with the my %h{SomeObjectType} syntax + implemented Int($x) style coercions + implemented Capture.perl New in 2012.01 + -c command line option re-implemented + take flattening bug fixed + duplicate named parameter names detected + fixed clone being too shallow with regard to containers + fixed negative modulo for bigint + better Routine.perl + .DEFINITE macro implemented + .^methods, .^attributes and .^parents now support :excl (the new default) and :all + Array.delete implemented + restored basic -n and -p functionality + improved parameter introspection + fixed operations on bigints when the first operand had been mixed in to + fixed multi-dispatch narrowness calculation for native types + binding to array and hash elements + added Order enumeration, and updated cmp and <=> to use it + adding various missing magicals, such as &?ROUTINE and ::?ROLE + accessor generation for my $.x and our $.x cases + fixed @x>>.() (hyper-invocation) + updated Complex.Str to match current spec + fixed eval to see GLOBAL properly + implemented 0 but Answer(42) style mix-ins + fixed various issues in scoping/handling of $/ + fixed usage of make in a regex (previously, only worked in action methods) + optimized Range.roll and Range.pick for large ranges + fixed non-numeric, no-Str ranges + fixed build on Cygwin + fixed regex backtracking into subrules and captures New in 2011.12 + improved protoregex support, including NFA caching + and (lookahead and lookbehind) + backslash sequences in character classes + fixed quantified captures and :r interaction bug + optimized match object construction, ListIter, substr and chomp + improved performance of send/get on sockets + optimizer detects missing private methods and simplifies calls (level 3 only) + fixed some issues when an array was assigned to itself, maybe using .= + implemented .wrap and .unwrap, plus wrap handles with a .restore method + implemented .trans on strings + unicode properties can be matched against in regexes + binding to @, % and & sigils now checks for the appropriate role + assignments to variables declared with the & sigil now checked for Callable + typed hashes, partial support for typed arrays + some parametric role fixes + can now use but operator with a type object + smartmatching of regexes against arrays and hashes + socket IO now implements .write and custom input line separators + implemented getc + implemented .WALK + implemented ff, ^ff, ff^ and ^ff^ + implemented .REPR macro + implemented Proxy class + some typed errors are now thrown from within the compiler + stubbed methods from roles now require those methods to be implemented + updated docs/ROADMAP + .WHICH now returns ObjAt objects + defining new operators New in 2011.11 + CATCH blocks are now much closer to spec + big integer support + basic protoregex support with NFA-driven LTM for some declarative constructs + correct default values for natively typed variables + fixed initialization of state variables + improved support for natively typed variables + catch more uses of undeclared variables + splice() is now implemented + uniq() is now implemented + several runtime errors now throw properly typed error objects + various performance improvements, for example to the X meta op and Str.succ + improved support for MAIN argument parsing + fixed lexicals/recursion bug + IO.copy is now implemented New in 2011.10 + operators and functions with native type arguments + detection of call to undefined routines at CHECK time + various optimizations: inlining of operators, CHECK time dispatch decisions + performance improvements of MapIter + support @$foo style derefencing/coercion + Exception.backtrace + eval() has stopped to catch exceptions New in 2011.09 + Rewritten meta object protocol and object storage + many speedups + Int, Num and Str are now far more lightweight + much more robust handling of infinite list + basic LoL (List of Lists) support + :U and :D type modifiers + protos and multis now conform to the new spec + improved enum support + basic 'constant' declarator + .WHAT and friends as macros + chrs sub and method + support for .gist + run() has been renamed to shell() to conform to current spec + hyper methods now descend into nested data structures + basic safe mode (through --seting=SAFE) + recording and reporting of test timings (tools/test_summary.pl) + Pod parsing and --pod=text option + basic support for .WHY + greatly improved BEGIN-time support + traits applied at BEGIN time for packages, routines and attributes + parametric roles reify types properly, fixing many bugs + better handling of type variables + support $?CLASS, which is generic in roles + support import/export of custom meta-objects for built in package declarators + custom meta-objects can override method dispatch + faster, allocation-free multi-dispatch cache + a custom BUILD does not suppress default values + undeclared attributes detected and reported at compile time + basic support for native int/num types on lexical variables + int/num as attributes are stored compactly in the object body New in 2011.07 + fractional powers of negative numbers now result in Complex numbers + obtain spectests from a specific branch of the `roast' repo + fix bug that prevented build on systems with little RAM New in 2011.06 + added take-rw built-in + numerous build system improvements + assignment now evaluates arguments right-to-left New in 2011.05 release + added a call counter for builtins in Perl 6-level subroutines + gcd (greatest common divisor) and lcm (largest common multiple) operators + build system improvements + added --ignore-parrot-rev option to Configure.pl + Configure.pl now creates "config.status" file + fixed relational operators when used with NaN + implemented Int.base + speedup smart-matching against numbers and Str.comb with default arguments + added RAKUDO_SUBLOG environment var for tracking subroutine calls + overall performance speedups New in 2011.04 release + implemented Str.indent + A new, much simpler API and implemention of IO::Socket::INET + Unified error messages to use "Cannot" New in 2011.03 release + improved error message on type check failure in assignment + -n and -p command line options + Test.pm's skip() now has argument ordering consistent with todo() + implemented complex conjugation + more IO methods related to stat New in 2011.02 release + IPv6 support + more robust numeric exponentation + --ll-backtrace command line option for PIR level stack traces + future-proof for upcoming generational garbage collector in parrot + various constructs now return Nil + infix: implemented + infix:<^^> and infix: improved + negation metaoperator is now restricted to operators that return Bool New in 2011.01 release + faster subroutine calls (type cache) + 'handles RoleName' now works + Test.pm: s/done_testing/done/ + non-spec debugging pragma Devel::Trace + improved parsing of keyword boundaries + sped up .comb New in 2010.12 release + new .trans algorithm + fixed $*PID on MacOS X + don't register names of anon types + configuration improvements + updated Any functions + fix $*IN_DECL leakage + implemented Hash.hash + Temporal updates + Buf.decode fixed + open() fixed for binary flag New in 2010.11 release + now works with parrot on git + implemented qw// + 5x speedup of .trans + various improvements to Set + don't use deprecated charset ops anymore + Bool.Bool and Bool.so now return False + implemented &elems + improved error for Date.new(Str) + improvement on hyperoperators + indexings like .[0 .. *-1] work now New in 2010.10 release + True and False now stringify according to the specification + basic form of 'require' for run time module loading + warnings from the setting now produce line numbers in the users' program + local time zone available as $*TZ + more consistent line numbers from warnings + getting and setting attributes via introspection + implement samespace, ms// and ss/// + hyper operator invoving = can now modify their arguments + speed up Str.flip by over a factor of 100 New in 2010.09 release + new methods on IO concerning the modify and access time of files + S32::Temporal now completely implemented + Instants and Durations + speedup for slurp() and .reverse built-ins + various improvements to the Set type + revamp of series operator code, and adaption to new spec + implement ...^ up-to-but-excluding-series operator + allow :r and :ratchet modifiers on regex quoting constructs + Bool.pick + significantly improved enum implementation New in 2010.08 release + syntactic adverbs on substitutions, rx quotes and m//, e.g. '$x ~~ s:2nd/a/b/' + updated ROADMAP + speedups for integer operations + the Match class's .perl method now produces useful, roundtrippable Perl code + the MAIN subroutine can now parse short arguments + the cmp and <=> operators now work on more numeric types + the Buf class now has .pack and .unpack methods with partial functionality + numeric bitshift operators now have the correct precedence + smartmatch against True or False is now an error New in 2010.07 release + support for delegation via 'handles' + implemented binding with := and read-only binding with ::= + implement OS related built-ins like mkdir, cwd + improved diagnostics in Test.pm + basic binary IO, buffer encoding and decoding + magic $*ARGFILE file handle + more robust closures + multi-level Array and Hash element autovivification + perl6 --version now identifies the exact git sha1 and parrot version + implemented 'is rw' trait on classes + file tests now work through IO, ie. 'README'.IO ~~ :e + generic, multi-level Whatever-currying (eg grep !(* % 2), @list) + improved error reporting in many cases, especially multi-method dispatch + implemented backtracking into capturing groups and subrules + phasers refactored, they can now return results and see the setting + custom circumfix operators + basic .wrap and .unwrap implementation + weighted Hash.pick + .perl on custom classes now dumps attributes + Basic implementation of the ==> and <== feed operators + Int ~~ Num is no longer true, as per spec; use Numeric instead + Improvements to enumerations New in 2010.06 release + new list model with immutable iterators, lots of fixes to lists and arrays + variable interpolation into regexes + compile time Whatever currying for infix, prefix and postfix operators + autoprinting in the REPL shell + in @*INC, the current directory '.' now comes at the end, as in Perl 5 + basic Buf implementation: Str.encode/Buf.decode work for UTF-8 + proper Perl 6 match objects + Backtraces with Perl 6 subroutine names and line numbers + MAIN and USAGE subs + basic version of Str.trans + mix-ins with non-roles (5 but 'string') + @*ARGS is now read-write + IO::Socket::INET again works in CORE + hash and array slices have been greatly improved + basic support for callframe() and CallFrame type New in 2010.05 release + implemented lexical and anonymous classes and roles + manual pages are now installed + the .match method now understand the adverbs :c; :p, :nth, :x, :g, :ov + test reports with tools/test_summary.pl now record detailed timing information + many improvements to numeric handling + implemented S (sequential) meta operator + fixed placeholder parameters ($^a, $^b) + basic enum implementation + implemented List.classify + turned on an additional 47 test files + further improved error messages + implement zero-argument versions of many binary operators + basic interoperation with Perl 5 through the external Blizkost project New in 2010.04 release + interpolation of expression ending in postcircumfixes into double-quoted strings (for example "cards: @cards.sort()") + prefix and postfix hyper operators + multi subs now work properly when lexically scoped + implemented item assignment with tighter precedence than the comma operator + loading of .pm6 modules + Basic implementation of Numeric and Real roles + implementation of DateTime and Date built-in types + named regexes can be declared outside of grammars again + support for numbers with arbitrary radix, including fractional numbers (:16) + implemented fmt(), printf() note() and IO.getc built-in routines + infix meta operators now inherit the precedence of the modified operator + &[+] short name for infix operators + hash slices + signature literals + smart-matching against signatures + more consistent implementation of prefix:<|> for interpolating things into signatures + better error message on accidental usa of Perl 5 features such as << as bit shift operators, and catch many perl 5 magic variables + implemented type Cool + implemented anonymous classes and roles + implemented $*PID + method introspection works again + better error message for calling non-existent routine in a namespace + now run programs with the setting as an outer lexical scope, as per spec New in 2010.03 release + The trigonometric functions and the Rat class have received numerous updates, making them faster and more complete + .^parent now works again + The invocation logic has received various speedups + Hash creation has been optimized + Various improvement related to constant internal strings have led to slight speedups + .pick, .sort, .keys, .values, .kv, sprintf were reimplemented, ported from the old 'alpha' branch + The statement modifier for loop works again + Various parsing bugs have been sorted out; one having to do with closing curly braces at the end of a line not terminating the statement + .CREATE, .BUILDALL and .can in the OO system have received attention, some of it leading to mild speedups + $*PROGRAM_NAME and @*ARGS now work + Deferral works again (nextsame/nextwith/callsame/callwith) + Array.delete works again + Fixed .?, .+ and .* along with matching latest spec on .? + Switch untyped variables to default to Any instead of Mu + &foo lookup syntax works again (including for operators) + Various cases of eqv operator implemented + Make overriding postcircumfix:<( )> work again, this time per spec + Make junctions of code objects invokable again + Lazy implementation of the Z operator + Added back @*INC + Read-only %*ENV support + Grammars work again + Implemented regexes taking parameters + Implemented proto-regex declarations + Initial work on getting subset types working again + Add back many of the file test methods + Added docs/S11-Modules-proposal.pod documenting how we intend to handle modules through Rakudo * + First cut of locating and loading modules with a given version and/or authority, and in absence of a requirement selection of the latest version by default if multiple are available. + Many improvements to the series operator + Implemented 'need' and a first cut of 'import'; 'use' works in terms of them + Import is now into the lexical scope by default, as per spec + Removed requirement to hand-pre-compile .pm to .pir for use with 'use' + Improved multi-dispatch candidate not found errors to include details of the available candidates + Implemented 'use MONKEY_TYPING' + Many cases of smart-match work again + $x.Foo::bar() and $x.$y() work again + $.foo(1,2,3) works again + !, R, X and Z meta-operators work, albeit with some caveats + s/foo/bar/ and s[foo] = 'bar' substitution syntax implemented + Array.rotate added back + User defined operators (prefix, postfix, infix) working again + Many more small but important improvements to built-in types and functions + Various other bug fixes + ROADMAP updates New in 2010.02 release + The branch formerly known as 'ng' becomes the new master branch + The previous master branch is now Rakudo/alpha + NQP-RX replaces NQP in the Parrot Compiler Toolkit, enabling the source code of the compiler to be written in a subset of Perl 6 that is much more powerful, most importantly with regexes, as the name suggests + The revised Perl6/Grammar.pm is much closer to the canonical STD.pm + Regexes may declare contextual and lexical variables + Lazy lists and arrays are partly implemented + The object metamodel is largely written in NQP-RX instead of PIR + The name of the root of the object hierarchy is now Mu + The term 'undef' is gone, replaced by Nil, Mu or *.notdef depending on context + Builtin classes derive from Cool which derives from Any + The refactored source code is more compact and more easily extended + The number of spectests passed has reduced from a peak of 32731 in alpha to 24221, because porting the functionality to the new master is still ongoing + Release numbering changes from 'dash' to 'dot' delimiter to get on better with various package management systems New in 2010-01 release + Added method form of eval. + Implemented :s and :l file operators + Added functions for logarithms using $base + Refactored subroutine calls to use new Context structures in Parrot 2.0.0 New in 2009-12 release + Only minor maintenance was done because all attention was being given to the Rakudo/ng branch, bringing in the new nqp-rx bootstrap compiler New in 2009-11 release + Rakudo now uses Parrot's updated calling convention features + support unpacking of arrays, hashes and objects in signatures + changed .pick to use :replace instead of :repl + many core setting optimizations and bugfixes + IO::Socket.recv() has been extended to accept a parameter specifying the number of bytes which will be received + Rakudo now looks up %INC in the right namespace when loading libraries for foreign languages New in 2009-10 release + smolder reports for spectest runs + more Complex trig functions + pure Perl 6 implementation of the Complex type + some variants of the new series operator + correct construction of twigilled colonpairs + infix:, .pred and .succ for the Rat type + when configuring with --gen-parrot, pass --optimize to parrot's Configure.pl + moved more operators to the setting and thus made them overloadable + { %hash } now correctly constructs a hash, not a closure + new, faster low level Signature type + improved Signature introspection + new, much faster signature binder + improved various error messages related to signature binding + signature literals now supported + binding of named arguments to positional parameters + attributive parameters implemented + package blocks now run as immediate blocks, as per the spec + lexical variables declared outside of packages now visible inside them New in 2009-09 release + updates to numeric operators: infix(Int, Int) creates a Rat + Rat (rational) numbers + overloadable builtin operators + contextual variables + setting values in %*ENV now works + partial support for trigonometric functions of complex numbers + better handling of custom traits, many builtin traits moved to core setting + improved type dispatch for builtin operators, type coercions New in 2009-08 release + Rakudo must now be built from an installed parrot, and can be installed itself + separate Perl 6 meta class + introspection on roles + declaration of methods in the meta class by writing method ^newmethod($obj) + :tree options for parent class, attribute and role introspection + allow some custom postcircumfix:<( )> methods + moved more built-ins into the setting + implement operators infix: (divisibility test) and prefix [||] and [//] + updated ROADMAP in preparation for the Rakudo Star release + instead of throwing nasty parse errors, Rakudo now informs you that feed operators are not yet implemented + improved testing: planless testing with done_testing(); better diagnostic output from is() + the syntax for embedded comments has changed + embedded Pod comments are now recognized + support for defining traits and applying them to routines, classes and roles + "hides" trait (class A hides B { ... }), and "is hidden" + better handling of slurpy and optional in multi-dispatch + use of .?, .+ and .* with indirect calling form ($obj.+@cands) + .can improved; now returns something usable as an iterator + lastcall implemented New in 2009-07 release + extensive refactor of the multi dispatch code to get closer to the spec + better handling of named arguments in multi dispatch + operators and traits can be defined in the setting + basic implementation of the series and eqv operators + refatored trait code to match updated specification + implemented more cases of smartmatching against hashes + fixed state variables to work with //= and ||= initialization + improved testing: when Rakudo dies with 'Null PMC Access' it is never considered a success + implemented the :all flag to split which keeps captures + added List.rotate builtin + nextwith and callwith now also work properly with methods + take() without outer gather now merely warns + introspection of roles and attributes New in 2009-06 release + refactored and corrected object initialization (BUILD/CREATE) + attributes initilizations can now use attributes defined earlier + method calls are now faster + basic safe mode that forbids IO and execution of external programs + implemented meta operators for user defined operators + initial implementation of Temporal (date/time related objects) + type checking of implicit return values + improved introspection methods + cleaned up IO methods + improved "is export" handling for modules and setting + automatically transcode to iso-8859-1 for faster parsing when possible + refactored and corrected assignment, .succ, .pred, C<++>, C<-->, postcircumfix:<[ ]>, Whatever + "module Foo;" now allows statements before it + improved Unicode string handling + better support for Str increment/decrement in Unicode ranges + many performance improvements New in 2009-05 release + updated docs/ROADMAP + basic support for custom operators + operators can now be referenced as &infix:<+> + meta operator support for custom operators + cross-language library loading + stack traces now include source file name and line number + implemented Regex type + .WALK (parent classes in configurable order) + .name method on routines + refactored enums, thereby fixing many enum related bugs + fixed namespace of eval()ed code + implemented parallel dispatch (@objects>>.methods) + initial support for «...» quotes + text files now default to utf8 encoding + fixes to Match.perl and Match.chunks + implemented 'constant name = $value' + documented build dependencies + grep() accepts general matcher, things like @list.grep(Int) work + trigonometric functions (sin, cos, ...) now available via 'use Num :Trig' + qx{} quotes now work (except on Windows) + hyper-operators on hashes now work (%a >>+<< %b) + initial implementation of $foo.@bar + refactored wrap and unwrap to work with candidate lists; fixes some bugs + refactored/improved callsame and callwith, and added nextsame and nextwith (only work for dispatches of the form $foo.@bar and with wrap so far) + partial implementation of .^parents and .^methods + can initialize attributes in terms of others + many other bug fixes and performance enhancements New in 2009-04 release (#16, "Bratislava") + wrap and unwrap for subroutines + calling a method on a Whatever star generates a closure + 1+*, *+1 and others generate closures (*-1 missing) + Associative, Positional and Callable are now parametric roles + typed arrays and hashes + parametric role subtyping (R[T1] ~~ R[T2] where T1 ~~ T2) + .invert and .push on Hashes + enforce return types of subroutines (partial implementation) + parallel testing + Configure.pl now supports passing options to parrot's Configure + support for lexical subroutines and multis + implemented \c[character name] in double quoted strings and regexes + implemented Perl 5 regexes + rx/.../ regex quoting + sockets support has been added (IO::Socket) + regex patterns may now be quantified by a separator regex + moved many methods to the setting + exporting and importing by tags, support :DEFAULT export tag + implemented START blocks + implemented roots builtin + implemented .ast on Match objects + added Match.caps and Match.chunks + split() now supports limits in all cases + prefix:<=> and the "fish operator" ( =<> ) are now gone + .readline is now .get + roles are now punned on any method call on the role + many other bug fixes New in 2009-03 release (#15, "Oslo") + implemented $*PROGRAM_NAME magical variable + outer lexicals are now visible in eval() + next, last etc. work in grep() + added R metaoperator + add an initial draft of Match.perl + refactor Grammar and Match class hierarchy + fix if/unless/while/until/for/... on line after close curlies + add Q quoting, including Q:PIR + added "state" variables + //= fixed to short-circuit, and added short-circuiting &&= and ||= + multi-subs now have the Multi type and have a .candidates method + multi-method dispatch now looks up the class hierarchy + various fixes to using roles as type constraints + support bare sigils in signatures + more methods and functions moved to (Perl 6) setting + many other bug fixes New in 2009-02 release (#14, "Vienna") + first release independent of Parrot releases + passing 7076 spectests (+796 since 2009-01 release) + build and use fakecutable (perl6.exe) by default + redesigned build, configuration, and test subsystems + add settings/ directory for builtins written in Perl 6 (was "prelude") + improve diagnostics in Test.pm + allow anonymous classes via C<::> + re-use existing parameterized roles instead of creating new ones + roles now pun classes when .new is called on them + 'proto' now marks all same-named routines as 'multi' + XopX is now Xop + implement <-> (rw) pointy blocks + added min= and max= metaoperators + many many bugfixes + publish release schedule + documentation improvements rakudo-2013.12/docs/compiler_overview.pod0000664000175000017500000003007512242026101017772 0ustar moritzmoritz## $Id$ =head1 RAKUDO COMPILER OVERVIEW =head2 How the Rakudo Perl 6 compiler works This document describes the architecture and operation of the Rakudo Perl 6 (or simply Rakudo) compiler. The F describes how to build and run Rakudo. Rakudo has six main parts summarized below. Source code paths are relative to Rakudo's F directory, and platform specific filename extensions such as F<.exe> are sometimes omitted for brevity. =over 4 =item 1. Not Quite Perl builds Perl 6 source code parts into Rakudo =item 2. A main program drives parsing, code generation and runtime execution (F) =item 3. A grammar parses user programs (F) =item 4. Action methods build a Parrot Abstract Syntax Tree (F) =item 5. Parrot extensions provide Perl 6 run time behavior (F, F, F) =item 6. Libraries provide functions at run time (F, F, F, F, F) =back The F (generated from F<../tools/build/Makefile.in> by F<../Configure.pl>) compiles all the parts to form the F executable and the F or F "fake executable". We call it fake because it has only a small stub of code to start the Parrot virtual machine, and passes itself as a chunk of bytecode for Parrot to execute. The source code of the "fakecutable" is generated as F with the stub at the very end. The entire contents of F are represented as escaped octal characters in one huge string called C. What a hack! =head2 1. NQP The source files of Rakudo are preferably and increasingly written in Perl 6, the remainder in Parrot Intermediate Representation (PIR) or C. Not Quite Perl (nqp) provides the bootstrap step of compiling compiler code (yes!) written in a subset of Perl 6, into PIR. The latest version of NQP includes the I<6model> library, which is the building block for all Perl 6 object. It also comes with a regex engine that Rakudo uses. NQP is a bootstrapped compiler, it is mostly written in NQP. The source code of NQP is in a separate repository at L. Note, NQPx only I the Rakudo compiler, and does not compile or run user programs. =head3 Stages NQP compiles us a compiler in F<../perl6.pbc> and then F<../perl6> or F<../perl6>. NQP also compiles the I found in F. This is a library that controls how classes, methods, roles and so on work. The bare-bones compiler then loads the compiled metamodel, and compiles the I found in F. Those core files provide the runtime library (like the C and C classes). But note that many of these classes are also used when the final compiler processes your Perl 6 scripts. =head2 2. Compiler main program A subroutine called C<'MAIN'>, in F, starts the source parsing and bytecode generation work. It creates a C object for the C<'perl6'> source type. Before tracing Rakudo's execution further, a few words about Parrot process and library initialization. Parrot execution does not simply begin with 'main'. When Parrot executes a bytecode file, it first calls all subroutines in it that are marked with the C<:init> modifier. Rakudo has over 50 such subroutines, brought in by C<.include> directives in F, to create classes and objects in Parrot's memory. Similarly, when the executable loads libraries, Parrot automatically calls subs having the C<:load> modifier. The Rakudo C<:init> subs are usually also C<:load>, so that the same startup sequence occurs whether Rakudo is run as an executable or loaded as a library. So, that Rakudo 'main' subroutine had created a C object. Next, 'main' invokes the C<'command_line'> method on this object, passing the command line arguments in a PMC called C. The C<'command_line'> method is inherited from the C parent class (part of the PCT, remember). And that's it, apart from a C<'!fire_phasers'('END')> and an C. Well, as far a C<'main'> is concerned. The remaining work is divided between PCT, grammar and actions. =head2 3. Grammar Using C, C target C uses F to compile F to F. The compiler works by calling C method in F. After some initialization, TOP matches the user program to the comp_unit (meaning compilation unit) token. That triggers a series of matches to other tokens and rules (two kinds of regex) depending on the source in the user program. For example, here's the parse rule for Rakudo's C statement (in F): token statement_control:sym { :s [ || <.panic: 'unless does not take "else", please rewrite using "if"'> ] } This token says that an C statement consists of the word "unless" (captured into C<< $ >>), and then an expression followed by a block. The C<.panic:> is a typical "Awesome" error message and the syntax is almost exactly the same as in F, described below. Remember that for a match, not only must the C<< >> match the word C, the C<< >> must also match the C token. If you read more of F, you will learn that C in turn tries to match an C<< >> and a C<< >>, which in turn tries to match ..... That is why this parsing algorithm is called Recursive Descent. The top-level portion of the grammar is written using Perl 6 rules (Synopsis 5) and is based on the STD.pm grammar in the C repository (L). There are a few places where Rakudo's grammar deviates from STD.pm, but the ultimate goal is for the two to converge. Rakudo's grammar inherits from PCT's C, which provides the C<< <.panic> >> rule to throw exceptions for syntax errors. =head2 4. Actions The F file defines the code that the compiler generates when it matches each token or rule. The output is a tree hierarchy of objects representing language syntax elements, such as a statement. The tree is called a Parrot Abstract Syntax Tree (PAST). The C class inherits from C, another part of the Parrot Compiler Toolkit. Look in F<../parrot/ext/nqp-rx/stage0/src/HLL-s0.pir> for several instances of C<.namespace ["HLL";"Actions"]>. When the PCT calls the C<'parse'> method on a grammar, it passes not only the program source code, but also a pointer to a parseactions class such as our compiled C. Then, each time the parser matches a named regex in the grammar, it automatically invokes the same named method in the actions class. Back to the C example, here's the action method for the C statement (from F): method statement_control:sym($/) { my $past := xblock_immediate( $.ast ); $past.pasttype('unless'); make $past; } When the parser invokes this action method, the current match object containing the parsed statement is passed into the method as C<$/>. In Perl 6, this means that the expression C<< $ >> refers to whatever the parser matched to the C token. Similarly there are C<< $ >> and C<< $ >> objects etc until the end of the recursive descent. By the way, C<< $ >> is Perl 6 syntactic sugar for C< $/{'xblock'} >. The magic occurs in the C<< $.ast >> and C expressions in the method body. The C<.ast> method retrieves the PAST made already for the C subtree. Thus C<$past> becomes a node object describing code to conditionally execute the block in the subtree. The C statement at the end of the method sets the newly created C node as the PAST representation of the unless statement that was just parsed. The Parrot Compiler Toolkit provides a wide variety of PAST node types for representing the various components of a HLL program -- for more details about the available node types, see PDD 26 ( L ). The PAST representation is the final stage of processing in Rakudo itself, and is given to Parrot directly. Parrot does the remainder of the work translating from PAST to PIR and then to bytecode. =head2 5. Parrot extensions Rakudo extends the Parrot virtual machine dynamically (i.e. at run time), adding 14 dynamic opcodes ("dynops") which are additional virtual machine code instructions, and 9 dynamic PMCs ("dynpmcs") (PolyMorphic Container, remember?) which are are Parrot's equivalent of class definitions. The dynops source is in F, which looks like C, apart from some Perlish syntactic sugar. A F<../parrot_install/bin/ops2c> desugars that to F which your C compiler turns into a library. For this overview, the opcode names and parameters might give a vague idea what they're about: rakudo_dynop_setup() rebless_subclass(in PMC, in PMC) find_lex_skip_current(out PMC, in STR) x_is_uprop(out INT, in STR, in STR, in INT) get_next_candidate_info(out PMC, out PMC, out PMC) transform_to_p6opaque(inout PMC) deobjectref(out PMC, in PMC) descalarref(out PMC, in PMC) allocate_signature(out PMC, in INT) get_signature_size(out INT, in PMC) set_signature_elem(in PMC, in INT, in STR, in INT, inout PMC, inout PMC, inout PMC, inout PMC, inout PMC, inout PMC, in STR) get_signature_elem(in PMC, in INT, out STR, out INT, out PMC, out PMC, out PMC, out PMC, out PMC, out PMC, out STR) bind_signature(in PMC) x_setprophash(in PMC, in PMC) The dynamic PMCs are in F, one file per class. The language is again almost C, but with other sugary differences this time, for example definitions like C whose purpose will appear shortly. A F<../parrot_install/lib/x.y.z-devel/tools/build/pmc2c.pl> converts the sugar to something your C compiler understands. For a rough idea what these classes are for, here are the names: P6Invocation P6LowLevelSig MutableVAR Perl6Scalar ObjectRef P6role Perl6MultiSub Perl6Str and P6Opaque. =head3 Binder The dynops and the dynpmcs call a utility routine called a signature binder, via a function pointer called C. A binder matches parameters passed by callers of subs, methods and other code blocks, to the lexical names used internally. Parrot has a flexible set of calling conventions, but the Perl 6 permutations of arity, multiple dispatch, positional and named parameters, with constraints, defaults, flattening and slurping needs a higher level of operation. The answer lies in F which is compiled into C and C libraries. Read L for a more detailed explanation of the binder. F has three C<.loadlib> commands early on. The C loads the 9 PMCs, the C does the 14 dynops, and the C adds over 30 mathematical operators such as C, C, C, C
, C, C, C, C etc. (source in F) =head2 6. Builtin functions and runtime support The last component of the compiler are the various builtin functions and libraries that a Perl 6 program expects to have available when it is running. These include functions for the basic operations (C<< infix:<+> >>, C<< prefix: >>) as well as common global functions such as C and C. The stage-1 compiler compiles these all and they become part of the final F. The source code is in F, F, F, F and F. =head2 Still to be documented * Rakudo PMCs * The relationship between Parrot classes and Rakudo classes * Protoobject implementation and basic class hierarchy =head1 AUTHORS Patrick Michaud is the primary author and maintainer of Rakudo. The other contributors and named in F. =head1 COPYRIGHT Copyright (C) 2007-2010, The Perl Foundation. =cut # Local Variables: # fill-column: 100 # End: # vim: expandtab shiftwidth=4: rakudo-2013.12/docs/deprecations0000664000175000017500000000622612242026101016132 0ustar moritzmoritzDeprecations in 2013.11 Order::Increase and Order::Decrease are now called Order::Less and Order::More. Using "Increase" or "Decrease" will now generate "is DEPRECATED" warnings at the end of execution. Deprecations in 2012.12 'for'-loops will be lazy (just like map), and only be automatically run in sink (void) or list context. This causes problems if the last statement in a block is a for-loop that either calls return(), or is inside a try { } block. Since such code is now run after the block exits, it is not in the dynamic scope of the routine or the try block. As a fix, you can force eager execution of the for-loop by adding another statement after it, or by writing 'eager do for LIST BLOCK'. This change will take effect in 2013.01. warnings will start being issued for unused parameters to pointy blocks and routines. At present, they do not warn at all. Planned for 2013.01. constructs like "my $a; { $a; my $a; }", where the meaning of the first mention of $a in the block would create confusion as to what was being referred to, will become an error as in STD. This change will take effect in 2013.01. Deprecations in 2012.11 at present, a reference to an &foo that does not exist evalutes to Nil. This will become a CHECK-time failure, in line with STD. Planned for the 2012.12 release. Deprecations in 2012.10 protos for built-in routines are now mostly as generic as possible, and will be changed to be specific to the arity of the routine. For example 'proto sub chr(|) {*}' will become 'proto sub chr($) {*}' This affects everybody who adds multis with unusual arity to built-in subs. Planned for the 2012.11 release. Unary hyper ops currently descend into nested arrays and hashes. This will change to make them equivalent to a one-level map. Planned for the 2012.11 release. ~/.perl6/lib will go away from the default include path (@*INC). Instead %*CUSTOM_LIB now holds paths to four library locations: perl Rakudo installs its core modules here vendor OS-level package managers should install their modules here site for local module installations (e.g. with panda or ufo) home like site, but always under the user's home directory. fallback if site isn't writable. Removal of ~/.perl6/lib from @*INC planned for the 2012.11 release Deprecations in 2012.09 Str.capitalize and &capitalize are deprecated in favor of the the Str.wordcase and &wordcase routines. They will uncondtionally warn in 2012.10, and be removed in 2012.11. Deprecations in 2012.08 Parameters preceeded by a | or \ may not have a sigil anymore. sub f(\$x) { say $x } must be changed to sub f(\x) { say x } Usage of \$x will unconditionally warn in 2012.09 and be removed in 2012.10 IO::Path.dir (which returns the directory part of the path) has been renamed to IO::Path.directory. IO::Path.dir will be removed or re-purposed in 2012.09 The LAZY statement prefix will be removed in 2012.09. It was a non-specced experiment and did not work out well. rakudo-2013.12/docs/glossary.pod0000664000175000017500000000751412224263172016112 0ustar moritzmoritz## $Id$ =head1 glossary.pod - glossary of terms used in the Rakudo compiler =over =item action method Action methods are typically used to perform transformations and other actions while parsing a source code program. Parse grammars typically use the special token C< {*} > to indicate the point at which an action method is to be invoked. In addition, a line containing C< {*} > may also use C< #= > to specify a "key" that is to be passed to the action method. =item NQP - Not Quite Perl NQP is a primitive language for writing subroutines and methods in Parrot using a Perl 6 syntax. It's not intended to be a full-fledged programming language, nor does it provide a runtime environment beyond the basic Parrot primitives. Compilers typically use NQP to compile "action methods" that convert a parse tree into its equivalent abstract syntax tree representation. =item Parrot design documents (PDDs) Parrot design documents are the specifications for Parrot's interface to its "outside world". The PDDs serve basically the same purpose for Parrot that the Synopses serve for Perl 6. (See L). =item parse grammar A "parse grammar" is the set of rules and subroutines that are used to parse source code into an equivalent parse tree representation. In most computer science circles we would simply call this a "grammar", but in Parrot the term "grammar" is also used occasionally to specify other sets of transformation rules (that aren't necessarily performing parsing). Within the Rakudo compiler the terms "parse grammar" and "grammar" are pretty much interchangeable. =item PAST - Parrot Abstract Syntax Tree PAST is a set of classes used to represent the abstract semantics of a compiled program. Normally a compiler will convert source code into an equivalent PAST, and then allow the compiler toolkit to take care of the code generation. PAST is documented in PDD 26 - Parrot Abstract Syntax Tree (L). =item PCT - Parrot Compiler Toolkit The Parrot Compiler Toolkit is a suite of components that are useful for building compilers in Parrot. It consists of a base grammar for parsers ( C ), a base class for compilers ( C ), an abstract syntax tree representation (PAST), and a PAST compiler. =item PGE - Parse Grammar Engine The Parse Grammar Engine is the primarily regular expression engine for Rakudo and Parrot. It's the component that handles grammars and regular expressions in Rakudo, as well as being the primary foundation for parsing Perl 6 itself. =item Rakudo Rakudo is the name of a Perl 6 implementation that runs on Parrot. An abbreviation of "Rakuda-do," which, when translated from Japanese, means "The Way of the Camel". In Japanese, "Rakudo" means "Paradise." For more info, see L. =item STD.pm STD.pm is the "standard" Perl 6 grammar definition, see L. At the moment STD.pm is not really a "specification" in a proscriptive sense -- it's more of a guideline or model for Perl 6 implementations to follow. The goal is that eventually the various implementations will converge on a common grammar (that will probably look a lot like STD.pm). =item Tree Grammar Engine (TGE) Early versions of compilers for Parrot, including Rakudo, made use of the "Tree Grammar Engine" (F) to transform parse trees into an abstract syntax tree and then into executable code. For Rakudo, this has been obsoleted in favor of using action methods and NQP for transformation into PAST. =back =cut =head1 AUTHORS Patrick Michaud is the primary author and maintainer. =head1 COPYRIGHT Copyright (C) 2007, The Perl Foundation. =cut # Local Variables: # fill-column: 100 # End: # vim: expandtab shiftwidth=4: rakudo-2013.12/docs/guide_to_setting.pod0000664000175000017500000000623012224263172017575 0ustar moritzmoritz=encoding utf-8 =head1 NAME Guide to the C library =head1 DESCRIPTION Why we write built-in methods and functions in Perl 6, and what you should know when you write more such subs or methods. =head2 Reasons There are a few reasons to write built-in methods in Perl 6 and not in PIR, as done previously: =over =item Perl 6 is a much nicer language than PIR =item Typed Arrays/Lists are really parametric roles, and those are much easier to write in Perl 6 =item In order for Rakudo's multi-dispatchers to work properly, the target subs have to have Signature objects attached to them. This is far easier to do in Perl 6 than in PIR. =back There are two potential drawbacks: (1) slower execution, and (2) some operations can be expressed in PIR that cannot yet be expressed in Rakudo (and sometimes not even in Perl 6!). For cases where these drawbacks matter, we can use inline PIR or maintain the subroutines in PIR as needed. =head2 Guidelines Your patches to migrate PIR builtins to Perl 6 are very welcome, especially if they follow these guidelines: =over =item Think of laziness At some point in the hopefully not-so-distant future Lists will become lazy by default. So you should try to avoid anything that forces eager evaluation of arrays, like querying their length. This is bad: while $i < self.elems { ... } Better use a C loop, which will respect laziness for self.list { ... } If you assemble multiple items into a potentially lazy list, C is a very good construct to remember. =item Take care with type constraints Some of the Synopsis documents list type constraints for some of the arguments, including the invocant. They are not always correct, when in doubt leave them out. =item When adding a new file in src/setting/ ... remember to add it to L to the C variable and re-generate the Makefile using L. =item Prefer C to explicit invocant variables. Many of the method specifications in the synopses list explicit invocant variables. Using them often makes the code less clear, and can sometimes be incorrect (for example, an invocant of C<@values> will restrict the method to invocants that have the C role). Better is to use C, or if invoking a method on C then you can use C<$.foo> or C<@.bar> directly. =item All subs and methods are really multis All built-in methods or subroutines should be declared as C. =item Use explicit empty signatures If a method doesn't take any arguments, give it an explicit empty signature C<()>. That's very different from omitting the signature altogether (which would be an implicit catch-all signature). =item Use implicit return at the end of routines If no C statement is executed in a routine, the value of the last evaluated expression is returned. So if a C is the last statement in a routine, omit the C - currently explicit returns take much more time than implicit ones. =back =head1 SEE ALSO L L =for editor vim: ft=pod tw=70 rakudo-2013.12/docs/metamodel.pod0000664000175000017500000003207212224263172016213 0ustar moritzmoritz=head1 The Rakudo Metamodel =head2 Warning What follows is the current way this works in Rakudo. Parts of it may one day become spec, other bits likely never will. All of it is liable to change as we work out what should be spec and what shouldn't be, and also co-ordinate with other implementations and interested parties to make sure those bits that we determine should be specification are spec'd in a way that matches our shared desires and needs, so far as that's possible. It goes without saying that in doing the things described in this document, you're walking barefoot through a construction site. For now, tread carefully, and be prepared to patch up in response to changes. =head2 Overview Meta-objects are simply objects that describe parts of the object model. The metamodel lays down the interface that these objects should provide. In Rakudo we have several types of meta-object, all of which have an associated API (sometimes known as a Meta-object Protocol, just to make sure the whole topic appears to be sufficiently scary to outsiders, or something). This document defines the API for: =over 4 =item Packages meta-objects (representing classes, grammars, roles, etc); ones included in Rakudo include ClassHOW, GrammarHOW and RoleHOW. =item Attribute meta-objects (representing attributes); the default one of these is simply called Attribute. =item Composition meta-objects (e.g. specifying role composition algorithms) =back The composition model warrants a little explanation, since it is broken into a couple of parts. We'll stick with classes and roles for now, but we define the interface in the expectation that one day we might want to have things that are composed into a class following some composition algorithm that may be given a different name. Thus we talk in terms of "composables". There are two important things. First, the actual composer - implementing the composition algorithm - is not a part of the thing we're composing or the thing we're composing into (that is, it is independent of the class and the role). Second, it is up to the thing being composed (e.g. the role in the case of composing a role into a class) to supply the composer. =head2 Package meta-object API (aka HOW API) This is the API for packages. When we compile something like: class Town is Place { method bar() { say "mmm beer" } } Then it results in a set of calls like: my $temp = ClassHOW.new('Town'); &trait_mod:($temp, Place); $temp.^add_method('bar', anon method bar() { say "mmm beer" }); ::Town := $temp.^compose(); Most of these are calls on the meta-class to methods that give meaning to the keywords the user wrote in their code. The following methods are supported as a minimum. =over 4 =item method new($name?) Creates something that knows how to provide its metaclass, e.g. through the same mechanism as C<.HOW> obtains it. It need not be the final type-object that may be installed in a namespace or lexpad - that is for compose to return. However, there's nothing to stop it being. Whether a new instance of the meta-class is created or not is totally up to the implementation of the C method. For the standard Perl 6 C keyword in Rakudo, we create an instance of the meta-class and a temporary object that only knows how to reference the meta-class instance. However, if you were doing a more prototype-OO implementation, then you could instead have the meta-class be a singleton and return a new object, and the object itself knows completely about its methods, attributes and so forth, rather than this knowledge belonging to the meta-class. =item add_method($meta, $name, &code_ref) Adds a method to the methods table of C<$meta> under the given C<$name> and with the given implementation. =item add_attribute($meta, $name) Adds an attribute of the given C<$name> to C<$meta>. =item add_parent($meta, $parent) Adds the given parent to C<$meta>. =item add_composable($meta, $composee) Takes something that we are able to compose (for example, a role) and adds it to the composition list. Certainly, none of the built-in implementations of add_composable immediately perform any composition at this point. Instead, they add the composable to a "to do" list, and at the point we call "compose" to finish the composition of the package, and the application of all the composables takes place. You probably want to do something similar. =item applier_for($meta, $target) For non-composables (that is, packages that cannot be composed into others), this is an error. Otherwise, it returns something that we can use to apply the current package to the target. The thing returned should implement the composer API. It may be convenient to implement this is a set of multi subs. =item compose($meta) Finalizes the creation of the package. It can do any other composition-time operations, such as role composition and calling the composition hook on all attributes added to the package. Returns the type object that we're going to actually install into the namespace or lexical pad, or just return if it's an anonymous declaration. =back This is the declarational part of the API, however the introspection part should also be implemented. Please see the Introspection section of S12 for details on this. =head2 Attribute meta-object API This is the API that objects representing attributes should expose. The attribute meta-object is responsible for generating any accessor and/or delegation methods associated with the attribute. =over 4 =item new($name, :$has-accessor, :$rw, :$handles, :$build, :$type) Creates a new attribute meta-object, initialized with the name, whether or not the attribute has an accessor, whether or not that accessor 'is rw' and - if there was a handles trait modifier on the attribute - the handles trait modifier. =item compose($meta-package) Takes the attribute and does any final composition tasks (such as installing any accessor methods and/or delegators). The parameter is the meta-object of the package that the attribute belongs to; you can call .add_method on it to add methods, for example. =back =head2 Composer meta-object API The composer is responsible for composing something composable (in standard Perl 6, that's a role) into some other object (perhaps a class or another role or an instance). The minimal interface need only support one method, but it may well be that a composee and a composer choose to share knowledge of more than this (for example, a "requires" or "conflicts" list). =over 4 =item apply($target, @composees) Applies all of the composees to the target, or throws an exception if there is a problem with doing so. It's totally up to the composer exactly what it does; the default composer for Perl 6 roles will construct a single intermediate role and then compose that into the target, for example. Since the model is intended for more general composition-y things rather than just roles as are commonly defined today, we choose to give the composer a view of all of the composees. =back =head2 Metaclass Compatibility Warning: Conjectural. One rather complex issue we run into is what happens if you want to inherit from something that has a different metaclass. For now, we require that if some class S isa T, then also S.HOW isa T.HOW. This means that all other types of class-ish things that want to have a custom metaclass should subclass ClassHOW (either directly or transitively). Thus, this is fine: class A { } thingy B is A { } otherthingy C is B { } If the following is true: OtherThingyHOW.isa(ThingyHOW) and ThingyHOW.isa(ClassHOW) =head2 Composer Compatibility Warning: Conjectural. TODO: Provide a solution to the problems described here. Given it's the things we compose that determine what composer to use, we may easily run into a situation where different things want a different composer. At some level that's OK - if we want to support a more general notion of "things that do something composition-ish" then it is probably too restrictive to just always make this an error in the long run. For now, however, we do just that; when we have a good solution, we can relax the restriction. We do have the nicety that once we hit runtime, since composition is flattening by nature, we don't have any relationship at runtime with something that was composed in (besides keeping it in our list of "things that we composed"). Thus the problem of the behaviors of two different appliers is only a composition-time issue and not a runtime one. =head2 Associating a package declarator with a metaclass Rakudo provides two levels of hookage for creating new types of package declarator. You will very likely only need this one, which is the HOW map, %*HOW. This is simply a hash that maps the name of a scope declarator to the name of the HOW to create. At the entry point to your derived grammar, you should temporize the current HOW hash from the calling language, and add mappings from names of package declarators that you will introduce to the HOW to use. By default, this hash contains things like: { class => 'ClassHOW', role => 'RoleHOW' } It's completely fine for multiple package declarators to map to the same HOW - you may just wish to introduce a new one as better documentation but not need to do anything more special in terms of the meta-model. Note that your rule for parsing the scope declarator sets the name of the thing in this map in the $*PKGDECL global. For example, here is one from STD. token package_declarator:role { :my $*PKGDECL ::= 'role'; } You should do the same (and it's probably nice if what you set matches the name of the symbol you parse). =head2 Meta-programming Example: Adding AOP Support Note that this currently does not work in Rakudo, and will probably change a bit. It's purpose is mostly a thought experiment to try and help sanify the design of the metamodel. slang AOP { method TOP { temp %*HOW; %*HOW := AspectHOW; my $lang = self.cursor_fresh( AOP ); $lang.comp_unit; } token package_declarator:sym { :my $*PKGDECL := 'aspect'; } } class AspectComposer { method apply($target, @aspects) { my @wrappables = $target.methods(:local); for @aspects -> $aspect { for $aspect.method_wrappers.kv -> $name, $wrapper { my ($wrappee) = @wrappables.grep({ .name eq $name }); if $wrappee { $wrappee.wrap($wrapper); } else { die "No sub found to wrap named '$name'"; } } } } } class Aspect { has $.HOW; has $.Str; method WHAT() { self } method defined() { False } } class AspectHOW { has %.method_wrappers; method new($name) { return Aspect.new( HOW => self.bless(*), Str => $name ~ "()" ); } method add_method($obj, $name, $method) { $.method_wrappers{$name} = $method; } multi method composer_for($obj, $ where { .can('methods') }) { return AspectComposer; } multi method composer_for($obj, Object) { die "Can only apply aspects to things that expose methods"; } method compose($obj) { return $obj; } method add_attribute($meta, $attr) { die "Aspects do not support attributes"; } method add_parent($meta, $parent) { die "Aspects do not support inheritance"; } method add_composable($meta, $composable) { die "Aspects do not support being composed into"; } } This could then we used as something like: use AOP; aspect LogToStderrToo { method log($message) { $*ERR.say($message); nextsame; } } class ErrorLog does LogToStderrToo { method log($message) { my $fh = open("log", :a); $fh.say($message); $fh.close; } } Note that a usable implementation would want a bit more than this, and have many other design considerations. =head2 Influencing package code generation Note: This is highly Rakudo-specific and very likely to remain that way. The good news is that you won't need to do it often. Rakudo has a compile-time representation of the package currently being compiled. This is the thing that ends up actually generating the code - PAST nodes - that make the calls on the metaclass. By default, we always create an instance of Perl6::Compiler::Package, apart from for roles and modules, for which we need to do some slightly different code generation - those use a subclass of it, such as Perl6::Compiler::Role. You may modify %*PKGCOMPILER, again keying on $*PKGDECL, to specify something other than the default. You should then write a subclass of an existing handler for this and implement the same interface (plus any other bits you'll need - it's just a class). rakudo-2013.12/docs/metaobject-api.pod0000664000175000017500000000606212224263172017130 0ustar moritzmoritz=head1 Rakudo Meta-Object API This document describes the meta-objects that constitute Rakudo's objects implementation. It also describes the API to implement should you wish to introduce your own meta-objects. =head2 Meta-model Organization Rakudo is built on top of the NQP platform. NQP provides an object model core that is often known as "6model". It is inspired by the needs of Perl 6, but actually provides a very minimal base that other languages can build their own meta-objects on top of. While Rakudo could start from these base primitives, instead it makes use of some of the NQP meta-objects. Out of the box 6model provides no concept of classes or roles. NQP's meta-objects include a simple, non-parametric implementation of roles and a simple but capable implementation of classes. These are put to use in writing Rakudo's meta-objects. The Rakudo meta-objects are generally factored in terms of roles. These are composed into classes that represent the various types of Perl 6 package (such as classes and roles). =head2 Roles The following roles exist and provide re-usable pieces of functionality that can be re-used in various places in the meta-model. =head3 MethodContainer This role provides storage of methods, method addition and method introspection. =head3 MultiMethodContainer This role provides the extra pieces needed for multi-method handling. =head3 AttributeContainer This role provides storage of attributes, attribute addition and attribute introspection. =head3 RoleContainer This role provides storage of roles, role addition and role introspection. The composition process is not part of the functionality provided by this role, however. =head3 MultipleInheritance Provides for addition of multiple parents, and introspection of them too. =head3 C3MRO This role provides an implementation of the C3 method resolution order. =head3 Versioning This role provides storage and introspection of a version and authority. =head2 Classes The following classes exist in the Perl 6 meta-model. =head3 ModuleHOW Provides an implementation of modules. =head3 ClassHOW Provides an implementation of classes. =head3 ParametricRoleHOW Provides an implementation of parametric roles, which may be instantiated. =head3 ConcreteRoleHOW Provides an implementation of a concrete instance of a role. =head3 GrammarHOW Provides an implementation of grammars. Actually, just a subclass of the ClassHOW since grammars are really just slightly specialized classes. =head3 NativeHOW Meta-object for a native type (only accesible via the type object, perhaps). =head3 SubsetHOW Provides an implementation of subset types. =head3 Attribute Represents an attribute. =head3 RoleToClassComposer Composes a single role into a class. (If many roles are specified, it makes a single role that does all of the roles the class wishes to, and then composes that single role). =head3 RoleToRoleComposer Composes one or more roles into another role, creating a kind of role "summation". =head3 RoleToObjectComposer Compoes a role into an object - essentially doing a mix-in. rakudo-2013.12/docs/parrot-relationship.txt0000664000175000017500000001342612224263172020311 0ustar moritzmoritzBackground: For a variety of reasons, Rakudo continues to target Parrot monthly releases. This implies that Rakudo developers must periodically test and develop against the HEAD of Parrot's master branch, to detect potential breakages before they make it into a monthly Parrot release that Rakudo expects to build against shortly thereafter. Early reporting of potential issues, breakages, and performance degradatation of Parrot HEAD prior to any release is also very beneficial to Parrot development. During the May 2011 Parrot Developers Summit the participants agreed that Parrot will continue to support Rakudo's efforts to target Parrot monthly releases and be regularly synchronized with Parrot's master branch. Note that the above agreement does _not_ go so far as to state that commits to Parrot master can never cause a Rakudo failure. We recognize that breakages will occasionally occur between Rakudo and Parrot's HEAD, both within and outside of the scope of Parrot's deprecation and support policies. Such interim breakages are completely acceptable as long as there is some confidence by both development teams that whatever issue is causing the breakage is likely to be resolved satisfactorily prior to the next Parrot monthly release. It is when such resolution seems unlikely that there has been sharp and contentious debate over the "how, where, who, and when" details of solving whatever issue may be at hand. This is what the new policy aims to address. The policy: Starting May 2011, Parrot and Rakudo will designate two persons from each team to serve as "relationship managers" to resolve any issues that arise between the two projects. These managers are expected to carry sufficient clout or authority to effect potentially unpopular decisions within their respective projects (e.g., reverting commits, delaying feature availability, adjusting development schedules, etc.). Christoph Otto and Andrew Whitworth have been selected as Parrot's relationship managers for Rakudo; Rakudo managers for Parrot will be represented by Moritz Lenz and Patrick Michaud. In the future, when Rakudo developers feel that discussions about Parrot on IRC, mailing list, or other channels are unlikely to resolve a critical breakage or performance issue they are encountering, the developers should bring the issue to the attention of one or both of Rakudo's representatives ( or ). The Rakudo developers involved should also seek to reduce any pressure they may be applying in the other forums. (Reducing pressure can be as simple as "I think we may be at an impasse that needs the guidance of the relationship managers, let's get them to work on it and we can go have a beer.") The Rakudo representatives will evaluate any issue brought to their attention, and they will then bring it to the attention of the Parrot representatives if they deem it appropriate. At this point, the representatives from both teams will collectively work to arrive at a consensus solution that will be acceptable to both projects (if not to all of the participants). The mechanisms by which the representatives choose to arrive at their decisions are entirely up to them. The above process also holds in reverse for Parrot developers that feel an issue has become unresolvable via direct discussions with Rakudo developers. Note that petitioning or pressuing another project's relationship managers directly (in their role as relationship manager) is highly discouraged. Once it's decided that relationship managers need to be involved, opinions and discussions between the managers will carry far more weight than those coming across project boundaries. A relationship manager is free to answer cross-project lobbying requests from non-managers with "Raise this issue with your project's relationship managers." There are two primary motivations for the establishment of project relationship managers. First, we want to provide a "safety valve" to relieve heat/pressure and provide a path forward whenever the normal discussion channels start to appear impossibly deadlocked. Second, we want a mechanism that ensures that critical decisions aren't appearing to be made (either explicitly or through inaction) solely because of the set of participants of any given IRC discussion or mailing list thread. Bringing an issue to the attention of a relationship manager does not mean that the issue will be immediately resolved, nor that that the issue will ultimately be resolved in exactly the manner desired by the requestor. What it does mean is that the relationship managers have committed (1) to thoughtfully investigate and respond to any issues raised by their counterparts, so that we can all have some confidence that the issues have been carefully considered from many sides by people empowered to make changes if needed, and (2) to work on such issues in a timely manner, so that the overall disruptions to Parrot's and Rakudo's development are minimized. We all know that Parrot developers want Rakudo to succeed, and vice-versa. Nobody is intentionally trying to make things difficult for others; the projects are just sufficiently complex that it's impractical for us to completely avoid any surprises (breakages) in either project. We know surprises will occur; this new policy will hopefully enable us to collectively handle the inevitable surprises more productively than we have in the past ("fail softly"). We'll try it and see how it works out; if it doesn't work out, we'll come up with something else. (Or perhaps well all need to discuss it with our relationship managers. :-) Comments and feedback welcomed. [1] http://irclog.perlgeek.de/parrotsketch/2011-05-14 [2] http://lists.parrot.org/pipermail/parrot-dev/2011-May/005887.html [3] http://lists.parrot.org/pipermail/parrot-dev/2011-June/005945.html rakudo-2013.12/docs/release_guide.pod0000664000175000017500000002444012255234316017043 0ustar moritzmoritz=encoding UTF-8 =head1 release_guide.pod - guide to Rakudo releases Rakudo's development release cycle is based on Parrot's release cycle. Parrot releases are scheduled for the third Tuesday of each month; Rakudo will generally issue its own development release two days later (on Thursday). Each development release is given a sequential number and a code name based on an active Perl Mongers group. Rakudo's February 2009 release is #14; prior releases were bundled as part of monthly Parrot releases. For releases made so far, see the list of development releases at the end of this document. =head2 Planned future releases Releases are typically on the third Thursday of each month. 2014-01-23 Rakudo #72 masak 2014-02-20 Rakudo #73 2014-03-20 Rakudo #74 2014-04-17 Rakudo #75 2014-05-22 Rakudo #76 2014-06-19 Rakudo #77 =head2 Suggested .pm group names for future releases Names can be gotten from L if you can't think of one with any particular significance to Perl 6 or Rakudo. =head2 Steps to create a release (for release managers) =over 4 =item 1. A few days before the Rakudo release, it's a good idea to... =over 4 =item * Remind people of the upcoming release, invite people to update the ChangeLog file, update the ROADMAP, choose a release name, etc. =item * Review the RT queue for tickets that might need resolving prior to the release, addressing them as needed. "Tickets that need resolving" is left your discretion. Any problem that has a large impact on users is worth addressing either as a fix or as prominent documentation (the README and/or the release announcement). =item * Create a draft release announcement in docs/announce/YYYY.MM.md in markdown format. You can often use the previous release's file as a starting point, updating the release number, version information, name, etc. as appropriate. $ git add docs/announce/YYYY.MM.md $ git commit docs =item * If it's a month relatively early in the calendar year, double-check that the copyright date in the README file includes the current year. (It's not necessary to update copyright dates in other files, unless you know that a given file has been modified in a year not reflected by the file's copyright notice.) =back =item 2. Update Rakudo's leap-second tables: $ perl tools/update-tai-utc.pl src/core/tai-utc.pm If a new leap second has been announced, F will be modified, so commit the new version: $ git commit src/core/tai-utc.pm But probably there won't be any new leap seconds, in which case the file will be unchanged. B: this program requires the perl modules L, L and L to be installed. =item 3. As the actual release date nears, review the git log history to see if any additional items need to be added to the ChangeLog. This can be conveniently done with "git log --since=yyyy-mm-dd --reverse". $ git commit docs/ChangeLog =item 4. When it's time to cut the release, finalize the new release announcement in docs/announce/YYYY.MM.md . (If one hasn't already been created, see step 1 above.) Highlight areas in which the new release is significant. If possible, also give some small details about the choice of release name. (If the details are a bit lengthy, this can often best be done as a separate section at the bottom of the announcement.) Include a list of contributors since the last release in the announcement. You can get an automatically generated list by running $ perl tools/contributors.pl B: this program requires the perl module L be installed. Please check the result manually for duplicates and other errors. $ git add docs/announce/YYYY.MM.md $ git commit docs =item 5. Update the release dates and names at the bottom of this file (F). Also improve these instructions if you find any steps that are missing. $ git commit docs/release_guide.pod =item 6. Create an NQP release with the same C version number as Rakudo. Follow NQP's C file to do that. =item 7. Go back to the Rakudo repository, and update the NQP dependency: $ echo YYYY.MM > tools/build/NQP_REVISION $ git commit -m '[release] bump NQP revision' tools/build/NQP_REVISION =item 8. Enter the new version into the F file, and commit the changes: $ echo YYYY.MM > VERSION $ git commit -m '[release] bump VERSION' VERSION =item 9. Make sure any locally modified files have been pushed back to github. $ git status $ git push =item 10. Make sure everything compiles and runs from a known clean state: $ make realclean $ perl Configure.pl --gen-parrot $ make $ make test $ make stresstest There are many tests to run for the stresstest target. If you have a machine with multiple CPU cores, you may want to execute that last as $ TEST_JOBS=4 make stresstest where 4 is the number of CPU cores. This should make the total time to execute all of the tests dramatically less. Continue adjusting things until make stresstest passes as expected. Often this means fixing a bug, fudging a test, or (temporarily?) commenting out a test file in t/spectest.data . Use your best judgment or ask others if uncertain what to do here. =item 11. Create a tarball by entering C, where YYYY.MM is the month for which the release is being made. This will create a tarball file named C. B: this step removes any untracked files in F. So please make a backup if you have any important data in there. =item 12. Unpack the tar file into another area, and test that it builds and runs properly using the same process in step 8. If there are any problems, fix them and go back to step 8. =item 13. Tag the release by its release month ("YYYY.MM") and its code name. $ git tag -a -m"tag release #nn" YYYY.MM # e.g., 2013.08 $ git tag -a -m"tag release #nn" CODENAME # e.g., "Bratislava" $ git push --tags =item 14. Upload the tarball to L: $ scp rakudo-YYYY.MM.tar.gz rakudo@rakudo.org:public_html/downloads/rakudo/ If you do not have permissions for that, ask one of (pmichaud, jnthn, masak, tadzik, moritz, PerlJam) on #perl6 to do it for you. =item 15. To avoid public confusion with Rakudo Star releases, we now publish compiler release announcements ONLY to perl6-compiler@perl.org. (We may restart widespread announcements of compiler releases once they are known, or we may begin publishing a single announcement for both.) Don't send out any announcements until the files are actually available per step 14 above. =item 16. Update the Wikipedia entry at L. =item 17. You're done! Celebrate with the appropriate amount of fun. =back =head2 Development releases so far 2009-02-26 Rakudo #14 "Vienna" (pmichaud) 2009-03-20 Rakudo #15 "Oslo" (pmichaud) 2009-04-23 Rakudo #16 "Bratislava" (pmichaud) 2009-05-21 Rakudo #17 "Stockholm" (pmichaud) 2009-06-18 Rakudo #18 "Pittsburgh" (pmichaud) 2009-07-23 Rakudo #19 "Chicago" (moritz) 2009-08-20 Rakudo #20 "PDX" (kyle) 2009-09-17 Rakudo #21 "Seattle" (particle) 2009-10-22 Rakudo #22 "Thousand Oaks" (duff) 2009-11-19 Rakudo #23 "Lisbon" (masak) 2009-12-17 Rakudo #24 "Seoul" (chromatic) 2010-01-22 Rakudo #25 "Minneapolis" (pmichaud) 2010-02-18 Rakudo #26 "Amsterdam" (mberends) 2010-03-18 Rakudo #27 "Copenhagen" (smash) 2010-04-22 Rakudo #28 "Moscow" (moritz) 2010-05-20 Rakudo #29 "Erlangen" (colomon) 2010-06-17 Rakudo #30 "Kiev" (masak) 2010-07-22 Rakudo #31 "Atlanta" (Coke) 2010-08-19 Rakudo #32 "Pisa" (mathw) 2010-09-23 Rakudo #33 "Milan" (moritz) 2010-10-21 Rakudo #34 "Paris" (duff) 2010-11-18 Rakudo #35 "Melbourne" (masak) 2010-12-23 Rakudo #36 "New York" (smash) 2011-01-20 Rakudo #37 "BristolBath" (tadzik) 2011-02-17 Rakudo #38 "Toulouse" (arnsholt) 2011-03-17 Rakudo #39 "Orlando" (jdhore) 2011-04-21 Rakudo #40 "ZA" (duff) 2011-05-19 Rakudo #41 "Dahut" (jdhore) 2011-06-23 Rakudo #42 "Bruxelles" (jdhore) 2011-07-21 Rakudo #43 "Beijing" (mberends,moritz) 2011-08-18 -- none -- 2011-09-30 Rakudo #44 "Riga" (tadzik) 2011-10-20 Rakudo #45 "Houston" (duff) 2011-11-17 Rakudo #46 "London" (tadzik) 2011-12-22 Rakudo #47 "Columbus" (moritz) 2012-01-23 Rakudo #48 "Toronto" (moritz) 2012-02-23 Rakudo #49 "SPb" (masak) 2012-03-22 Rakudo #50 "Argentina" (masak) 2012-04-19 Rakudo #51 "Brazos Valley" (Coke) 2012-04-25 2012.04.1 (moritz) 2012-05-17 Rakudo #52 "MadMongers" (tadzik) 2012-06-21 Rakudo #53 "Strasbourg" (duff) 2012-07-19 Rakudo #54 "Tallinn" (masak) 2012-08-23 Rakudo #55 "Frankfurt" (tadzik,moritz) 2012-09-20 Rakudo #56 "Perl" (masak) 2012-09-29 2012.09.1 (pmichaud) 2012-10-18 Rakudo #57 "Tokyo" (duff) 2012-11-22 Rakudo #58 "Walnut" (FROGGS) 2012-12-20 Rakudo #59 "Warszawa" (masak) 2013-01-17 Rakudo #60 "Sonoma" (isBEKaml) 2013-02-21 Rakudo #61 "drinkers" (tadzik) 2013-02-23 2013.02.1 (moritz) 2013-03-21 Rakudo #62 "Singapore" (masak) 2013-04-18 Rakudo #63 "Albany" (Coke) 2013-05-23 Rakudo #64 "Austin" (FROGGS) 2013-06-20 Rakudo #65 "Poznan" (masak) 2013-07-18 Rakudo #66 "Edinburgh" (moritz,lizmat) 2013-08-22 Rakudo #67 "Bicycle" (moritz) 2013-09-19 Rakudo #68 "Shanghai" (masak) 2013-10-17 Rakudo #69 "Roederbergweg" (Coke) 2013-11-21 Rakudo #70 "Malmö" (lizmat) 2013-12-19 Rakudo #71 "Advent" (moritz) =head1 COPYRIGHT Copyright (C) 2009-2013, The Perl Foundation. =cut # Local Variables: # fill-column: 100 # End: # vim: expandtab shiftwidth=4: rakudo-2013.12/docs/ROADMAP0000664000175000017500000000647212250627156014560 0ustar moritzmoritzRakudo Roadmap -------------- Last updated: 2013-10-25 This document serves as a guide to the major goals for Rakudo development, as things stood in December 2011. They have been roughly categorized. Each has been given a 1-3 priority indicator, where 1 is "fairly pressing", 2 is "desirable", and 3 is "wanted, but not a key goal right now". Each item also has from one to five asterisks indicating the estimated "degree of effort" required for the item. A lower priority does not mean, "don't work on this". If you want to hack on a priority 3 item, go right ahead. It is, after all, wanted. And things that are priority 3 now will eventually work their way up to the top anyway. Mostly, -Ofun. Some items are marked with the names of people likely to either work on them OR serve as a "contact person" for the goal. Again, don't let a name already being against a goal stop you working on it - though it would be wise that you check where the marked person is at with it to avoid any duplicated effort, or to pick up hints about how to jump in. :-) Patches to this document are welcome - to add missing goals, remove completed ones, re-prioritize, volunteer for a goal, rescue yourself from a goal, etc. Compiler Performance/Portability Improvements (jnthn) 3 ** Optimizing multis for `[+] 1..10` and `[<=] 1..10` etc. Macros (masak) 2 ** hygienic macros and the COMPILING:: pseudopackage 2 **** "delayed" declarations of routines and types within quasiquotes 3 ? Textual macros Operators 2 *** missing native operators, including ++/-- (jnthn) 3 ** logical cascades Regexes 2 ** ~~ inside regexes 3 ** <*foo> 3 ** <~~0>, <~~foo> 3 *** explicit backtracking control (::, :::) 3 ** and Built-ins/Data Structures 2 ** throwing typed exceptions (moritz) 2 *** packed arrays (jnthn) 2 ***** NFG strings, .codes, .graphs, etc. 2 ** Rat/FatRat/Rational cleanup 2 ** sized/shaped arrays (jnthn) 2 *** val() (japhb) 2 ** Correct type smiley support (:U, :D, :T, etc.) (jnthn) 3 *** arrays with custom keys 3 *** complete Buf implementation (depends on 'is rw' native ints) 3 *** complete LoL and slice context implementation 3 *** Cat and stream matching Language Features 1 *** basic Perl 5 interop (use, eval, etc.) (diakopter) 2 * $=DATA and friends (tadzik) 2 ** module versioning (lizmat,FROGGS) 2 ** missing bits of enums 2 *** new syntax/semantics for coercion (jnthn) 2 ** MAIN and USAGE (japhb) 2 ** Failure changes (japhb) 2 *** coercion types 2 * tr/// 2 ** 'no strict;' (moritz,FROGGS) 3 *** domain specific languages -- slang and grammar tweaks (FROGGS) 3 **** more advanced Perl 5 interop (lexical embedding, etc.) (FROGGS) 3 ? Parse and execute simple Perl 5 code (FROGGS) 2 ** label handling using goto, next, last ... Optimizer (jnthn) 2 ** ro/rw variable tracking, related transforms 2 ** context/non-context variable tracking 2 *** :D/:U constraint tracking and integration with dispatch analysis 2 * topic preservation elimination on simple block inlines 2 *** inlining calls to methods 3 *** guard lifting for method call inlining STD Convergence (needs more exploration) 2 ** more of STDs TTIAR error handling Other things (to be organized into above groups) 3 ? AUTOLOAD, including possibly AUTOLOADING setting components rakudo-2013.12/docs/running.pod0000664000175000017500000000477212224263172015732 0ustar moritzmoritz=head1 NAME perl6 - Rakudo Perl 6 Compiler =head1 SYNOPSIS perl6 [switches] [--] [programfile] [arguments] =head1 DESCRIPTION With no arguments, enters a REPL. With a C<[programfile]> or the C<-e> option, compiles the given program and by default also executes the compiled code. -c check syntax only (runs BEGIN and CHECK blocks) --doc extract documentation and print it as text -e program one line of program -h, --help display this help text -n run program once for each line of input -p same as -n, but also print $_ at the end of lines --target=[stage] specify compilation stage to emit -t, --trace=[flags] enable trace flags, see 'parrot --help-debug' --encoding=[mode] specify string encoding mode -o, --output=[name] specify name of output file -v, --version display version information --stagestats display time spent in the compilation stages --ll-exception display a low level backtrace on errors --profile print profile information to standard error Note that only boolean single-letter options may be bundled Output from C<--profile> can be visualized by C. Supported stages for --target are: parse past post pir evalpmc where parse = a representation of the parse tree past = an intermediate format representing the parrot abstract syntax tree post = an intermediate format representing the parrot opcode syntax tree pir = the parrot intermediate representation =head1 List of env vars used in Rakudo =over =item C, C (src/core/terms.pm) Appends a delimited list of paths to C<@INC>. C is evaluated first. =item C (src/Perl6/ModuleLoader.pm) If set to a non-false value, causes the module loader to print debugging information to standard error. =item C (src/core/Exception.pm) Controls whether to emit ANSI codes for error highlighting. Defaults to true if unset, except on Win32. =back =head1 PARROT OPTIONS To specify options to the underlying parrot VM, you must explicitly run parrot; you cannot specify these options by using the C executable. parrot [parrot switches] perl6.pbc [switches] [--] [programfile] [arguments] See C for a list of valid parrot options. =head1 AUTHORS Written by the Rakudo contributors, see the CREDITS file. This manual page was written by Reini Urban, Moritz Lenz and the Rakudo contributors. =cut rakudo-2013.12/docs/S11-Modules-proposal.pod0000664000175000017500000001210412224263172020045 0ustar moritzmoritz=head1 S11-Modules proposal for Rakudo * implementation The aim will be to implement it all in NQP if possible. =head1 Overriding Principle The source code must always be the absolute source of all information. Everything else should act as a cache. That means *.pir files and databases of metadata may be automatically or manually derived from the *.pm files, but they may not add information (from the command line, for example). If there is to be cached metadata in future, it should be stored in files as close to the corresponding source files as possible. If modules are precompiled to *.pir files, those files will be stored in the same directories as their corresponding *.pm source files, with identical names apart from the extension. =head1 Restrictions and limitations =head2 No C keyword Classes may contain other classes, which provides sufficient hierarchy. Rakudo will implement C, in order to contain sub definitions that do not belong to any class. =head2 Only simplest :ver and :auth implementation There should be only one C<:ver> and C<:auth> name part per source code file, in order to keep the implementation simple. In order to keep users sane, multiple C<:ver> or C<:auth> name parts in the same source file will make the using program die with a NYI error. The following is ok (loaded by "use Foo::Bar:ver<1.2.3>:auth"): # in Foo/Bar.pm class Foo::Bar:ver<1.2.3>:auth { # or module, grammar etc ... class Baz { ... } } The following (nested class declarations) will not be implemented in Rakudo *: # in Foo.pm module Foo { # or class Foo, grammar Foo etc class Bar:ver<1.2.3>:auth { ... } } =head2 No Unicode mangling in file names If you want to use Unicode in your module names, your file system must support Unicode as well. If you want users without Unicode file names to use your modules, don't use Unicode in your module names. =head2 Retain @*INC to specify where searching begins Rakudo effectively gives the following output to -e'.say for @*INC' ~/.perl6/lib parrot_install/lib/2.1.0-devel/languages/perl6/lib . The . entry may be removed from the default @*INC because it creates a security risk, but it is needed in the medium term for the build process to conveniently find F. Unlike the Perl 5 case, all matching candidate files in all applicable directories will be considered, so in most cases the order of directories in @*INC is not significant. If copies of the same module name with the same C<:auth> and C<:ver> name parts exist in the same or even different directories, Rakudo may arbitrarily use any one of those files and ignore the others. The module installer utility should try to prevent such duplication arising, but should tolerate it if it already exists. =head2 Room for wriggling on file names If multiple instances of a module exist, they may be distributed among all the @*INC directories. Folders correspond to packages (aka namespaces) and they are not allowed to have :ver and :auth name parts. In every directory, file name collisions are avoided by optionally inserting a unique .infix in the name before the .pm extension. The following would all match a C command: Foo.pm Foo.1.pm Foo.12345.pm Currently only digits are being considered, but anything within reason between the two dots should be allowed, and is under the control of the module installer. The infix characters are meaningless. Only the code inside the file specifies :ver and :auth. =head1 Searches in C, C and C commands In commands such as C, the :auth and :ver name parts are independently optional. Rakudo * will do only exact matches on :auth and :ver name parts, because the alternative gives headaches... Consider the example "use Foo::Bar:ver<1.2.3>:auth" Rakudo * will look for files matching Foo/Bar.pm and Foo/Bar.*.pm from every starting point listed in @*INC. Rakudo will then open each file in turn and partially (how?) parse the content to extract the first :ver and :auth values, building a list of the results. Caching will probably be added soon after the initial implementation works, in order to reduce the obvious overheads. If the C specified an C<:auth> or a C<:ver>, the values must match, and non-matching files are disqualified. Rakudo will consider files in the user's local directories (. and ~/.perl6/lib) that omit :auth and :ver values. Modules in the parrot_install tree should all have :auth and :ver. If the :ver is not specified, Rakudo must select the file containing the highest :ver value. Files without :ver are considered as having the lowest possible :ver value. Multiple files without :ver, or multiple files with the same :ver, will result in an arbitrary selection. =head1 Implementation notes There is a Perl 5 stub implementation of the module finding algorithm in the rmp repository L in the file C. Commit bits to that repo are handed out freely; just ask hugme on #perl6 :-). rakudo-2013.12/docs/spectest-progress.csv0000664000175000017500000013115312224263172017751 0ustar moritzmoritz"date","revision","pass","fail","todo","skip","regr","spec","files" "2008-05-22 00:00",27739,223,0,0,341,564,2905,31 "2008-05-23 00:00",27763,228,0,0,341,569,2905,32 "2008-05-24 00:00",27775,228,0,0,341,569,2915,32 "2008-05-25 00:00",27796,310,0,0,356,666,2915,39 "2008-05-26 00:00",27812,310,0,0,356,666,2915,39 "2008-05-27 00:00",27839,310,0,0,356,666,2956,39 "2008-05-28 00:00",27868,317,0,0,349,666,2964,39 "2008-05-29 00:00",27910,394,4,15,361,774,3011,43 "2008-05-30 00:00",27933,415,0,15,345,775,3012,43 "2008-05-31 00:00",27953,415,0,15,345,775,3014,43 "2008-06-01 00:00",27986,518,0,15,359,892,3014,52 "2008-06-02 00:00",28021,623,0,15,374,1012,3014,55 "2008-06-03 00:00",28042,623,0,15,374,1012,3014,55 "2008-06-04 00:00",28058,624,0,14,374,1012,3014,55 "2008-06-05 00:00",28084,668,0,15,424,1107,3063,58 "2008-06-06 00:00",28127,674,0,14,422,1110,3068,58 "2008-06-07 00:00",28161,682,0,16,441,1139,3068,59 "2008-06-08 00:00",28174,697,0,17,425,1139,3078,59 "2008-06-09 00:00",28192,699,0,15,425,1139,3079,59 "2008-06-10 00:00",28223,699,0,15,425,1139,3079,59 "2008-06-11 00:00",28229,705,0,15,425,1145,3104,59 "2008-06-12 00:00",28248,705,0,15,425,1145,3125,59 "2008-06-13 00:00",28298,707,0,15,426,1148,3129,60 "2008-06-14 00:00",28331,711,0,15,422,1148,3129,60 "2008-06-15 00:00",28372,754,0,15,432,1201,3153,63 "2008-06-16 00:00",28412,779,0,15,432,1226,3189,64 "2008-06-17 00:00",28454,781,0,15,434,1230,3200,64 "2008-06-18 00:00",28506,781,0,15,434,1230,3200,64 "2008-06-19 00:00",28535,781,0,15,434,1230,3405,64 "2008-06-20 00:00",28570,792,0,15,434,1241,3452,65 "2008-06-21 00:00",28591,794,0,15,431,1240,3451,65 "2008-06-22 00:00",28627,843,0,15,391,1249,3494,66 "2008-06-23 00:00",28658,849,0,20,384,1253,3505,66 "2008-06-24 00:00",28672,849,0,20,384,1253,3510,66 "2008-06-25 00:00",28693,891,0,31,389,1311,4218,70 "2008-06-26 00:00",28701,944,0,38,432,1414,4292,73 "2008-06-27 00:00",28737,1080,1,38,310,1429,4311,75 "2008-06-28 00:00",28767,1072,17,38,314,1441,4338,75 "2008-06-29 00:00",28810,1077,74,38,286,1475,4380,75 "2008-06-30 00:00",28840,1126,0,38,307,1471,4484,74 "2008-07-01 00:00",28858,1172,0,36,314,1522,4484,75 "2008-07-02 00:00",28928,1290,0,47,368,1705,4788,80 "2008-07-03 00:00",28991,1365,0,47,418,1830,4814,83 "2008-07-04 00:00",29042,1473,0,56,539,2068,5096,86 "2008-07-05 00:00",29065,1587,0,59,433,2079,5097,87 "2008-07-06 00:00",29090,1587,0,59,433,2079,5115,87 "2008-07-07 00:00",29114,1618,0,84,462,2164,5240,90 "2008-07-08 00:00",29144,1662,0,86,504,2252,5283,94 "2008-07-09 00:00",29181,1677,0,82,498,2257,5288,94 "2008-07-10 00:00",29220,1679,0,85,520,2284,5328,94 "2008-07-11 00:00",29277,1691,0,85,520,2296,5340,95 "2008-07-12 00:00",29323,1691,0,85,520,2296,5340,95 "2008-07-13 00:00",29376,1691,0,85,520,2296,5340,95 "2008-07-14 00:00",29418,1691,0,85,520,2296,5350,95 "2008-07-15 00:00",29468,1695,0,85,516,2296,5350,95 "2008-07-16 00:00",29503,1736,0,81,521,2338,5389,96 "2008-07-17 00:00",29544,1736,0,81,521,2338,5401,96 "2008-07-18 00:00",29575,1770,0,84,529,2383,5429,97 "2008-07-19 00:00",29607,1763,0,87,576,2426,5492,98 "2008-07-20 00:00",29628,1763,0,87,576,2426,5540,98 "2008-07-21 00:00",29642,1763,0,87,576,2426,5555,98 "2008-07-22 00:00",29666,1799,0,94,606,2499,5578,102 "2008-07-23 00:00",29691,1799,0,95,606,2500,5589,102 "2008-07-24 00:00",29719,1815,0,98,606,2519,5610,104 "2008-07-25 00:00",29733,1845,56,103,569,2573,5694,107 "2008-07-26 00:00",29749,1885,0,105,600,2590,5694,110 "2008-07-27 00:00",29786,1896,0,104,599,2599,5703,112 "2008-07-28 00:00",29822,1902,0,103,612,2617,5770,113 "2008-07-29 00:00",29837,1902,0,103,612,2617,5803,113 "2008-07-30 00:00",29869,1861,79,108,583,2631,5845,114 "2008-07-31 00:00",29902,5,2627,0,0,2632,5846,115 "2008-08-01 00:00",29917,1998,3,105,629,2735,5877,116 "2008-08-02 00:00",29933,1998,3,105,629,2735,5877,116 "2008-08-03 00:00",29963,2003,12,105,615,2735,6055,116 "2008-08-04 00:00",29990,2003,12,105,615,2735,6055,116 "2008-08-05 00:00",30019,2102,12,140,827,3081,6055,118 "2008-08-06 00:00",30052,2102,12,140,827,3081,6055,118 "2008-08-07 00:00",30081,2102,12,140,827,3081,6055,118 "2008-08-08 00:00",30120,2198,3,135,869,3205,6065,121 "2008-08-09 00:00",30136,2200,3,135,867,3205,6065,121 "2008-08-10 00:00",30154,2200,3,135,867,3205,6065,121 "2008-08-11 00:00",30161,2196,0,131,878,3205,6065,121 "2008-08-12 00:00",30179,0,3205,0,0,3205,6075,121 "2008-08-13 00:00",30201,2196,0,131,878,3205,6075,121 "2008-08-14 00:00",30217,2196,0,131,878,3205,6075,121 "2008-08-15 00:00",30243,2196,0,131,878,3205,6075,121 "2008-08-16 00:00",30256,2220,0,134,914,3268,6138,121 "2008-08-17 00:00",30275,2220,0,134,914,3268,6170,121 "2008-08-18 00:00",30292,2220,0,134,914,3268,6170,121 "2008-08-19 00:00",30322,2220,0,134,914,3268,6242,121 "2008-08-20 00:00",30370,2249,0,133,938,3320,6235,123 "2008-08-21 00:00",30419,2256,0,248,812,3316,6249,123 "2008-08-22 00:00",30434,2256,0,248,812,3316,6253,123 "2008-08-23 00:00",30465,2263,0,258,814,3335,6278,125 "2008-08-24 00:00",30499,2267,0,258,822,3347,6288,126 "2008-08-25 00:00",30527,2278,0,262,816,3356,6309,127 "2008-08-26 00:00",30556,2278,0,262,816,3356,6309,127 "2008-08-27 00:00",30584,2278,0,262,819,3359,6312,127 "2008-08-28 00:00",30609,2344,0,263,835,3442,6400,131 "2008-08-29 00:00",30631,2351,0,264,840,3455,6413,132 "2008-08-30 00:00",30650,2352,0,263,840,3455,6435,132 "2008-08-31 00:00",30668,2352,0,262,841,3455,6473,132 "2008-09-01 00:00",30680,2389,0,269,850,3508,6473,140 "2008-09-02 00:00",30694,2383,13,269,859,3524,6519,141 "2008-09-03 00:00",30717,2620,49,273,930,3872,6888,150 "2008-09-04 00:00",30745,2707,0,275,945,3927,7066,153 "2008-09-05 00:00",30771,3129,0,386,1278,4793,7246,157 "2008-09-06 00:00",30806,2798,0,281,976,4055,8002,156 "2008-09-07 00:00",30848,3287,0,285,1246,4818,8002,158 "2008-09-08 00:00",30881,3288,0,284,1246,4818,8003,158 "2008-09-09 00:00",30915,3288,0,284,1246,4818,8003,158 "2008-09-10 00:00",30946,3288,0,284,1246,4818,8071,158 "2008-09-11 00:00",30979,3296,0,296,1267,4859,8164,159 "2008-09-12 00:00",31010,3310,0,289,1272,4871,8237,159 "2008-09-13 00:00",31050,3332,4,292,1278,4906,8237,161 "2008-09-14 00:00",31098,3332,4,292,1278,4906,8237,161 "2008-09-15 00:00",31140,3361,0,293,1382,5036,8243,162 "2008-09-16 00:00",31173,3370,0,296,1385,5051,8245,163 "2008-09-17 00:00",31198,3377,0,296,1403,5076,8251,165 "2008-09-18 00:00",31220,3380,4,295,1403,5082,8257,165 "2008-09-19 00:00",31249,3399,0,282,1403,5084,8259,166 "2008-09-20 00:00",31282,3399,0,317,1368,5084,8259,166 "2008-09-21 00:00",31292,3418,0,306,1378,5102,8277,167 "2008-09-22 00:00",31329,3418,0,306,1378,5102,8277,167 "2008-09-23 00:00",31355,3434,0,306,1374,5114,8289,167 "2008-09-24 00:00",31376,3779,0,326,1401,5506,8296,177 "2008-09-25 00:00",31400,3815,0,328,1450,5593,8309,179 "2008-09-26 00:00",31428,3897,0,332,1457,5686,8393,180 "2008-09-27 00:00",31451,4090,0,379,1470,5939,8495,187 "2008-09-28 00:00",31470,4121,0,388,1477,5986,8505,188 "2008-09-29 00:00",31485,4121,0,392,1477,5990,8509,188 "2008-09-30 00:00",31503,4381,0,388,1453,6222,8743,193 "2008-10-01 00:00",31537,4381,7,388,1453,6229,8743,194 "2008-10-02 00:00",31561,4406,0,390,1460,6256,8779,198 "2008-10-03 00:00",31578,4437,0,394,1464,6295,8773,200 "2008-10-04 00:00",31609,4437,0,394,1466,6297,8775,200 "2008-10-05 00:00",31645,4437,0,394,1466,6297,8775,200 "2008-10-06 00:00",31687,4363,74,397,1436,6270,8826,205 "2008-10-07 00:00",31743,4363,74,397,1436,6270,8850,205 "2008-10-08 00:00",31780,4363,74,397,1436,6270,8850,205 "2008-10-09 00:00",31813,4366,11,398,1499,6274,8861,205 "2008-10-10 00:00",31846,4373,0,397,1495,6265,8871,204 "2008-10-11 00:00",31875,4366,0,396,1494,6256,8871,203 "2008-10-12 00:00",31893,4370,0,396,1494,6260,8877,203 "2008-10-13 00:00",31918,4380,0,396,1492,6268,8884,204 "2008-10-14 00:00",31932,4380,0,396,1492,6268,8884,204 "2008-10-15 00:00",31968,4390,0,398,1488,6276,8892,204 "2008-10-16 00:00",31992,4409,0,393,1488,6290,8909,204 "2008-10-17 00:00",32000,4409,0,393,1488,6290,8910,204 "2008-10-18 00:00",32008,4409,0,393,1488,6290,8910,204 "2008-10-19 00:00",32032,4409,0,393,1488,6290,8910,204 "2008-10-20 00:00",32045,4409,0,393,1488,6290,8910,204 "2008-10-21 00:00",32065,4413,0,393,1490,6296,8916,204 "2008-10-22 00:00",32096,4413,0,393,1490,6296,8916,204 "2008-10-23 00:00",32122,4429,0,394,1494,6317,8937,206 "2008-10-24 00:00",32144,4429,0,394,1494,6317,8937,206 "2008-10-25 00:00",32151,4429,0,394,1494,6317,8937,206 "2008-10-26 00:00",32162,4429,0,394,1494,6317,8956,206 "2008-10-27 00:00",32192,4429,2,394,1494,6319,8958,206 "2008-10-28 00:00",32211,4433,2,392,1492,6319,8958,206 "2008-10-29 00:00",32225,4433,2,392,1492,6319,8958,206 "2008-10-30 00:00",32239,4433,0,392,1494,6319,8958,206 "2008-10-31 00:00",32245,4435,0,392,1492,6319,8958,206 "2008-11-01 00:00",32261,4435,0,392,1492,6319,8958,206 "2008-11-02 00:00",32278,4435,0,392,1492,6319,8958,206 "2008-11-03 00:00",32312,4440,0,392,1487,6319,8958,206 "2008-11-04 00:00",32324,4436,5,392,1487,6320,8959,206 "2008-11-05 00:00",32357,4472,10,392,1500,6374,8989,211 "2008-11-06 00:00",32372,4409,0,396,1509,6314,8992,211 "2008-11-07 00:00",32415,4413,0,405,1496,6314,8993,211 "2008-11-08 00:00",32444,4439,4,407,1494,6344,8995,210 "2008-11-09 00:00",32460,4458,7,398,1491,6354,9006,211 "2008-11-10 00:00",32478,4435,58,387,1430,6310,9032,211 "2008-11-11 00:00",32512,4199,473,389,1314,6375,9032,212 "2008-11-12 00:00",32568,4528,8,391,1481,6408,9035,216 "2008-11-13 00:00",32593,4590,0,398,1496,6484,9036,219 "2008-11-14 00:00",32632,4601,0,396,1490,6487,9039,220 "2008-11-15 00:00",32656,4601,0,396,1490,6487,9039,220 "2008-11-16 00:00",32686,4601,0,396,1490,6487,9039,220 "2008-11-17 00:00",32761,4506,41,386,1483,6416,9039,220 "2008-11-18 00:00",32796,4576,41,386,1485,6488,9040,220 "2008-11-19 00:00",32864,4578,41,386,1483,6488,9040,220 "2008-11-20 00:00",32924,4585,41,387,1483,6496,9048,221 "2008-11-21 00:00",32971,4585,41,387,1483,6496,9048,221 "2008-11-22 00:00",32998,4599,41,387,1489,6516,9055,222 "2008-11-23 00:00",33032,4594,41,383,1489,6507,9055,221 "2008-11-24 00:00",33130,4616,41,384,1494,6535,9075,224 "2008-11-25 00:00",33180,4616,41,384,1494,6535,9075,224 "2008-11-26 00:00",33212,4648,41,386,1481,6556,9096,225 "2008-11-27 00:00",33257,5,6347,0,0,6352,9105,227 "2008-11-28 00:00",33295,4634,89,382,1471,6576,9106,227 "2008-11-29 00:00",33322,4653,48,382,1476,6559,9106,227 "2008-11-30 00:00",33359,4653,48,382,1476,6559,9106,227 "2008-12-01 00:00",33411,4689,10,382,1482,6563,9110,227 "2008-12-02 00:00",33436,4689,10,382,1484,6565,9112,227 "2008-12-03 00:00",33449,4689,10,382,1484,6565,9112,227 "2008-12-04 00:00",33477,4703,0,384,1482,6569,9116,227 "2008-12-05 00:00",33499,4710,0,384,1483,6577,9121,228 "2008-12-06 00:00",33539,4708,0,370,1501,6579,9123,228 "2008-12-07 00:00",33590,4717,0,373,1506,6596,9140,231 "2008-12-08 00:00",33645,4779,0,385,1540,6704,9330,233 "2008-12-09 00:00",33696,4805,13,387,1580,6785,9341,236 "2008-12-10 00:00",33741,4884,0,350,1572,6806,9358,235 "2008-12-11 00:00",33793,4916,0,350,1561,6827,9325,235 "2008-12-12 00:00",33823,5004,1,401,1489,6895,9356,240 "2008-12-13 00:00",33823,5005,0,410,1480,6895,9356,240 "2008-12-14 00:00",33844,5005,0,410,1480,6895,9356,240 "2008-12-15 00:00",33898,5101,0,383,1485,6969,9435,249 "2008-12-16 00:00",33949,5139,0,357,1473,6969,9435,249 "2008-12-17 00:00",34009,5170,0,350,1462,6982,9448,250 "2008-12-18 00:00",34055,5213,0,350,1452,7015,9492,250 "2008-12-19 00:00",34059,5213,0,350,1452,7015,9497,250 "2008-12-20 00:00",34114,5228,0,351,1456,7035,9517,252 "2008-12-21 00:00",34185,5645,0,304,1538,7487,9578,261 "2008-12-22 00:00",34232,5790,0,304,1393,7487,9578,261 "2008-12-23 00:00",34267,5833,0,319,1435,7587,9742,264 "2008-12-24 00:00",34313,5837,0,316,1434,7587,9742,264 "2008-12-25 00:00",34346,5840,1,316,1431,7588,9744,264 "2008-12-26 00:00",34364,5880,1,326,1404,7611,9851,264 "2008-12-27 00:00",34407,5905,0,327,1379,7611,9851,264 "2008-12-28 00:00",34465,5913,0,324,1375,7612,9863,264 "2008-12-29 00:00",34549,5802,141,324,1345,7612,9863,264 "2008-12-30 00:00",34615,5912,0,324,1376,7612,9863,264 "2008-12-31 00:00",34686,5911,0,323,1378,7612,9863,264 "2009-01-01 00:00",34735,5911,0,323,1378,7612,9873,264 "2009-01-02 00:00",34787,5911,0,323,1378,7612,10783,264 "2009-01-03 00:00",34854,5911,0,323,1378,7612,10783,264 "2009-01-04 00:00",34911,5911,0,323,1378,7612,10786,264 "2009-01-05 00:00",34959,5914,0,323,1378,7615,10786,265 "2009-01-06 00:00",35013,6170,0,338,1414,7922,11248,279 "2009-01-07 00:00",35093,6171,0,343,1416,7930,11256,279 "2009-01-08 00:00",35189,6175,0,338,1417,7930,11256,279 "2009-01-09 00:00",35243,6172,0,337,1424,7933,11263,279 "2009-01-10 00:00",35329,6141,0,331,1479,7951,11287,279 "2009-01-11 00:00",35386,6143,0,331,1478,7952,11288,279 "2009-01-12 00:00",35432,6218,0,331,1425,7974,11470,281 "2009-01-13 00:00",35477,6233,0,333,1425,7991,11487,282 "2009-01-14 00:00",35517,6233,0,337,1425,7995,11491,282 "2009-01-15 00:00",35576,6254,0,337,1425,8016,11525,284 "2009-01-16 00:00",35615,6263,0,337,1444,8044,11525,285 "2009-01-17 00:00",35664,0,6288,337,1437,8062,11525,286 "2009-01-18 00:00",35708,5,7844,0,0,7849,11525,286 "2009-01-19 00:00",35736,6352,0,313,1458,8123,11542,290 "2009-01-20 00:00",35788,6280,171,297,1420,8167,11582,292 "2009-01-21 00:00",35851,0,8167,0,0,8167,11582,292 "2009-01-22 00:00",35875,6500,11,308,1420,8239,11651,294 "2009-01-23 00:00",35904,6523,0,310,1421,8254,11666,295 "2009-01-24 00:00",35944,6522,0,307,1435,8264,11676,295 "2009-01-25 00:00",35983,6383,180,292,1405,8260,11678,295 "2009-01-26 00:00",36017,6517,0,293,1450,8260,11682,295 "2009-01-27 00:00",36042,6546,0,301,1511,8358,14080,295 "2009-01-28 00:00",36078,6601,1,301,1541,8444,14174,298 "2009-01-29 00:00",36135,6609,0,298,1754,8661,14236,298 "2009-01-30 00:00",9f84067,6614,0,300,1780,8692,14267,298 "2009-01-31 00:00",9f84067,6595,21,300,1778,8692,14267,298 "2009-02-01 00:00",48b6102,6595,21,300,1945,8859,14434,298 "2009-02-02 00:00",21f374f,6609,30,300,1944,8881,14593,299 "2009-02-03 00:00",21f374f,6609,30,300,1944,8881,14593,299 "2009-02-04 00:00",c3705e4,6609,30,300,1944,8881,14593,299 "2009-02-05 00:00",c108072,6629,0,301,1948,8878,14586,300 "2009-02-06 00:00",f990451,6629,0,301,1948,8878,14586,300 "2009-02-07 00:00",f990451,6629,0,301,1948,8878,14586,300 "2009-02-08 00:00",13f6779,6632,0,301,1982,8915,14586,301 "2009-02-09 00:00",1b85e1d,6635,0,301,1982,8918,14589,301 "2009-02-10 00:00",1b85e1d,6635,0,301,1982,8918,14589,301 "2009-02-11 00:00",e73c958,6635,0,301,1982,8918,14589,301 "2009-02-12 00:00",b2e7ac9,6766,0,299,1972,9037,14712,302 "2009-02-13 00:00",b2e7ac9,6766,0,299,1972,9037,14712,302 "2009-02-14 00:00",a0a3902,6812,0,298,1970,9080,14746,303 "2009-02-15 00:00",2f489f2,6812,0,298,1970,9080,14807,303 "2009-02-16 00:00",beac378,6805,15,298,1969,9087,14812,305 "2009-02-17 00:00",8695e4b,6823,0,298,1971,9092,14826,305 "2009-02-18 00:00",842ef38,6815,17,302,1981,9112,14836,306 "2009-02-19 00:00",444a4c8,6843,1,301,1985,9130,14861,306 "2009-02-20 00:00",5423d30,6952,0,303,1988,9243,15188,313 "2009-02-21 00:00",f23eda2,6951,15,307,1977,9250,15188,314 "2009-02-22 00:00",f23eda2,6955,15,307,1977,9254,15192,314 "2009-02-23 00:00",2a9382c,6970,0,307,1977,9254,15192,314 "2009-02-24 00:00",e074bf4,6999,0,308,1987,9294,15232,314 "2009-02-25 00:00",5944501,7007,0,310,1985,9302,15240,314 "2009-02-26 00:00",e6b7133,7041,0,309,1962,9312,15250,314 "2009-02-27 00:00",08b7890,7037,48,311,1947,9343,15261,315 "2009-02-28 00:00",c1f3976,7084,0,315,1944,9343,15261,315 "2009-03-01 00:00",af4b730,7084,0,315,1944,9343,15261,315 "2009-03-02 00:00",0d369db,7087,0,315,1944,9346,15268,315 "2009-03-03 00:00",4ec17da,7087,0,315,1944,9346,15268,315 "2009-03-04 00:00",55fb203,5648,0,284,1444,7376,15268,315 "2009-03-05 00:00",412cbe9,7121,0,314,1932,9367,15289,317 "2009-03-06 00:00",e47c348,7121,0,314,1932,9367,15289,317 "2009-03-07 00:00",f6cdf9b,7121,0,315,1932,9368,15290,317 "2009-03-08 00:00",ed4cd14,7122,2,318,1931,9373,15295,317 "2009-03-09 00:00",8bbc31c,7124,0,318,1931,9373,15295,317 "2009-03-10 00:00",95ce390,7015,140,321,1922,9398,15320,317 "2009-03-11 00:00",0c893bc,7148,0,319,1931,9398,15320,317 "2009-03-12 00:00",ea32839,7153,0,319,1926,9398,15320,317 "2009-03-13 00:00",087e299,7152,2,319,1935,9408,15330,317 "2009-03-14 00:00",41267fd,7166,0,319,1934,9419,15341,317 "2009-03-15 00:00",5b1ff9c,7174,0,315,1932,9421,15341,319 "2009-03-16 00:00",d2ad095,7174,0,316,1931,9421,15343,319 "2009-03-17 00:00",84920ea,7174,0,316,1934,9424,15346,319 "2009-03-18 00:00",521a5f1,7245,0,316,1919,9480,15356,321 "2009-03-19 00:00",f8b6aee,7255,0,318,1922,9495,15356,324 "2009-03-20 00:00",44e1496,7271,0,319,1926,9516,15382,325 "2009-03-21 00:00",627b6d6,7280,0,319,1942,9541,15407,325 "2009-03-22 00:00",de786f3,7280,0,319,1942,9541,15407,325 "2009-03-23 00:00",1c263b0,7308,1,324,1944,9577,15471,327 "2009-03-24 00:00",7487710,7322,1,324,1947,9594,15479,328 "2009-03-25 00:00",9a84c35,7367,0,324,1947,9638,15479,329 "2009-03-26 00:00",bb22e02,7424,0,325,1958,9707,15518,332 "2009-03-27 00:00",4929856,7795,0,326,2077,10198,15518,339 "2009-03-28 00:00",9fa0fca,7804,0,332,2062,10198,15518,339 "2009-03-29 00:00",7af829f,7804,0,332,2062,10198,15518,339 "2009-03-30 00:00",370dd76,8039,0,340,1819,10198,15518,339 "2009-03-31 00:00",c015556,8039,0,340,1819,10198,15518,339 "2009-04-01 00:00",78cb4c3,8049,0,342,1819,10210,15518,340 "2009-04-02 00:00",64e33af,8049,0,342,1819,10210,15518,340 "2009-04-03 00:00",913094f,8081,0,342,1816,10239,15534,344 "2009-04-04 00:00",68ea385,8406,0,342,1964,10712,15534,347 "2009-04-05 00:00",7dc65fd,8436,0,340,1960,10736,15579,349 "2009-04-06 00:00",078012a,8436,0,340,1960,10736,15579,349 "2009-04-07 00:00",8f4dc52,8436,0,340,1960,10736,15579,349 "2009-04-08 00:00",a2728b4,8444,0,342,1960,10746,15589,349 "2009-04-09 00:00",4ae560c,10224,0,343,2050,12617,15627,354 "2009-04-10 00:00",70fc009,10284,0,344,2052,12680,15633,356 "2009-04-11 00:00",79aba97,10300,0,346,2074,12720,15676,359 "2009-04-12 00:00",5b679a9,10298,5,346,2074,12723,15679,359 "2009-04-13 00:00",679e480,10298,5,346,2074,12723,15679,359 "2009-04-14 00:00",2c13d6c,10298,5,346,2074,12723,15679,359 "2009-04-15 00:00",d208e1c,10357,0,347,2148,12852,15801,362 "2009-04-16 00:00",a4535c1,10357,0,347,2148,12852,15801,362 "2009-04-17 00:00",a4535c1,10357,0,347,2148,12852,15801,362 "2009-04-18 00:00",f2c5829,10414,0,354,2153,12921,15860,371 "2009-04-19 00:00",d0310a3,10430,0,355,2151,12936,15866,372 "2009-04-20 00:00",0d55159,10381,0,360,2144,12885,15887,372 "2009-04-21 00:00",cea34fd,10389,0,359,2136,12884,15886,373 "2009-04-22 00:00",2665575,10467,0,358,2131,12956,15886,374 "2009-04-23 00:00",d79ccbe,10467,0,358,2133,12958,15888,374 "2009-04-24 00:00",9a53051,10907,0,353,2138,13398,16298,375 "2009-04-25 00:00",7bbc62a,10922,0,353,2136,13411,16311,376 "2009-04-26 00:00",705ecc2,10922,0,353,2136,13411,16311,376 "2009-04-27 00:00",c4f6763,10927,0,353,2137,13417,16317,376 "2009-04-28 00:00",467ade5,10931,0,363,2136,13430,16332,376 "2009-04-29 00:00",c76d8d0,10943,0,367,2146,13456,16343,377 "2009-04-30 00:00",96de998,10961,0,367,2145,13473,16364,378 "2009-05-01 00:00",b83a0b0,10958,0,367,2145,13470,16363,377 "2009-05-02 00:00",ec69e24,10991,0,364,2191,13546,16372,378 "2009-05-03 00:00",d4a0b3b,10984,7,364,2191,13546,16416,378 "2009-05-04 00:00",cddb162,10999,11,365,2190,13565,16487,379 "2009-05-05 00:00",4d7fe56,11011,0,364,2190,13565,16490,379 "2009-05-06 00:00",71c69d0,11013,0,364,2191,13568,16490,380 "2009-05-07 00:00",615936e,11022,0,365,2195,13582,16492,382 "2009-05-08 00:00",6db88b0,11032,0,365,2195,13592,16495,383 "2009-05-09 00:00",1f4ec5d,11028,66,360,2142,13596,16519,383 "2009-05-10 00:00",7d581a5,11085,1,362,2182,13630,16553,383 "2009-05-11 00:00",a27bbb6,11180,0,386,2213,13779,16562,387 "2009-05-12 00:00",feca3f2,11187,0,390,2213,13790,16573,387 "2009-05-13 00:00",3412a2f,11257,0,387,2182,13826,16581,388 "2009-05-14 00:00",8349d75,11258,1,387,2183,13829,16584,388 "2009-05-15 00:00",8ff0e0a,11291,0,390,2194,13875,16595,390 "2009-05-16 00:00",ec55f17,11288,8,389,2196,13881,16601,390 "2009-05-17 00:00",ec55f17,11288,8,389,2196,13881,16601,390 "2009-05-18 00:00",1639d85,11294,0,389,2199,13882,16603,390 "2009-05-19 00:00",9d2934e,11297,0,389,2199,13885,16603,391 "2009-05-20 00:00",595d364,11299,0,389,2199,13887,16623,391 "2009-05-21 00:00",f08f5ad,11342,0,390,2176,13908,16644,392 "2009-05-22 00:00",5eac9bd,11342,0,390,2176,13908,16644,392 "2009-05-23 00:00",23718a8,11342,0,390,2176,13908,16684,392 "2009-05-24 00:00",23718a8,11338,0,395,2175,13908,16684,392 "2009-05-25 00:00",23718a8,11337,0,395,2175,13907,16683,392 "2009-05-26 00:00",2376c44,11343,0,397,2178,13918,16685,394 "2009-05-27 00:00",6953001,11346,0,397,2178,13921,16685,395 "2009-05-28 00:00",b325177,11346,0,397,2178,13921,16685,395 "2009-05-29 00:00",6062528,11350,0,393,2178,13921,16685,395 "2009-05-30 00:00",764684b,11350,0,393,2178,13921,16685,395 "2009-05-31 00:00",764684b,11350,0,393,2178,13921,16685,395 "2009-06-01 00:00",0b9c9a3,11350,0,392,2180,13922,16686,395 "2009-06-02 00:00",d396ab4,11346,2,392,2182,13922,16686,395 "2009-06-03 00:00",c907d37,11348,2,392,2180,13922,16683,395 "2009-06-04 00:00",77db80c,11379,2,389,2190,13960,16683,399 "2009-06-05 00:00",10a9b23,11380,2,389,2190,13961,16684,399 "2009-06-06 00:00",fb2fd43,11391,2,389,2190,13972,16696,399 "2009-06-07 00:00",97f1415,11391,2,389,2190,13972,16696,399 "2009-06-08 00:00",5f70a68,11428,0,380,2165,13973,16697,399 "2009-06-09 00:00",063f3d5,11475,0,380,2165,14020,16744,400 "2009-06-10 00:00",86aeafb,11508,0,380,2168,14056,16838,401 "2009-06-11 00:00",86aeafb,11508,0,380,2168,14056,16838,401 "2009-06-12 00:00",a2b8ceb,11508,0,380,2168,14056,16841,401 "2009-06-13 00:00",4d21e2a,11514,0,380,2174,14068,16853,401 "2009-06-14 00:00",77f9d70,11535,0,382,2182,14099,16867,404 "2009-06-15 00:00",77f9d70,11535,0,382,2182,14099,16867,404 "2009-06-16 00:00",ba09b27,11535,0,382,2182,14099,16867,404 "2009-06-17 00:00",952fe6d,11536,0,381,2183,14100,16874,404 "2009-06-18 00:00",9dc941f,11536,0,381,2183,14100,16888,404 "2009-06-19 00:00",1b06df8,11536,0,381,2183,14100,16888,404 "2009-06-20 00:00",1b06df8,11488,48,381,2183,14100,16888,404 "2009-06-21 00:00",1b06df8,11488,48,381,2183,14100,16888,404 "2009-06-22 00:00",1b06df8,11532,4,381,2183,14100,16891,404 "2009-06-23 00:00",10f2235,11532,4,383,2184,14103,16894,404 "2009-06-24 00:00",0e0671a,11546,4,383,2184,14117,16908,405 "2009-06-25 00:00",0e0671a,11548,4,383,2183,14118,16909,405 "2009-06-26 00:00",6c43f93,11539,21,380,2218,14158,16921,406 "2009-06-27 00:00",6c43f93,11548,9,384,2218,14159,16925,406 "2009-06-28 00:00",6c43f93,11526,17,384,2221,14148,17010,406 "2009-06-29 00:00",6c43f93,11536,7,384,2221,14148,17010,406 "2009-06-30 00:00",1831bd1,11510,85,388,2223,14206,17026,409 "2009-07-01 00:00",5351a33,11592,52,384,2219,14245,17059,412 "2009-07-02 00:00",3d94ef4,11629,6,388,2226,14249,17063,412 "2009-07-03 00:00",f59630e,11546,90,387,2218,14241,17056,412 "2009-07-04 00:00",6a4d66a,11566,99,397,2216,14278,17067,412 "2009-07-05 00:00",6a4d66a,11577,85,400,2226,14288,17082,412 "2009-07-06 00:00",0e8a86a,11585,112,388,2175,14260,17136,411 "2009-07-07 00:00",99ad1eb,11497,125,403,2183,14208,17178,411 "2009-07-08 00:00",70bfd5c,11561,195,398,2195,14349,17197,412 "2009-07-09 00:00",70bfd5c,11577,195,403,2198,14373,17222,412 "2009-07-10 00:00",544038f,11748,0,410,2215,14373,17222,412 "2009-07-11 00:00",02d0ed2,11746,2,410,2215,14373,17224,412 "2009-07-12 00:00",02d0ed2,11750,2,415,2215,14382,17236,412 "2009-07-13 00:00",4024702,11796,0,420,2227,14443,17264,415 "2009-07-14 00:00",147b3d7,11784,0,426,2226,14436,17315,415 "2009-07-15 00:00",d8d0640,11787,3,430,2229,14447,17326,415 "2009-07-16 00:00",9a7a1dc,11792,2,430,2225,14449,17328,415 "2009-07-17 00:00",9a7a1dc,11802,2,441,2228,14473,17358,415 "2009-07-18 00:00",faf91f9,11813,3,442,2228,14486,17371,415 "2009-07-19 00:00",faf91f9,11815,1,442,2228,14486,17371,415 "2009-07-20 00:00",415514b,11835,1,461,2231,14528,17411,415 "2009-07-21 00:00",b756ac9,11854,0,473,2245,14572,17455,416 "2009-07-22 00:00",21066f1,11343,651,473,2101,14568,17453,416 "2009-07-23 00:00",6062092,11876,0,461,2238,14575,17460,416 "2009-07-24 00:00",fc60e1d,11913,0,462,2236,14611,17496,418 "2009-07-25 00:00",dd5767c,12006,0,537,2242,14785,17511,423 "2009-07-26 00:00",240b984,12027,0,543,2244,14814,17540,423 "2009-07-27 00:00",4c31fb7,12043,0,543,2244,14830,17556,423 "2009-07-28 00:00",ea667e8,12033,14,540,2248,14835,17556,423 "2009-07-29 00:00",6999e58,12048,8,541,2253,14850,17571,423 "2009-07-30 00:00",13ba2f3,12114,8,502,2210,14834,17583,423 "2009-07-31 00:00",a53a1cd,12124,8,511,2210,14853,17602,424 "2009-08-01 00:00",e02bc06,12124,8,512,2214,14858,17609,424 "2009-08-02 00:00",e02bc06,12126,13,512,2214,14865,17616,424 "2009-08-03 00:00",91408af,12179,8,520,2226,14933,17588,426 "2009-08-04 00:00",18598de,12179,8,520,2226,14933,17588,426 "2009-08-05 00:00",24b26a0,12185,8,524,2227,14944,17599,426 "2009-08-06 00:00",a948cae,12189,8,528,2227,14952,17607,426 "2009-08-07 00:00",4665d75,12156,65,528,2206,14955,17610,426 "2009-08-08 00:00",7717c4a,12193,16,531,2221,14961,17622,426 "2009-08-09 00:00",5667dca,12247,0,529,2286,15062,17595,429 "2009-08-10 00:00",39cc848,12303,0,530,2286,15119,17611,430 "2009-08-11 00:00",11a2934,12301,0,533,2259,15093,17625,429 "2009-08-12 00:00",a5dfe96,12303,0,535,2260,15098,17636,428 "2009-08-13 00:00",69eee0d,12308,0,538,2263,15109,17647,428 "2009-08-14 00:00",0d4fe08,12294,0,525,2268,15087,17619,428 "2009-08-15 00:00",637d803,12298,21,522,2262,15103,17632,429 "2009-08-16 00:00",ada2b41,12326,0,526,2267,15119,17650,429 "2009-08-17 00:00",5637208,12326,0,526,2267,15119,17665,429 "2009-08-18 00:00",55c5fa1,12339,1,524,2265,15129,17675,430 "2009-08-19 00:00",b9c79c2,12339,0,523,2267,15129,17675,430 "2009-08-20 00:00",fd8fc8a,12371,0,516,2263,15150,17682,431 "2009-08-21 00:00",ae56d02,12376,0,516,2263,15155,18193,431 "2009-08-22 00:00",0a5b07e,12397,0,514,2263,15174,18204,433 "2009-08-23 00:00",e83932a,12397,0,514,2263,15174,18204,433 "2009-08-24 00:00",c4c67da,12399,0,514,2266,15179,18209,433 "2009-08-25 00:00",9d9d416,12401,0,514,2264,15179,18209,433 "2009-08-26 00:00",bd51ce2,12402,0,513,2267,15182,18212,433 "2009-08-27 00:00",ec2f831,12402,0,513,2267,15182,18212,433 "2009-08-28 00:00",f351f60,12391,0,517,2274,15182,18212,433 "2009-08-29 00:00",7666e92,12393,0,516,2273,15182,18241,433 "2009-08-30 00:00",7666e92,12465,0,520,2274,15259,18289,433 "2009-08-31 00:00",8772e90,12478,0,517,2274,15269,18299,433 "2009-09-01 00:00",9bcba63,12550,0,520,2381,15451,18481,435 "2009-09-02 00:00",ba10463,13245,0,521,2414,16180,19210,435 "2009-09-03 00:00",c9a9300,13257,0,521,2414,16192,19222,435 "2009-09-04 00:00",b51d94c,13402,0,521,2446,16369,19399,435 "2009-09-05 00:00",2276af9,13401,2,521,2445,16369,19399,435 "2009-09-06 00:00",6e2104a,13404,0,518,2447,16369,19403,435 "2009-09-07 00:00",205733f,14255,0,518,2783,17556,20590,435 "2009-09-08 00:00",01ae3fa,14273,0,518,2783,17574,20599,436 "2009-09-09 00:00",62879bb,14268,0,521,2785,17574,20599,436 "2009-09-10 00:00",5960161,14272,0,521,2785,17578,20603,436 "2009-09-11 00:00",d0355a5,14267,5,521,2785,17578,20603,436 "2009-09-12 00:00",3b63817,14835,0,521,2832,18188,21213,436 "2009-09-13 00:00",0f1edeb,15494,0,521,2657,18672,21697,436 "2009-09-14 00:00",0f1edeb,15500,0,523,2659,18682,21679,436 "2009-09-15 00:00",a9ff309,15500,0,523,2659,18682,21679,436 "2009-09-16 00:00",9a61441,15497,0,518,2651,18666,21671,436 "2009-09-17 00:00",ea6448f,15497,0,518,2651,18666,21671,436 "2009-09-18 00:00",a969c9e,15498,0,520,2651,18669,21674,436 "2009-09-19 00:00",4b141a8,15498,0,520,2651,18669,21674,436 "2009-09-20 00:00",2c40a5b,15498,0,521,2651,18670,21695,436 "2009-09-21 00:00",2c40a5b,15498,0,521,2651,18670,21695,436 "2009-09-22 00:00",5d3d3a3,15498,0,521,2651,18670,21695,436 "2009-09-23 00:00",0220cc2,15506,0,521,2658,18685,21710,436 "2009-09-24 00:00",e9a7966,15506,0,521,2658,18685,21710,436 "2009-09-25 00:00",729722a,15515,0,521,2651,18687,21712,436 "2009-09-26 00:00",729722a,15515,0,521,2651,18687,21712,436 "2009-09-27 00:00",834929c,15518,0,525,2651,18694,21719,436 "2009-09-28 00:00",0331d60,15513,0,520,2648,18681,21729,436 "2009-09-29 00:00",0331d60,15512,0,520,2650,18682,21730,436 "2009-09-30 00:00",2d34081,12778,98,520,2134,15404,18458,436 "2009-10-01 00:00",ffe6481,15956,0,520,2650,19126,22180,436 "2009-10-02 00:00",f52e459,15966,0,515,2660,19141,22195,436 "2009-10-03 00:00",e976f23,27697,0,515,6847,35059,38113,449 "2009-10-04 00:00",e976f23,26949,1,515,6847,34309,37363,449 "2009-10-05 00:00",1ca164a,27717,2,514,6838,35071,38088,449 "2009-10-06 00:00",d91717d,27720,0,517,6839,35076,38093,449 "2009-10-07 00:00",8d63378,27718,2,517,6839,35076,38093,449 "2009-10-08 00:00",30e2cfd,27719,0,515,6841,35075,38092,449 "2009-10-09 00:00",daf221d,27719,0,515,6841,35075,38092,449 "2009-10-10 00:00",1b83557,27754,0,521,6846,35121,38138,450 "2009-10-11 00:00",7ec926f,27776,0,518,6847,35141,38158,450 "2009-10-12 00:00",d749d9b,27835,0,521,6868,35224,38211,452 "2009-10-13 00:00",d749d9b,27836,0,521,6867,35224,38211,452 "2009-10-14 00:00",54cfe42,27840,0,520,6874,35234,38221,452 "2009-10-15 00:00",3eceb87,27842,0,521,6876,35239,38226,452 "2009-10-16 00:00",d5a2ee9,27804,0,521,6876,35201,38188,452 "2009-10-17 00:00",d5a2ee9,27804,0,521,6876,35201,38188,452 "2009-10-18 00:00",dc9e98e,0,27804,521,6876,35201,38188,452 "2009-10-19 00:00",827734a,27879,0,523,6902,35304,38291,452 "2009-10-20 00:00",9d76f3b,32365,83,523,2333,35304,38291,452 "2009-10-21 00:00",db1e525,32568,104,485,2140,35297,38284,453 "2009-10-22 00:00",0e662a7,32614,83,491,2151,35339,38326,453 "2009-10-23 00:00",49e62fa,32616,83,493,2156,35348,38335,454 "2009-10-24 00:00",501b4fb,32618,83,493,2157,35351,38335,454 "2009-10-25 00:00",501b4fb,32621,83,494,2160,35358,38342,454 "2009-10-26 00:00",6817b90,32621,83,494,2164,35362,38337,454 "2009-10-26 00:00",571425b,0,32621,494,2164,35362,38337,454 "2009-10-28 00:00",e8cac16,32714,7,496,2188,35405,38373,454 "2009-10-29 00:00",8cf27e5,32721,7,500,2192,35420,38388,454 "2009-10-30 00:00",4320479,31697,17,499,2187,34175,37143,454 "2009-10-31 00:00",d154eb9,32729,7,499,2187,35422,38390,454 "2009-11-01 00:00",d154eb9,32701,37,499,2187,35424,38392,454 "2009-11-02 00:00",33111d4,32609,120,498,2161,35388,38356,452 "2009-11-03 00:00",74f561e,32609,117,498,2164,35388,38356,452 "2009-11-04 00:00",16eab0f,32613,117,498,2164,35392,38360,452 "2009-11-05 00:00",5e05b88,32685,7,516,2196,35404,38372,451 "2009-11-06 00:00",5e05b88,32685,7,516,2196,35404,38372,451 "2009-11-07 00:00",fe6dd27,32688,7,513,2196,35404,38372,451 "2009-11-08 00:00",37d480a,32677,13,512,2196,35398,38374,451 "2009-11-09 00:00",929998c,32696,5,514,2196,35411,38379,451 "2009-11-10 00:00",929998c,32696,15,516,2196,35423,38389,451 "2009-11-11 00:00",f16c9e2,32705,6,516,2196,35423,38389,451 "2009-11-12 00:00",f87efac,31444,11,525,2197,33683,36618,453 "2009-11-13 00:00",d04cce9,32734,8,525,2198,35465,38400,453 "2009-11-14 00:00",d04cce9,32737,8,532,2201,35478,38378,453 "2009-11-15 00:00",7347ec0,32738,8,532,2201,35479,38379,453 "2009-11-16 00:00",7347ec0,32737,10,534,2204,35485,38380,453 "2009-11-17 00:00",d3a573b,32742,6,534,2206,35407,38302,453 "2009-11-18 00:00",68d5c37,32742,6,534,2206,35407,38302,453 "2009-11-19 00:00",c00de9d,32753,5,537,2209,35423,38318,453 "2009-11-20 00:00",f5065b6,32723,16,534,2194,35467,38367,453 "2009-11-21 00:00",6bf0179,32769,16,538,2214,35537,38538,453 "2009-11-22 00:00",6bf0179,32769,16,538,2214,35537,38538,453 "2009-11-23 00:00",6bf0179,32759,16,540,2222,35537,38538,453 "2009-11-24 00:00",0a61bee,32794,8,542,2222,35563,38564,453 "2009-11-25 00:00",0a61bee,32771,31,542,2222,35563,38564,453 "2009-11-26 00:00",f151334,32540,134,531,2184,35262,38263,453 "2009-11-27 00:00",f151334,32540,134,531,2185,35263,38264,453 "2009-11-28 00:00",2b93c78,32557,134,537,2185,35286,38287,453 "2009-11-29 00:00",7ce13d8,32538,0,528,2216,35295,38296,453 "2009-11-30 00:00",7ce13d8,32536,0,528,2218,35295,38296,453 "2009-12-01 00:00",ef9c024,32536,0,528,2218,35295,38296,453 "2009-12-02 00:00",ef9c024,32536,0,528,2218,35295,38296,453 "2009-12-03 00:00",7914ca3,32536,0,528,2218,35295,38296,453 "2009-12-04 00:00",7ef3861,32509,0,528,2218,35298,38299,453 "2009-12-05 00:00",7ef3861,32539,0,527,2218,35298,38299,453 "2009-12-06 00:00",7ef3861,32539,0,527,2218,35298,38299,453 "2009-12-07 00:00",7ef3861,32406,0,527,2208,35160,38161,453 "2009-12-08 00:00",7ef3861,32270,0,545,2009,35166,38167,453 "2009-12-09 00:00",7ef3861,32259,0,546,2021,35171,38172,453 "2009-12-10 00:00",7ef3861,32259,0,546,2021,35171,38172,453 "2009-12-11 00:00",7ef3861,32258,0,546,2021,35171,38172,453 "2009-12-12 00:00",7ef3861,32255,0,545,2025,35172,38173,453 "2009-12-13 00:00",7ef3861,32255,0,543,2027,35172,38173,453 "2009-12-14 00:00",7ef3861,32255,0,543,2027,35172,38173,453 "2009-12-15 00:00",7ef3861,32225,0,543,2027,35172,38173,453 "2009-12-16 00:00",55f51dc,32255,0,543,2027,35172,38173,453 "2009-12-17 00:00",2198ecc,32192,0,543,2021,34311,37376,449 "2009-12-18 00:00",7f1c3fe,32084,0,541,2009,34237,37313,448 "2009-12-19 00:00",7f1c3fe,32080,0,541,2006,34237,37313,448 "2009-12-20 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-21 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-22 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-23 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-24 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-25 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-26 00:00",8dc1895,32080,0,541,2006,34237,37313,448 "2009-12-27 00:00",8dc1895,32075,0,541,2002,34245,37321,448 "2009-12-28 00:00",77bf8cf,32075,0,541,2002,34245,37321,448 "2009-12-29 00:00",77bf8cf,32045,0,545,2004,34221,37297,448 "2009-12-30 00:00",db84bc0,32045,0,548,2004,34224,37300,448 "2009-12-31 00:00",db84bc0,32045,0,548,2004,34224,37300,448 "2010-01-01 00:00",db84bc0,32041,0,547,2005,34224,37300,448 "2010-01-02 00:00",db84bc0,32041,0,547,2005,34224,37300,448 "2010-01-03 00:00",db84bc0,32041,0,547,2005,34224,37300,448 "2010-01-04 00:00",db84bc0,32041,0,547,2005,34224,37300,448 "2010-01-05 00:00",3867ffd,32038,0,546,2001,34216,37292,448 "2010-01-06 00:00",3867ffd,32038,0,546,2001,34216,37292,448 "2010-01-07 00:00",3867ffd,32038,0,546,2001,34216,37292,448 "2010-01-08 00:00",3867ffd,32038,0,546,2001,34216,37292,448 "2010-01-09 00:00",3867ffd,32012,0,545,1984,34172,37248,448 "2010-01-10 00:00",3867ffd,32012,0,545,1984,34172,37248,448 "2010-01-11 00:00",3867ffd,32007,0,544,1990,34172,37248,448 "2010-01-12 00:00",3867ffd,32007,0,544,1997,34176,37252,448 "2010-01-13 00:00",3867ffd,32007,0,544,1997,34176,37252,448 "2010-01-14 00:00",3867ffd,32007,0,544,1997,34176,37252,448 "2010-01-15 00:00",3867ffd,32007,0,544,1997,34176,37252,448 "2010-01-16 00:00",3867ffd,31958,0,544,1999,34179,37255,447 "2010-01-17 00:00",3867ffd,31958,0,544,1999,34179,37255,447 "2010-01-18 00:00",726b83a,31958,0,544,1999,34179,37255,447 "2010-01-19 00:00",726b83a,31958,0,544,1999,34179,37255,447 "2010-01-20 00:00",726b83a,31957,0,545,1999,34179,37268,447 "2010-01-21 00:00",1d49284,31957,0,545,1999,34179,37268,447 "2010-01-22 00:00",1d49284,31957,0,545,1999,34179,37268,447 "2010-01-24 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-25 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-26 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-27 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-28 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-29 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-30 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-01-31 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-02-01 00:00",a609d77,32731,0,542,2216,35489,38554,449 "2010-02-02 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-03 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-04 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-05 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-06 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-07 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-08 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-09 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-10 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-11 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-12 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-13 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-14 00:00",30e0ed3,32731,0,542,2216,35489,38554,449 "2010-02-15 00:00",70667a0,4051,0,58,336,4445,16418,139 "2010-02-16 00:00",65e2d3d,4085,0,58,336,4479,16428,140 "2010-02-17 00:00",6c478f2,4816,1,129,279,5225,16525,172 "2010-02-18 00:00",b4824f3,24167,0,131,301,24599,35727,194 "2010-02-19 00:00",8fdc942,24221,0,131,301,24653,35730,195 "2010-02-20 00:00",71d8848,24223,0,129,301,24653,35730,195 "2010-02-21 00:00",e904536,23424,20,122,296,23862,34939,195 "2010-02-22 00:00",14f803a,23424,20,122,296,23862,34872,195 "2010-02-23 00:00",d6129bc,24265,0,130,317,24712,35680,197 "2010-02-24 00:00",4f74e3b,24309,0,128,319,24756,35677,200 "2010-02-25 00:00",88f57f6,24339,0,128,331,24798,35695,204 "2010-02-26 00:00",403afe0,24575,1,139,426,25141,35754,215 "2010-02-27 00:00",c83cf2a,24645,0,139,422,25206,35748,216 "2010-02-28 00:00",8ffb7ea,24884,2,151,469,25506,35854,225 "2010-03-01 00:00",588a345,23508,0,162,500,24072,34217,231 "2010-03-02 00:00",5e5969d,25342,0,181,522,26045,35961,240 "2010-03-03 00:00",efb2ccd,25346,0,183,522,26051,35967,240 "2010-03-04 00:00",cee8058,25346,2,181,522,26051,35973,240 "2010-03-05 00:00",2d9808d,25354,1,182,522,26059,35975,241 "2010-03-06 00:00",974d9a8,25404,0,187,532,26091,35978,243 "2010-03-07 00:00",54be6dd,25678,1,201,526,26406,36153,256 "2010-03-08 00:00",f56934d,26687,0,262,789,27738,37279,272 "2010-03-09 00:00",0162536,26860,0,264,814,27938,37320,279 "2010-03-10 00:00",88032ee,27015,0,271,946,28232,37601,287 "2010-03-11 00:00",e634b58,27019,0,271,944,28234,37603,287 "2010-03-12 00:00",3f6af6a,27155,0,286,986,28427,37730,293 "2010-03-13 00:00",41506d4,27256,0,301,1036,28593,37739,302 "2010-03-14 00:00",fefb298,27412,0,308,1076,28796,37867,310 "2010-03-15 00:00",c29d389,27562,0,319,1190,29071,37963,318 "2010-03-16 00:00",f676705,25945,1,316,1197,27404,36272,322 "2010-03-17 00:00",e3937f7,27628,0,319,1205,29152,38020,322 "2010-03-18 00:00",2abcdcd,27764,1,340,1190,29295,38109,332 "2010-03-19 00:00",1e9aa08,27767,0,334,1170,29271,38079,333 "2010-03-20 00:00",a6e9e13,28068,0,356,1174,29598,38075,336 "2010-03-21 00:00",6be8f8c,28312,1,368,1200,29881,38165,338 "2010-03-22 00:00",265726d,28428,2,369,1214,30013,38190,343 "2010-03-23 00:00",eae8b29,28474,2,374,1250,30100,38271,348 "2010-03-24 00:00",d0bf6e3,28549,2,375,1218,30144,38280,354 "2010-03-25 00:00",626ee20,28553,0,375,1218,30146,38286,354 "2010-03-26 00:00",b2f995a,28730,0,415,1304,30449,38287,359 "2010-03-27 00:00",cddc8a7,28730,0,415,1298,30443,38281,359 "2010-03-28 00:00",cddc8a7,28730,0,415,1298,30443,38281,359 "2010-03-29 00:00",534afd8,28765,0,429,1309,30503,38307,361 "2010-03-30 00:00",534afd8,28765,0,429,1309,30503,38307,361 "2010-03-31 00:00",8ba6030,28799,1,430,1362,30592,38396,362 "2010-04-01 00:00",7d00af1,28872,1,438,1401,30712,38488,366 "2010-04-02 00:00",63ff066,28928,1,435,1378,30742,38494,369 "2010-04-03 00:00",e50ff8c,30369,1,435,1454,32259,38496,378 "2010-04-04 00:00",32fda13,30443,1,426,1458,32328,38513,380 "2010-04-05 00:00",4d1b1c7,30515,2,448,1491,32456,38537,385 "2010-04-06 00:00",3b1d348,30548,10,445,1493,32496,38577,386 "2010-04-07 00:00",8c434e8,30552,2,451,1493,32416,38486,387 "2010-04-08 00:00",8c434e8,30564,2,451,1493,32510,38580,387 "2010-04-09 00:00",8681735,30571,2,451,1489,32513,38582,388 "2010-04-10 00:00",43f8659,30570,2,452,1489,32513,38582,388 "2010-04-11 00:00",9406f55,30446,145,446,1441,32422,38491,388 "2010-04-12 00:00",8b256a9,30568,2,452,1491,32431,38500,388 "2010-04-13 00:00",cb45216,30609,2,453,1498,32562,38595,390 "2010-04-14 00:00",fb38dbf,30604,2,453,1503,32562,38595,390 "2010-04-15 00:00",2ec0e4e,30626,2,454,1509,32591,38595,391 "2010-04-16 00:00",78faa0c,30634,2,448,1507,32591,38595,391 "2010-04-17 00:00",78faa0c,30641,2,450,1507,32600,38604,391 "2010-04-18 00:00",78faa0c,30643,2,450,1507,32602,38606,391 "2010-04-19 00:00",842d2b0,30701,4,450,1507,32662,38666,392 "2010-04-20 00:00",b05155e,30751,2,457,1505,32715,38688,392 "2010-04-21 00:00",483a9da,30785,0,449,1522,32674,38627,397 "2010-04-22 00:00",98f05df,30887,0,450,1523,32774,38645,402 "2010-04-23 00:00",6783b52,31502,64,453,1634,33653,38728,410 "2010-04-24 00:00",de2ad34,31558,0,465,1632,33655,38731,410 "2010-04-26 00:00",f6ec0aa,31686,0,468,1650,33804,38790,417 "2010-04-27 00:00",1cdbc19,31695,19,473,1653,33840,38804,419 "2010-04-28 00:00",6a502fc,31707,1,479,1646,33833,38798,419 "2010-04-29 00:00",fe59fa8,31740,0,480,1633,33853,38818,419 "2010-04-30 00:00",f31d524,31142,724,464,1533,33863,38828,419 "2010-05-01 00:00",376196d,31178,724,455,1577,33934,38890,420 "2010-05-02 00:00",8abe0a6,31807,1,468,1694,33970,38898,421 "2010-05-03 00:00",b440a11,31789,47,470,1685,33991,38898,423 "2010-05-04 00:00",124895a,31846,0,473,1684,34003,38908,424 "2010-05-05 00:00",60c23d9,31846,0,473,1684,34003,38908,424 "2010-05-06 00:00",badc61d,30996,67,471,1685,33219,38094,426 "2010-05-07 00:00",ab23221,31873,11,474,1695,34039,38904,427 "2010-05-08 00:00",9427875,31864,10,475,1698,34041,38896,428 "2010-05-09 00:00",27e05a8,31966,24,475,1710,34170,39002,432 "2010-05-10 00:00",3d3893a,32005,0,532,1660,34197,39026,432 "2010-05-11 00:00",ed24098,32005,0,532,1660,34197,39026,433 "2010-05-12 00:00",ed24098,32015,0,532,1663,34210,39039,433 "2010-05-13 00:00",ed24098,32015,0,532,1663,34210,39039,433 "2010-05-14 00:00",da421b4,30785,0,532,1663,32963,37792,433 "2010-05-15 00:00",82f7ef3,32129,0,527,1652,34308,39137,433 "2010-05-16 00:00",92508d6,32144,0,529,1648,34321,39142,434 "2010-05-17 00:00",87e0e1b,32144,0,529,1648,34321,39142,434 "2010-05-18 00:00",2d0fc2b,32187,0,527,1666,34380,39183,437 "2010-05-19 00:00",5ec28d3,32257,0,527,1684,34461,39252,446 "2010-05-20 00:00",8292d45,32346,1,530,1682,34559,39356,448 "2010-05-21 00:00",e6863e4,32347,0,530,1682,34559,39356,448 "2010-05-22 00:00",9a15b82,32422,0,530,1684,34636,39433,451 "2010-05-23 00:00",eb84e91,32474,2,531,1689,34680,39434,457 "2010-05-24 00:00",10a3218,32517,0,531,1648,34696,39450,457 "2010-05-25 00:00",52a1375,32492,4,530,1646,34672,39455,456 "2010-05-26 00:00",475d1c7,32519,2,537,1628,34618,39395,460 "2010-05-27 00:00",e40ee42,32555,8,537,1647,34747,39520,460 "2010-05-28 00:00",ac1571f,32574,8,537,1646,34765,39538,460 "2010-05-29 00:00",9581e6a,32632,552,539,1641,35351,39542,471 "2010-05-30 00:00",dd0e5dd,32920,0,605,1857,35382,39573,471 "2010-05-31 00:00",4f9ca44,32962,1,608,1880,35451,39661,473 "2010-06-01 00:00",18d9960,33046,0,609,1871,35526,39736,473 "2010-06-02 00:00",18d9960,33063,0,609,1872,35544,39754,473 "2010-06-03 00:00",18d9960,0,33063,609,1872,35544,39754,473 "2010-06-04 00:00",e92a5f4,33172,0,607,1884,35663,39822,474 "2010-06-05 00:00",7c83e65,33223,2,607,1889,35721,39886,474 "2010-06-06 00:00",c0efe09,33258,4,606,1892,35760,39898,476 "2010-06-07 00:00",a1193fe,33296,0,609,1896,35801,39929,478 "2010-06-08 00:00",34c1ba4,33358,0,609,1890,35857,39985,479 "2010-06-09 00:00",9f05efa,33360,0,609,1890,35859,39987,479 "2010-06-10 00:00",16d9cb0,33360,0,609,1890,35859,39987,479 "2010-06-11 00:00",d59da85,33384,1,611,1890,35886,40009,481 "2010-06-12 00:00",52873b9,33323,1,611,1890,35825,39948,480 "2010-06-13 00:00",ecacff9,33361,1,614,1880,35856,39979,480 "2010-06-14 00:00",ca5bfc1,29096,3284,379,1209,32548,36671,480 "2010-06-15 00:00",11f835f,32370,641,562,1709,35017,39140,480 "2010-06-16 00:00",b6cc36c,32838,272,568,1772,35416,39649,473 "2010-06-17 00:00",fdb5ca4,33280,37,608,1935,35853,39887,489 "2010-06-18 00:00",3da39cf,33443,4,592,1916,35955,39960,490 "2010-06-19 00:00",683a745,33461,30,595,1906,35992,39969,492 "2010-06-20 00:00",b98d7fa,33534,55,594,1945,36128,40037,496 "2010-06-21 00:00",1277e18,33592,0,598,1951,36141,40050,496 "2010-06-22 00:00",7b089e5,33605,0,596,1937,36138,40047,496 "2010-06-23 00:00",11cbd4f,33610,0,597,1940,36147,40056,496 "2010-06-24 00:00",11cbd4f,33572,2,597,1916,36023,39932,495 "2010-06-25 00:00",f34e780,33587,0,600,1943,36130,40039,495 "2010-06-26 00:00",6769e19,33594,0,599,1938,36131,40040,496 "2010-06-27 00:00",2334011,33656,2,586,1921,36165,40074,496 "2010-06-28 00:00",05684c0,33663,0,584,1918,36165,40074,496 "2010-06-29 00:00",871e2fb,33718,4,569,1924,36215,40091,497 "2010-06-30 00:00",aa015ad,33735,1,569,1937,36238,40102,500 "2010-07-01 00:00",3d2cb82,33744,1,568,1937,36250,40114,500 "2010-07-02 00:00",fcf394a,33678,22,568,1932,36193,40057,501 "2010-07-03 00:00",0ad106c,33505,177,558,1915,36155,40021,501 "2010-07-04 00:00",77ca4f5,33767,55,568,1937,36327,40182,504 "2010-07-05 00:00",ef66ac3,33832,3,565,1940,36340,40195,505 "2010-07-06 00:00",55acd1d,33927,19,558,1907,36411,40197,507 "2010-07-07 00:00",f8dde0a,33926,2,568,1905,36383,40171,507 "2010-07-08 00:00",894e793,33910,0,568,1905,36383,40163,507 "2010-07-09 00:00",1086ff8,34010,12,573,1940,36534,40163,513 "2010-07-10 00:00",7579f7a,34118,3,580,1883,36584,40171,515 "2010-07-11 00:00",7579f7a,34085,3,578,1881,36543,40130,515 "2010-07-12 00:00",bb6df24,34111,26,579,1879,36544,40131,515 "2010-07-13 00:00",ae4538a,34143,29,581,1885,36591,40178,515 "2010-07-14 00:00",c8b6cf4,34157,16,596,1876,36598,40183,516 "2010-07-15 00:00",d51e99a,23534,5,600,1876,26015,20985,515 "2010-07-16 00:00",c513fbd,23507,13,600,1875,25995,20955,516 "2010-07-17 00:00",dd8d5d7,23527,5,596,1875,26003,20963,516 "2010-07-18 00:00",cd64dd0,23415,83,583,1868,25835,20749,518 rakudo-2013.12/dynext/IGNORE0000664000175000017500000000004512224263172015024 0ustar moritzmoritzThis space intentionally left blank. rakudo-2013.12/gen/jvm/.gitignore0000664000175000017500000000000212232644104016126 0ustar moritzmoritz* rakudo-2013.12/gen/parrot/.gitignore0000664000175000017500000000000212232644104016641 0ustar moritzmoritz* rakudo-2013.12/INSTALL.txt0000664000175000017500000001617112224263172014461 0ustar moritzmoritz Build requirements (Installing from source) For building Rakudo you need at least a C compiler, a "make" utility, and Perl 5.8 or newer. To automatically obtain and build Parrot you may also need a a git client, which is also needed for fetching the test suite. Building rakudo can take up to 1G of memory when compiling for the parrot runtime. In order to fully support Unicode, you'll also want to have the ICU library installed (). Rakudo can run without ICU, but some Unicode-related features do not work properly. To get readline support (command history and editing), you'll also need the "libreadline-dev" library. As an example, on Debian GNU/Linux or Ubuntu Linux, the necessary components for building Rakudo can be installed via the command aptitude install make gcc libicu-dev libreadline-dev git-core (Perl is installed by default already). To enable parallel testing you also need the CPAN module Test::Harness in version 3.16 or newer; you can control the number of parallel jobs with the "TEST_JOBS" environment variable. Building and invoking Rakudo If you're wanting the bleeding-edge version of the Rakudo Perl 6 compiler, we recommend downloading Rakudo directly from Github and building it from there. $ git clone git://github.com/rakudo/rakudo.git If you don't have git installed, you can get a tarball or zip of Rakudo from . Then unpack the tarball or zip. If you already have cloned Rakudo from github, you can get (pull) the most recent version from github like this: $ cd rakudo $ git pull Once you have an up-to-date copy of Rakudo, build it as follows: $ cd rakudo $ perl Configure.pl --gen-parrot $ make This will create a "perl6" or "perl6.exe" executable in the current (rakudo) directory. Note that if you have multiple (Perl 5) "perl"s in your path, you may need to use a fully qualified path to the appropriate executable (or update your PATH environment variable). Programs can then be run from the build directory using a command like: $ ./perl6 hello.pl Important: To run Rakudo from outside the build directory, you must run $ make install This will install the "perl6" (or "perl6.exe" binary on windows) into the "install/bin" directory locally, no additional root privileges necessary. The "--gen-parrot" above option tells Configure.pl to automatically download and build the most appropriate version of NQP and Parrot into local "nqp/" and "parrot/" subdirectories, install NQP and Parrot into the "install/" subdirectory, and use them for building Rakudo. It's okay to use the "--gen-parrot" option on later invocations of Configure.pl; the configure system will re-build NQP and/or Parrot only if a newer version is needed for whatever version of Rakudo you're working with. If you already have Parrot installed, you can use "--with-parrot=/path/to/bin/parrot" to use it instead of building a new one. This installed Parrot must include its development environment. Similarly, if you already have NQP installed, you can specify "--with-nqp=/path/to/bin/nqp" to use it. (Note that this must be NQP, not the NQP-rx that comes with Parrot.) The versions of any already installed NQP or Parrot binaries must satify a minimum specified by the Rakudo being built -- Configure.pl and "make" will verify this for you. Released versions of Rakudo always build against the latest release of Parrot; checkouts of Rakudo's HEAD revision from Github often require a version of Parrot that is newer than the most recent Parrot monthly release. Once built, Rakudo's "make install" target will install Rakudo and its libraries into the directories specified by the Parrot installation used to create it. Until this step is performed, the "perl6" executable created by "make" above can only be reliably run from the root of Rakudo's build directory. After "make install" is performed, the installed executable can be run from any directory (as long as the Parrot installation that was used to create it remains intact). If the Rakudo compiler is invoked without an explicit script to run, it enters a small interactive mode that allows Perl 6 statements to be executed from the command line. See the manual page ("docs/running.pod") for more about command-line options. Build/install problems Occasionally, there may be problems when building/installing Rakudo. Make sure you have a backup of any custom changes you have done to the source tree before performing the following steps: Try to remove the "install/" subdirectory: $ cd rakudo $ rm -r install $ git pull $ perl Configure.pl --gen-parrot $ make Or, in case you are really stuck, start with a fresh source tree: $ rm -r rakudo $ git clone git://github.com/rakudo/rakudo.git Running the test suite Entering "make test" will run a small test suite that comes bundled with Rakudo. This is a simple suite of tests, designed to make sure that the Rakudo compiler is basically working and that it's capable of running a simple test harness. Running "make spectest" will import the official Perl 6 test suite from the "roast" repository and run all of these tests that are currently known to pass. If you want to automatically submit the results of your spectest run to a central server, use "make spectest_smolder" instead. You need the Perl 5 module TAP::Harness::Archive and an active internet connection for that. The smoke results are collected at At present we do not have any plans to directly store the official test suite as part of the Rakudo repository, but will continue to fetch it from the roast repository. Releases of Rakudo get a snapshot of the roast repository as of the time of the release. You can also use "make" to run an individual test from the command line: $ make t/spec/S29-str/ucfirst.t t/spec/S29-str/ucfirst.rakudo .. 1..4 ok 1 - simple ok 2 - empty string ok 3 - # SKIP unicode ok 4 - # SKIP unicode # FUDGED! ok All tests successful. Files=1, Tests=4, 1 wallclock secs ( 0.02 usr 0.00 sys + 0.57 cusr 0.06 csys = 0.65 CPU) Result: PASS If you want to run the tests in parallel, you need to install a fairly recent version of the Perl 5 module Test::Harness (3.16 works for sure). Spectest smolder requirements (Windows) You need recent version of either Strawberry Perl or ActiveState Perl. If you are working with ActiveState Perl you need the Mingw gcc compiler. You need msys git installed and you need "\Program Files\Git\cmd" on your execution path and NOT "\Program Files\Git\bin". You need a win32 curl program. rakudo-2013.12/lib/lib.pm60000664000175000017500000000012312224263172014540 0ustar moritzmoritzmodule lib { }; our sub EXPORT(*@a) { @*INC.unshift: @a; return ().hash; } rakudo-2013.12/lib/Pod/To/Text.pm0000664000175000017500000000766512224263172015756 0ustar moritzmoritzclass Pod::To::Text; method render($pod) { pod2text($pod) } my &colored; if %*ENV { &colored = try { eval q{ use Term::ANSIColor; &colored } } // sub ($text, $color) { $text } } else { &colored = sub ($text, $color) { $text } } sub pod2text($pod) is export { my @declarators; given $pod { when Pod::Heading { heading2text($pod) } when Pod::Block::Code { code2text($pod) } when Pod::Block::Named { named2text($pod) } when Pod::Block::Para { $pod.content.map({pod2text($_)}).join("") } when Pod::Block::Table { table2text($pod) } when Pod::Block::Declarator { declarator2text($pod) } when Pod::Item { item2text($pod) } when Pod::FormattingCode { formatting2text($pod) } when Positional { $pod.map({pod2text($_)}).join("\n\n")} when Pod::Block::Comment { } when Pod::Config { } default { $pod.Str } } } sub heading2text($pod) { given $pod.level { when 1 { pod2text($pod.content) } when 2 { ' ' ~ pod2text($pod.content) } default { ' ' ~ pod2text($pod.content) } } } sub code2text($pod) { " " ~ $pod.content.subst(/\n/, "\n ", :g) } sub item2text($pod) { ' * ' ~ pod2text($pod.content).chomp.chomp } sub named2text($pod) { given $pod.name { when 'pod' { pod2text($pod.content) } when 'para' { para2text($pod.content[0]) } when 'defn' { pod2text($pod.content[0]) ~ "\n" ~ pod2text($pod.content[1..*-1]) } when 'config' { } when 'nested' { } default { $pod.name ~ "\n" ~ pod2text($pod.content) } } } sub para2text($pod) { twine2text($pod.content) } sub table2text($pod) { my @rows = $pod.content; @rows.unshift($pod.headers.item) if $pod.headers; my @maxes; for 0..(@rows[1].elems - 1) -> $i { @maxes.push([max] @rows.map({ $_[$i].chars })); } my $ret; if $pod.config { $ret = $pod.config ~ "\n" } for @rows -> $row { for 0..($row.elems - 1) -> $i { $ret ~= $row[$i].fmt("%-{@maxes[$i]}s") ~ " "; } $ret ~= "\n"; } return $ret; } sub declarator2text($pod) { next unless $pod.WHEREFORE.WHY; my $what = do given $pod.WHEREFORE { when Method { my @params=$_.signature.params[1..*]; @params.pop if @params[*-1].name eq '%_'; 'method ' ~ $_.name ~ signature2text(@params) } when Sub { 'sub ' ~ $_.name ~ signature2text($_.signature.params) } when nqp::p6bool(nqp::istype($_.HOW, Metamodel::ClassHOW)) { 'class ' ~ $_.perl } when nqp::p6bool(nqp::istype($_.HOW, Metamodel::ModuleHOW)) { 'module ' ~ $_.perl } when nqp::p6bool(nqp::istype($_.HOW, Metamodel::PackageHOW)) { 'package ' ~ $_.perl } default { '' } } return "$what\n{$pod.WHEREFORE.WHY.content}" } sub signature2text($params) { $params.elems ?? "(\n\t" ~ $params.map({ $_.perl }).join(", \n\t") ~ "\n)" !! "()"; } my %formats = { "C" => "bold", "L" => "underline", "D" => "underline", "R" => "inverse" }; my %only_first_part := bag ; sub formatting2text($pod) { my $text = twine2text($pod.content); if $pod.type ~~ %only_first_part { if $text ~~ /'|'/ { $text = $/.prematch } } if $pod.type ~~ %formats { return colored($text, %formats{$pod.type}); } $text } sub twine2text($twine) { return '' unless $twine.elems; my $r = $twine[0]; for $twine[1..*] -> $f, $s { $r ~= twine2text($f.content); $r ~= $s; } return $r; } # vim: ft=perl6 rakudo-2013.12/lib/Test.pm0000664000175000017500000002143712224263172014636 0ustar moritzmoritzmodule Test; # Copyright (C) 2007 - 2011 The Perl Foundation. ## This is a temporary Test.pm to get us started until we get pugs's Test.pm ## working. It's shamelessly stolen & adapted from MiniPerl6 in the pugs repo. # variables to keep track of our tests my $num_of_tests_run = 0; my $num_of_tests_failed = 0; my $todo_upto_test_num = 0; my $todo_reason = ''; my $num_of_tests_planned; my $no_plan = 1; my $die_on_fail; my $perl6_test_times = ? %*ENV; my $time_before; my $time_after; ## If done_testing hasn't been run when we hit our END block, we need to know ## so that it can be run. This allows compatibility with old tests that use ## plans and don't call done_testing. my $done_testing_has_been_run = 0; ## test functions # you can call die_on_fail; to turn it on and die_on_fail(0) to turn it off sub die_on_fail($fail=1) { $die_on_fail = $fail; } # "plan 'no_plan';" is now "plan *;" # It is also the default if nobody calls plan at all multi sub plan($number_of_tests) is export { if $number_of_tests ~~ ::Whatever { $no_plan = 1; } else { $num_of_tests_planned = $number_of_tests; $no_plan = 0; say '1..' ~ $number_of_tests; } # Get two successive timestamps to say how long it takes to read the # clock, and to let the first test timing work just like the rest. # These readings should be made with the expression now.to-posix[0], # but its execution time when tried in the following two lines is a # lot slower than the non portable nqp::p6box_n(nqp::time_n). $time_before = nqp::p6box_n(nqp::time_n); $time_after = nqp::p6box_n(nqp::time_n); say '# between two timestamps ' ~ ceiling(($time_after-$time_before)*1_000_000) ~ ' microseconds' if $perl6_test_times; # Take one more reading to serve as the begin time of the first test $time_before = nqp::p6box_n(nqp::time_n); } multi sub pass($desc = '') is export { $time_after = nqp::p6box_n(nqp::time_n); proclaim(1, $desc); $time_before = nqp::p6box_n(nqp::time_n); } multi sub ok(Mu $cond, $desc = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $ok = proclaim(?$cond, $desc); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub nok(Mu $cond, $desc = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $ok = proclaim(!$cond, $desc); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub is(Mu $got, Mu $expected, $desc = '') is export { $time_after = nqp::p6box_n(nqp::time_n); $got.defined; # Hack to deal with Failures my $test = $got eq $expected; my $ok = proclaim(?$test, $desc); if !$test { diag " got: '$got'"; diag "expected: '$expected'"; } $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub isnt(Mu $got, Mu $expected, $desc = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $test = !($got eq $expected); my $ok = proclaim($test, $desc); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub is_approx(Mu $got, Mu $expected, $desc = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $tol = $expected.abs < 1e-6 ?? 1e-5 !! $expected.abs * 1e-6; my $test = ($got - $expected).abs <= $tol; my $ok = proclaim(?$test, $desc); unless $test { diag("got: $got"); diag("expected: $expected"); } $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub todo($reason, $count = 1) is export { $time_after = nqp::p6box_n(nqp::time_n); $todo_upto_test_num = $num_of_tests_run + $count; $todo_reason = '# TODO ' ~ $reason; $time_before = nqp::p6box_n(nqp::time_n); } multi sub skip() { $time_after = nqp::p6box_n(nqp::time_n); proclaim(1, "# SKIP"); $time_before = nqp::p6box_n(nqp::time_n); } multi sub skip($reason, $count = 1) is export { $time_after = nqp::p6box_n(nqp::time_n); die "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?" if $count !~~ Numeric; my $i = 1; while $i <= $count { proclaim(1, "# SKIP " ~ $reason); $i = $i + 1; } $time_before = nqp::p6box_n(nqp::time_n); } sub skip_rest($reason = '') is export { $time_after = nqp::p6box_n(nqp::time_n); skip($reason, $num_of_tests_planned - $num_of_tests_run); $time_before = nqp::p6box_n(nqp::time_n); } sub diag(Mu $message) is export { $time_after = nqp::p6box_n(nqp::time_n); say $message.Str.subst(rx/^^/, '# ', :g); $time_before = nqp::p6box_n(nqp::time_n); } multi sub flunk($reason) is export { $time_after = nqp::p6box_n(nqp::time_n); my $ok = proclaim(0, "flunk $reason"); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub isa_ok(Mu $var, Mu $type, $msg = ("The object is-a '" ~ $type.perl ~ "'")) is export { $time_after = nqp::p6box_n(nqp::time_n); my $ok = proclaim($var.isa($type), $msg) or diag('Actual type: ' ~ $var.^name); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub dies_ok(Callable $closure, $reason = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $death = 1; my $bad_death = 0; try { $closure(); $death = 0; } if $death && $!.Str.index('Null PMC access') { $bad_death = 1; diag("Wrong way to die: '$!'"); } my $ok = proclaim( $death && !$bad_death, $reason ); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub lives_ok(Callable $closure, $reason = '') is export { $time_after = nqp::p6box_n(nqp::time_n); try { $closure(); } my $ok = proclaim((not defined $!), $reason) or diag($!); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub eval_dies_ok(Str $code, $reason = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $ee = eval_exception($code); my $ok; if defined $ee { # XXX no regexes yet in nom my $bad_death = $ee.Str.index('Null PMC access ').defined; if $bad_death { diag "wrong way to die: '$ee'"; } $ok = proclaim( !$bad_death, $reason ); } else { $ok = proclaim( 0, $reason ); } $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub eval_lives_ok(Str $code, $reason = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $ee = eval_exception($code); my $ok = proclaim((not defined $ee), $reason) or diag("Error: $ee"); $time_before = nqp::p6box_n(nqp::time_n); return $ok; } multi sub is_deeply(Mu $got, Mu $expected, $reason = '') is export { $time_after = nqp::p6box_n(nqp::time_n); my $test = _is_deeply( $got, $expected ); my $ok = proclaim($test, $reason); if !$test { my $got_perl = try { $got.perl }; my $expected_perl = try { $expected.perl }; if $got_perl.defined && $expected_perl.defined { diag " got: $got_perl"; diag "expected: $expected_perl"; } } $time_before = nqp::p6box_n(nqp::time_n); return $ok; } sub _is_deeply(Mu $got, Mu $expected) { $got eqv $expected; } ## 'private' subs sub eval_exception($code) { try { eval ($code); } $!; } sub proclaim($cond, $desc) { # exclude the time spent in proclaim from the test time $num_of_tests_run = $num_of_tests_run + 1; unless $cond { print "not "; unless $num_of_tests_run <= $todo_upto_test_num { $num_of_tests_failed = $num_of_tests_failed + 1 } } print "ok ", $num_of_tests_run, " - ", $desc; if $todo_reason and $num_of_tests_run <= $todo_upto_test_num { print $todo_reason; } print "\n"; print "# t=" ~ ceiling(($time_after-$time_before)*1_000_000) ~ "\n" if $perl6_test_times; if !$cond && $die_on_fail && !$todo_reason { die "Test failed. Stopping test"; } # must clear this between tests if $todo_upto_test_num == $num_of_tests_run { $todo_reason = '' } $cond; } sub done_testing() is export { die "done_testing() has been renamed to done(), please change your test code"; } sub done() is export { $done_testing_has_been_run = 1; if $no_plan { $num_of_tests_planned = $num_of_tests_run; say "1..$num_of_tests_planned"; } if ($num_of_tests_planned != $num_of_tests_run) { ##Wrong quantity of tests diag("Looks like you planned $num_of_tests_planned tests, but ran $num_of_tests_run"); } if ($num_of_tests_failed) { diag("Looks like you failed $num_of_tests_failed tests of $num_of_tests_run"); } } END { ## In planned mode, people don't necessarily expect to have to call done ## So call it for them if they didn't if !$done_testing_has_been_run && !$no_plan { done; } } # vim: ft=perl6 rakudo-2013.12/LICENSE0000664000175000017500000002130612224263172013613 0ustar moritzmoritz The Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. rakudo-2013.12/MANIFEST0000664000175000017500000011463212255243477013756 0ustar moritzmoritzblib/Perl6/.gitignore Configure.pl CREDITS docs/announce/2009-02 docs/announce/2009-03 docs/announce/2009-04 docs/announce/2009-05 docs/announce/2009-06 docs/announce/2009-07 docs/announce/2009-08 docs/announce/2009-09 docs/announce/2009-10 docs/announce/2009-11 docs/announce/2009-12 docs/announce/2010-01 docs/announce/2010.02 docs/announce/2010.03 docs/announce/2010.04 docs/announce/2010.05 docs/announce/2010.06 docs/announce/2010.07 docs/announce/2010.08 docs/announce/2010.09 docs/announce/2010.10 docs/announce/2010.11 docs/announce/2010.12 docs/announce/2011.01 docs/announce/2011.02 docs/announce/2011.03 docs/announce/2011.04 docs/announce/2011.05 docs/announce/2011.06 docs/announce/2011.07 docs/announce/2011.09 docs/announce/2011.10 docs/announce/2011.11 docs/announce/2011.12 docs/announce/2012.01 docs/announce/2012.02 docs/announce/2012.03 docs/announce/2012.04 docs/announce/2012.04.1 docs/announce/2012.05 docs/announce/2012.06 docs/announce/2012.07 docs/announce/2012.08 docs/announce/2012.09 docs/announce/2012.09.1 docs/announce/2012.10 docs/announce/2012.11 docs/announce/2012.12 docs/announce/2013.01 docs/announce/2013.02 docs/announce/2013.03.md docs/announce/2013.04.md docs/announce/2013.05.md docs/announce/2013.06.md docs/announce/2013.07.md docs/announce/2013.08.md docs/announce/2013.09.md docs/announce/2013.10.md docs/announce/2013.11.md docs/announce/2013.12.md docs/architecture.html docs/architecture.svg docs/ChangeLog docs/compiler_overview.pod docs/deprecations docs/glossary.pod docs/guide_to_setting.pod docs/metamodel.pod docs/metaobject-api.pod docs/parrot-relationship.txt docs/release_guide.pod docs/ROADMAP docs/running.pod docs/S11-Modules-proposal.pod docs/spectest-progress.csv dynext/IGNORE gen/jvm/.gitignore gen/parrot/.gitignore INSTALL.txt lib/lib.pm6 lib/Pod/To/Text.pm lib/Test.pm LICENSE MANIFEST README src/core/Any.pm src/core/Array.pm src/core/array_slice.pm src/core/Associative.pm src/core/AST.pm src/core/Attribute.pm src/core/Backtrace.pm src/core/Baggy.pm src/core/BagHash.pm src/core/Bag.pm src/core/Block.pm src/core/Bool.pm src/core/Buf.pm src/core/Callable.pm src/core/CallFrame.pm src/core/Capture.pm src/core/Code.pm src/core/Complex.pm src/core/control.pm src/core/Cool.pm src/core/core_epilogue.pm src/core/core_prologue.pm src/core/Cursor.pm src/core/Deprecations.pm src/core/Duration.pm src/core/Enumeration.pm src/core/EnumMap.pm src/core/Enum.pm src/core/Exception.pm src/core/EXPORTHOW.pm src/core/Failure.pm src/core/ForeignCode.pm src/core/GatherIter.pm src/core/Grammar.pm src/core/HashIter.pm src/core/Hash.pm src/core/hash_slice.pm src/core/Instant.pm src/core/Int.pm src/core/IO/ArgFiles.pm src/core/IO.pm src/core/IO/Socket/INET.pm src/core/IO/Socket.pm src/core/IO/Spec/Cygwin.pm src/core/IO/Spec.pm src/core/IO/Spec/QNX.pm src/core/IO/Spec/Unix.pm src/core/IO/Spec/Win32.pm src/core/Iterable.pm src/core/Iterator.pm src/core/Junction.pm src/core/ListIter.pm src/core/List.pm src/core/LoL.pm src/core/Macro.pm src/core/Main.pm src/core/MapIter.pm src/core/Match.pm src/core/metaops.pm src/core/Method.pm src/core/MixHash.pm src/core/Mix.pm src/core/Mixy.pm src/core/Mu.pm src/core/natives.pm src/core/Nil.pm src/core/Numeric.pm src/core/Num.pm src/core/ObjAt.pm src/core/operators.pm src/core/Order.pm src/core/OS.pm src/core/Pair.pm src/core/Parameter.pm src/core/Parcel.pm src/core/Pod.pm src/core/Positional.pm src/core/precedence.pm src/core/PseudoStash.pm src/core/QuantHash.pm src/core/Range.pm src/core/Rational.pm src/core/Rat.pm src/core/Real.pm src/core/Regex.pm src/core/Routine.pm src/core/Scalar.pm src/core/Seq.pm src/core/SetHash.pm src/core/set_operators.pm src/core/Set.pm src/core/Setty.pm src/core/Signature.pm src/core/Stash.pm src/core/Stringy.pm src/core/Str.pm src/core/stubs.pm src/core/Submethod.pm src/core/Sub.pm src/core/tai-utc.pm src/core/Temporal.pm src/core/terms.pm src/core/traits.pm src/core/UInt64.pm src/core/Variable.pm src/core/Version.pm src/core/WhateverCode.pm src/core/Whatever.pm src/gen/README src/main.nqp src/Perl6/Actions.nqp src/Perl6/Compiler.nqp src/Perl6/Grammar.nqp src/Perl6/Metamodel/Archetypes.nqp src/Perl6/Metamodel/ArrayType.nqp src/Perl6/Metamodel/AttributeContainer.nqp src/Perl6/Metamodel/BaseType.nqp src/Perl6/Metamodel/BoolificationProtocol.nqp src/Perl6/Metamodel/BOOTSTRAP.nqp src/Perl6/Metamodel/BUILDPLAN.nqp src/Perl6/Metamodel/C3MRO.nqp src/Perl6/Metamodel/ClassHOW.nqp src/Perl6/Metamodel/ConcreteRoleHOW.nqp src/Perl6/Metamodel/ContainerDescriptor.nqp src/Perl6/Metamodel/CurriedRoleHOW.nqp src/Perl6/Metamodel/DefaultParent.nqp src/Perl6/Metamodel/Dispatchers.nqp src/Perl6/Metamodel/Documenting.nqp src/Perl6/Metamodel/EnumHOW.nqp src/Perl6/Metamodel/EXPORTHOW.nqp src/Perl6/Metamodel/GenericHOW.nqp src/Perl6/Metamodel/GrammarHOW.nqp src/Perl6/Metamodel/InvocationProtocol.nqp src/Perl6/Metamodel/MethodContainer.nqp src/Perl6/Metamodel/MethodDelegation.nqp src/Perl6/Metamodel/Mixins.nqp src/Perl6/Metamodel/ModuleHOW.nqp src/Perl6/Metamodel/MROBasedMethodDispatch.nqp src/Perl6/Metamodel/MROBasedTypeChecking.nqp src/Perl6/Metamodel/MultiMethodContainer.nqp src/Perl6/Metamodel/MultipleInheritance.nqp src/Perl6/Metamodel/Naming.nqp src/Perl6/Metamodel/NativeHOW.nqp src/Perl6/Metamodel/PackageHOW.nqp src/Perl6/Metamodel/ParametricRoleGroupHOW.nqp src/Perl6/Metamodel/ParametricRoleHOW.nqp src/Perl6/Metamodel/ParrotInterop.nqp src/Perl6/Metamodel/PrivateMethodContainer.nqp src/Perl6/Metamodel/REPRComposeProtocol.nqp src/Perl6/Metamodel/RoleContainer.nqp src/Perl6/Metamodel/RolePunning.nqp src/Perl6/Metamodel/RoleToClassApplier.nqp src/Perl6/Metamodel/RoleToRoleApplier.nqp src/Perl6/Metamodel/Stashing.nqp src/Perl6/Metamodel/SubsetHOW.nqp src/Perl6/Metamodel/Trusting.nqp src/Perl6/Metamodel/TypePretense.nqp src/Perl6/Metamodel/Versioning.nqp src/Perl6/ModuleLoader.nqp src/Perl6/Optimizer.nqp src/Perl6/Pod.nqp src/Perl6/World.nqp src/RESTRICTED.setting src/vm/jvm/core/asyncops.pm src/vm/jvm/core/Channel.pm src/vm/jvm/core/CurrentThreadScheduler.pm src/vm/jvm/core/IOAsyncFile.pm src/vm/jvm/core/KeyReducer.pm src/vm/jvm/core/Lock.pm src/vm/jvm/core/Promise.pm src/vm/jvm/core/Scheduler.pm src/vm/jvm/core/SupplyOperations.pm src/vm/jvm/core/Supply.pm src/vm/jvm/core/Thread.pm src/vm/jvm/core/ThreadPoolScheduler.pm src/vm/jvm/ModuleLoaderVMConfig.nqp src/vm/jvm/Perl6/JavaModuleLoader.nqp src/vm/jvm/Perl6/Metamodel/JavaHOW.nqp src/vm/jvm/Perl6/Ops.nqp src/vm/jvm/runtime/org/perl6/rakudo/Binder.java src/vm/jvm/runtime/org/perl6/rakudo/RakOps.java src/vm/jvm/runtime/org/perl6/rakudo/RakudoContainerConfigurer.java src/vm/jvm/runtime/org/perl6/rakudo/RakudoContainerSpec.java src/vm/jvm/runtime/org/perl6/rakudo/RakudoJavaInterop.java src/vm/parrot/guts/bind.c src/vm/parrot/guts/bind.h src/vm/parrot/guts/container.c src/vm/parrot/guts/container.h src/vm/parrot/guts/exceptions.c src/vm/parrot/guts/exceptions.h src/vm/parrot/guts/serialization.h src/vm/parrot/guts/sixmodelobject.h src/vm/parrot/guts/storage_spec.h src/vm/parrot/guts/types.c src/vm/parrot/guts/types.h src/vm/parrot/ModuleLoaderVMConfig.nqp src/vm/parrot/ops/.gitignore src/vm/parrot/ops/perl6.ops src/vm/parrot/Perl6/Ops.nqp t/00-parrot/01-literals.t t/00-parrot/02-op-math.t t/00-parrot/03-op-logic.t t/00-parrot/04-op-cmp.t t/00-parrot/05-var.t t/00-parrot/06-op-inplace.t t/00-parrot/07-op-string.t t/00-parrot/08-var-array.t t/00-parrot/09-pir.t t/00-parrot/10-regex.t t/01-sanity/01-tap.t t/01-sanity/02-counter.t t/01-sanity/03-equal.t t/01-sanity/04-if.t t/01-sanity/05-sub.t t/01-sanity/06-eqv.t t/01-sanity/07-isa.t t/01-sanity/08-simple-multisubs.t t/01-sanity/09-end-blocks.t t/01-sanity/10-say.t t/01-sanity/11-defined.t t/01-sanity/12-try.t t/01-sanity/99-test-basic.t t/02-rakudo/dump.t t/fudgeandrun t/harness tools/autounfudge.pl tools/benchmark.pl tools/bisect-parrot.pl tools/build/check-versions.pl tools/build/create-jvm-runner.pl tools/build/gen-cat.pl tools/build/gen-version.pl tools/build-localtest.pl tools/build/Makefile-common.in tools/build/Makefile-JVM.in tools/build/Makefile-Parrot.in tools/build/nqp-jvm-rr.pl tools/build/NQP_REVISION tools/commit-stats.pl tools/contributors.pl tools/distro/rakudo.spec tools/lib/NQP/Configure.pm tools/perl6-limited.pl tools/progress-graph.pl tools/rakudo-swarm.config tools/rebase-rakudo.pl tools/release-dates.pl tools/update_passing_test_data.pl tools/update-tai-utc.pl tools/util/perlcritic.conf t/spec/fudge t/spec/fudgeall t/spec/integration/99problems-01-to-10.t t/spec/integration/99problems-11-to-20.t t/spec/integration/99problems-21-to-30.t t/spec/integration/99problems-31-to-40.t t/spec/integration/99problems-41-to-50.t t/spec/integration/99problems-51-to-60.t t/spec/integration/99problems-61-to-70.t t/spec/integration/advent2009-day01.t t/spec/integration/advent2009-day02.t t/spec/integration/advent2009-day03.t t/spec/integration/advent2009-day04.t t/spec/integration/advent2009-day05.t t/spec/integration/advent2009-day06.t t/spec/integration/advent2009-day07.t t/spec/integration/advent2009-day08.t t/spec/integration/advent2009-day09.t t/spec/integration/advent2009-day10.t t/spec/integration/advent2009-day11.t t/spec/integration/advent2009-day12.t t/spec/integration/advent2009-day13.t t/spec/integration/advent2009-day14.t t/spec/integration/advent2009-day15.t t/spec/integration/advent2009-day16.t t/spec/integration/advent2009-day17.t t/spec/integration/advent2009-day18.t t/spec/integration/advent2009-day19.t t/spec/integration/advent2009-day20.t t/spec/integration/advent2009-day21.t t/spec/integration/advent2009-day22.t t/spec/integration/advent2009-day23.t t/spec/integration/advent2009-day24.t t/spec/integration/advent2010-day04.t t/spec/integration/class-name-and-attribute-conflict.t t/spec/integration/code-blocks-as-sub-args.t t/spec/integration/error-reporting.t t/spec/integration/lazy-bentley-generator.t t/spec/integration/lexical-array-in-inner-block.t t/spec/integration/lexicals-and-attributes.t t/spec/integration/man-or-boy.t t/spec/integration/method-calls-and-instantiation.t t/spec/integration/no-indirect-new.t t/spec/integration/packages.t t/spec/integration/pair-in-array.t t/spec/integration/passing-pair-class-to-sub.t t/spec/integration/real-strings.t t/spec/integration/role-composition-vs-attribute.t t/spec/integration/rule-in-class-Str.t t/spec/integration/say-crash.t t/spec/integration/substr-after-match-in-gather-in-for.t t/spec/integration/topic_in_double_loop.t t/spec/integration/variables-in-do.t t/spec/integration/weird-errors.t t/spec/LICENSE t/spec/packages/A/A.pm t/spec/packages/A/B.pm t/spec/packages/A.pm t/spec/packages/ArrayInit.pm t/spec/packages/Bar.pm t/spec/packages/B/Grammar.pm t/spec/packages/B.pm t/spec/packages/ContainsUnicode.pm t/spec/packages/Exportops.pm t/spec/packages/Export_PackA.pm t/spec/packages/Export_PackB.pm t/spec/packages/Export_PackC.pm t/spec/packages/Export_PackD.pm t/spec/packages/Fancy/Utilities.pm t/spec/packages/FooBar.pm t/spec/packages/Foo.pm t/spec/packages/HasMain.pm t/spec/packages/Import.pm t/spec/packages/LoadCounter.pm t/spec/packages/LoadFromInsideAClass.pm t/spec/packages/LoadFromInsideAModule.pm t/spec/packages/OverrideTest.pm t/spec/packages/PackageTest.pm t/spec/packages/PM6.pm6 t/spec/packages/README t/spec/packages/RequireAndUse1.pm t/spec/packages/RequireAndUse2.pm t/spec/packages/RequireAndUse3.pm t/spec/packages/RoleA.pm t/spec/packages/RoleB.pm t/spec/packages/S11-modules/Foo.pm t/spec/packages/Test/Util.pm t/spec/packages/UseTest.pm t/spec/README t/spec/rosettacode/greatest_element_of_a_list.t t/spec/rosettacode/README t/spec/rosettacode/sierpinski_triangle.t t/spec/S01-perl-5-integration/array.t t/spec/S01-perl-5-integration/basic.t t/spec/S01-perl-5-integration/class.t t/spec/S01-perl-5-integration/context.t t/spec/S01-perl-5-integration/eval_lex.t t/spec/S01-perl-5-integration/exception_handling.t t/spec/S01-perl-5-integration/hash.t t/spec/S01-perl-5-integration/import.t t/spec/S01-perl-5-integration/method.t t/spec/S01-perl-5-integration/modify_inside_p5_p6.t t/spec/S01-perl-5-integration/modify_inside_p5.t t/spec/S01-perl-5-integration/README t/spec/S01-perl-5-integration/return.t t/spec/S01-perl-5-integration/roundtrip.t t/spec/S01-perl-5-integration/strings.t t/spec/S01-perl-5-integration/subs.t t/spec/S02-lexical-conventions/begin_end_pod.t t/spec/S02-lexical-conventions/bom.t t/spec/S02-lexical-conventions/comments.t t/spec/S02-lexical-conventions/end-pod.t t/spec/S02-lexical-conventions/minimal-whitespace.t t/spec/S02-lexical-conventions/one-pass-parsing.t t/spec/S02-lexical-conventions/pod-in-multi-line-exprs.t t/spec/S02-lexical-conventions/sub-block-parsing.t t/spec/S02-lexical-conventions/unicode.t t/spec/S02-lexical-conventions/unicode-whitespace.t t/spec/S02-lexical-conventions/unspace.t t/spec/S02-lists/tree.t t/spec/S02-literals/array-interpolation.t t/spec/S02-literals/autoref.t t/spec/S02-literals/char-by-name.t t/spec/S02-literals/char-by-number.t t/spec/S02-literals/fmt-interpolation.t t/spec/S02-literals/hash-interpolation.t t/spec/S02-literals/heredocs.t t/spec/S02-literals/hex_chars.t t/spec/S02-literals/listquote.t t/spec/S02-literals/listquote-whitespace.t t/spec/S02-literals/misc-interpolation.t t/spec/S02-literals/numeric.t t/spec/S02-literals/pair-boolean.t t/spec/S02-literals/pairs.t t/spec/S02-literals/pod.t t/spec/S02-literals/quoting.t t/spec/S02-literals/quoting-unicode.t t/spec/S02-literals/radix.t t/spec/S02-literals/string-interpolation.t t/spec/S02-literals/sub-calls.t t/spec/S02-literals/subscript.t t/spec/S02-literals/types.t t/spec/S02-literals/underscores.t t/spec/S02-literals/version.t t/spec/S02-magicals/78258.t t/spec/S02-magicals/args.t t/spec/S02-magicals/block.t t/spec/S02-magicals/config.t t/spec/S02-magicals/dollar_bang.t t/spec/S02-magicals/dollar-underscore.t t/spec/S02-magicals/env.t t/spec/S02-magicals/file_line.t t/spec/S02-magicals/perlver.t t/spec/S02-magicals/pid.t t/spec/S02-magicals/progname.t t/spec/S02-magicals/subname.t t/spec/S02-magicals/sub.t t/spec/S02-magicals/UsedEnv.pm6 t/spec/S02-magicals/vm.t t/spec/S02-names/bare-sigil.t t/spec/S02-names/caller.t t/spec/S02-names/identifier.t t/spec/S02-names/indirect.t t/spec/S02-names/is_default.t t/spec/S02-names/is_dynamic.t t/spec/S02-names/name.t t/spec/S02-names/our.t t/spec/S02-names/pseudo.t t/spec/S02-names/symbolic-deref.t t/spec/S02-names-vars/contextual.t t/spec/S02-names-vars/fmt.t t/spec/S02-names-vars/list_array_perl.t t/spec/S02-names-vars/names.t t/spec/S02-names-vars/perl.t t/spec/S02-names-vars/signature.t t/spec/S02-names-vars/variables-and-packages.t t/spec/S02-names-vars/varnames.t t/spec/S02-one-pass-parsing/less-than.t t/spec/S02-packages/package-lookup.t t/spec/S02-types/anon_block.t t/spec/S02-types/array_extending.t t/spec/S02-types/array_ref.t t/spec/S02-types/array-shapes.t t/spec/S02-types/array.t t/spec/S02-types/assigning-refs.t t/spec/S02-types/autovivification.t t/spec/S02-types/baghash.t t/spec/S02-types/bag.t t/spec/S02-types/bool.t t/spec/S02-types/capture.t t/spec/S02-types/catch_type_cast_mismatch.t t/spec/S02-types/compact.t t/spec/S02-types/declare.t t/spec/S02-types/deprecations.t t/spec/S02-types/fatrat.t t/spec/S02-types/flattening.t t/spec/S02-types/hash_ref.t t/spec/S02-types/hash.t t/spec/S02-types/infinity.t t/spec/S02-types/instants-and-durations.t t/spec/S02-types/int-uint.t t/spec/S02-types/isDEPRECATED.t t/spec/S02-types/keyhash.t t/spec/S02-types/keyweight.t t/spec/S02-types/lazy-lists.t t/spec/S02-types/lists.t t/spec/S02-types/mixed_multi_dimensional.t t/spec/S02-types/mixhash.t t/spec/S02-types/mix.t t/spec/S02-types/multi_dimensional_array.t t/spec/S02-types/nan.t t/spec/S02-types/native.t t/spec/S02-types/nested_arrays.t t/spec/S02-types/nested_pairs.t t/spec/S02-types/nil.t t/spec/S02-types/num.t t/spec/S02-types/pair.t t/spec/S02-types/parcel.t t/spec/S02-types/parsing-bool.t t/spec/S02-types/range.t t/spec/S02-types/sethash.t t/spec/S02-types/set.t t/spec/S02-types/sigils-and-types.t t/spec/S02-types/subscripts_and_context.t t/spec/S02-types/subset.t t/spec/S02-types/type.t t/spec/S02-types/undefined-types.t t/spec/S02-types/unicode.t t/spec/S02-types/version.t t/spec/S02-types/whatever.t t/spec/S03-binding/arrays.t t/spec/S03-binding/attributes.t t/spec/S03-binding/closure.t t/spec/S03-binding/hashes.t t/spec/S03-binding/nested.t t/spec/S03-binding/ro.t t/spec/S03-binding/scalars.t t/spec/S03-binding/subs.t t/spec/S03-feeds/basic.t t/spec/S03-junctions/associative.t t/spec/S03-junctions/autothreading.t t/spec/S03-junctions/boolean-context.t t/spec/S03-junctions/misc.t t/spec/S03-metaops/cross.t t/spec/S03-metaops/eager-hyper.t t/spec/S03-metaops/hyper.t t/spec/S03-metaops/not.t t/spec/S03-metaops/reduce.t t/spec/S03-metaops/reverse.t t/spec/S03-metaops/zip.t t/spec/S03-operators/adverbial-modifiers.t t/spec/S03-operators/also.t t/spec/S03-operators/andthen.t t/spec/S03-operators/arith.t t/spec/S03-operators/assign-is-not-binding.t t/spec/S03-operators/assign.t t/spec/S03-operators/autoincrement-range.t t/spec/S03-operators/autoincrement.t t/spec/S03-operators/autovivification.t t/spec/S03-operators/bag.t t/spec/S03-operators/basic-types.t t/spec/S03-operators/bit.t t/spec/S03-operators/boolean-bitwise.t t/spec/S03-operators/brainos.t t/spec/S03-operators/buf.t t/spec/S03-operators/chained-declarators.t t/spec/S03-operators/cmp.t t/spec/S03-operators/comparison-simple.t t/spec/S03-operators/comparison.t t/spec/S03-operators/context-forcers.t t/spec/S03-operators/context.t t/spec/S03-operators/div.t t/spec/S03-operators/equality.t t/spec/S03-operators/eqv.t t/spec/S03-operators/fiddly.t t/spec/S03-operators/flip-flop.t t/spec/S03-operators/gcd.t t/spec/S03-operators/identity.t t/spec/S03-operators/increment.t t/spec/S03-operators/infixed-function.t t/spec/S03-operators/inplace.t t/spec/S03-operators/is-divisible-by.t t/spec/S03-operators/lcm.t t/spec/S03-operators/list-quote-junction.t t/spec/S03-operators/minmax.t t/spec/S03-operators/misc.t t/spec/S03-operators/names.t t/spec/S03-operators/nesting.t t/spec/S03-operators/not.t t/spec/S03-operators/numeric-shift.t t/spec/S03-operators/overflow.t t/spec/S03-operators/precedence.t t/spec/S03-operators/range-basic.t t/spec/S03-operators/range-int.t t/spec/S03-operators/range.t t/spec/S03-operators/reduce-le1arg.t t/spec/S03-operators/relational.t t/spec/S03-operators/repeat.t t/spec/S03-operators/scalar-assign.t t/spec/S03-operators/set.t t/spec/S03-operators/short-circuit.t t/spec/S03-operators/shortcuts.t t/spec/S03-operators/so.t t/spec/S03-operators/spaceship-and-containers.t t/spec/S03-operators/spaceship.t t/spec/S03-operators/subscript-adverbs.t t/spec/S03-operators/subscript-vs-lt.t t/spec/S03-operators/ternary.t t/spec/S03-operators/value_equivalence.t t/spec/S03-sequence/arity0.t t/spec/S03-sequence/arity-2-or-more.t t/spec/S03-sequence/basic.t t/spec/S03-sequence/limit-arity-2-or-more.t t/spec/S03-sequence/misc.t t/spec/S03-sequence/nonnumeric.t t/spec/S03-smartmatch/any-any.t t/spec/S03-smartmatch/any-array.t t/spec/S03-smartmatch/any-bool.t t/spec/S03-smartmatch/any-callable.t t/spec/S03-smartmatch/any-complex.t t/spec/S03-smartmatch/any-hash-pair.t t/spec/S03-smartmatch/any-method.t t/spec/S03-smartmatch/any-num.t t/spec/S03-smartmatch/any-pair.t t/spec/S03-smartmatch/any-str.t t/spec/S03-smartmatch/any-sub.t t/spec/S03-smartmatch/any-type.t t/spec/S03-smartmatch/array-array.t t/spec/S03-smartmatch/array-hash.t t/spec/S03-smartmatch/capture-signature.t t/spec/S03-smartmatch/disorganized.t t/spec/S03-smartmatch/hash-hash.t t/spec/S03-smartmatch/range-range.t t/spec/S03-smartmatch/regex-hash.t t/spec/S03-smartmatch/scalar-hash.t t/spec/S03-smartmatch/signature-signature.t t/spec/S04-blocks-and-statements/let.t t/spec/S04-blocks-and-statements/pointy-rw.t t/spec/S04-blocks-and-statements/pointy.t t/spec/S04-blocks-and-statements/temp.t t/spec/S04-declarations/constant.t t/spec/S04-declarations/implicit-parameter.t t/spec/S04-declarations/multiple.t t/spec/S04-declarations/my.t t/spec/S04-declarations/our.t t/spec/S04-declarations/state.t t/spec/S04-declarations/will.t t/spec/S04-exception-handlers/catch.t t/spec/S04-exceptions/control_across_runloop.t t/spec/S04-exceptions/fail.t t/spec/S04-exceptions/pending.t t/spec/S04-phasers/ascending-order.t t/spec/S04-phasers/begin.t t/spec/S04-phasers/check.t t/spec/S04-phasers/descending-order.t t/spec/S04-phasers/end.t t/spec/S04-phasers/enter-leave.t t/spec/S04-phasers/eval-in-begin.t t/spec/S04-phasers/exit-in-begin.t t/spec/S04-phasers/exit-in-check.t t/spec/S04-phasers/first.t t/spec/S04-phasers/in-eval.t t/spec/S04-phasers/init.t t/spec/S04-phasers/in-loop.t t/spec/S04-phasers/interpolate.t t/spec/S04-phasers/keep-undo.t t/spec/S04-phasers/multiple.t t/spec/S04-phasers/next.t t/spec/S04-phasers/pre-post.t t/spec/S04-phasers/rvalue.t t/spec/S04-statement-modifiers/for.t t/spec/S04-statement-modifiers/given.t t/spec/S04-statement-modifiers/if.t t/spec/S04-statement-modifiers/unless.t t/spec/S04-statement-modifiers/until.t t/spec/S04-statement-modifiers/values_in_bool_context.t t/spec/S04-statement-modifiers/while.t t/spec/S04-statement-parsing/hash.t t/spec/S04-statements/do.t t/spec/S04-statements/for-scope.t t/spec/S04-statements/for.t t/spec/S04-statements/for_with_only_one_item.t t/spec/S04-statements/gather.t t/spec/S04-statements/given.t t/spec/S04-statements/goto.t t/spec/S04-statements/if.t t/spec/S04-statements/last.t t/spec/S04-statements/lazy.t t/spec/S04-statements/leave.t t/spec/S04-statements/lift.t t/spec/S04-statements/loop.t t/spec/S04-statements/map-and-sort-in-for.t t/spec/S04-statements/next.t t/spec/S04-statements/no-implicit-block.t t/spec/S04-statements/once.t t/spec/S04-statements/quietly.t t/spec/S04-statements/redo.t t/spec/S04-statements/repeat.t t/spec/S04-statements/return.t t/spec/S04-statements/sink.t t/spec/S04-statements/terminator.t t/spec/S04-statements/try.t t/spec/S04-statements/unless.t t/spec/S04-statements/until.t t/spec/S04-statements/while.t t/spec/S05-capture/alias.t t/spec/S05-capture/array-alias.t t/spec/S05-capture/caps.t t/spec/S05-capture/dot.t t/spec/S05-capture/external-aliasing.t t/spec/S05-capture/hash.t t/spec/S05-capture/match-object.t t/spec/S05-capture/named.t t/spec/S05-capture/subrule.t t/spec/S05-grammar/action-stubs.t t/spec/S05-grammar/example.t t/spec/S05-grammar/inheritance.t t/spec/S05-grammar/methods.t t/spec/S05-grammar/namespace.t t/spec/S05-grammar/parse_and_parsefile.t t/spec/S05-grammar/polymorphism.t t/spec/S05-grammar/protoregex.t t/spec/S05-grammar/protos.t t/spec/S05-grammar/signatures.t t/spec/S05-grammar/std.t t/spec/S05-grammar/ws.t t/spec/S05-interpolation/lexicals.t t/spec/S05-interpolation/regex-in-variable.t t/spec/S05-mass/charsets.t t/spec/S05-mass/named-chars.t t/spec/S05-mass/properties-block.t t/spec/S05-mass/properties-derived.t t/spec/S05-mass/properties-general.t t/spec/S05-mass/properties-script.t t/spec/S05-mass/recursive.t t/spec/S05-mass/rx.t t/spec/S05-mass/stdrules.t t/spec/S05-match/arrayhash.t t/spec/S05-match/blocks.t t/spec/S05-match/capturing-contexts.t t/spec/S05-match/make.t t/spec/S05-match/non-capturing.t t/spec/S05-match/perl.t t/spec/S05-match/positions.t t/spec/S05-metachars/closure.t t/spec/S05-metachars/line-anchors.t t/spec/S05-metachars/newline.t t/spec/S05-metachars/tilde.t t/spec/S05-metasyntax/angle-brackets.t t/spec/S05-metasyntax/assertions.t t/spec/S05-metasyntax/changed.t t/spec/S05-metasyntax/charset.t t/spec/S05-metasyntax/combchar.t t/spec/S05-metasyntax/delimiters.t t/spec/S05-metasyntax/interpolating-closure.t t/spec/S05-metasyntax/litvar.t t/spec/S05-metasyntax/longest-alternative.t t/spec/S05-metasyntax/lookaround.t t/spec/S05-metasyntax/null.t t/spec/S05-metasyntax/prior.t t/spec/S05-metasyntax/proto-token-ltm.t t/spec/S05-metasyntax/regex.t t/spec/S05-metasyntax/repeat.t t/spec/S05-metasyntax/sequential-alternation.t t/spec/S05-metasyntax/single-quotes.t t/spec/S05-metasyntax/unknown.t t/spec/S05-modifier/continue.t t/spec/S05-modifier/counted-match.t t/spec/S05-modifier/counted.t t/spec/S05-modifier/exhaustive.t t/spec/S05-modifier/global.t t/spec/S05-modifier/ignorecase.t t/spec/S05-modifier/ignoremark.t t/spec/S05-modifier/ii.t t/spec/S05-modifier/my.t t/spec/S05-modifier/overlapping.t t/spec/S05-modifier/perl5_0.t t/spec/S05-modifier/perl5_1.t t/spec/S05-modifier/perl5_2.t t/spec/S05-modifier/perl5_3.t t/spec/S05-modifier/perl5_4.t t/spec/S05-modifier/perl5_5.t t/spec/S05-modifier/perl5_6.t t/spec/S05-modifier/perl5_7.t t/spec/S05-modifier/perl5_8.t t/spec/S05-modifier/perl5_9.t t/spec/S05-modifier/pos.t t/spec/S05-modifier/ratchet.t t/spec/S05-modifier/repetition-exhaustive.t t/spec/S05-modifier/repetition.t t/spec/S05-modifier/samemark.t t/spec/S05-modifier/sigspace.t t/spec/S05-nonstrings/basic.t t/spec/S05-substitution/match.t t/spec/S05-substitution/subst.t t/spec/S05-syntactic-categories/new-symbols.t t/spec/S05-transliteration/79778.t t/spec/S05-transliteration/trans.t t/spec/S05-transliteration/with-closure.t t/spec/S06-advanced/caller.t t/spec/S06-advanced/callframe.t t/spec/S06-advanced/callsame.t t/spec/S06-advanced/lexical-subs.t t/spec/S06-advanced/recurse.t t/spec/S06-advanced/return_function.t t/spec/S06-advanced/return.t t/spec/S06-advanced/stub.t t/spec/S06-advanced/wrap.t t/spec/S06-currying/assuming-and-mmd.t t/spec/S06-currying/mixed.t t/spec/S06-currying/named.t t/spec/S06-macros/errors.t t/spec/S06-macros/opaque-ast.t t/spec/S06-macros/postfix.t t/spec/S06-macros/quasi-blocks.t t/spec/S06-macros/returning-closure.t t/spec/S06-macros/returning-string.t t/spec/S06-macros/unquoting.t t/spec/S06-multi/by-trait.t t/spec/S06-multi/lexical-multis.t t/spec/S06-multi/positional-vs-named.t t/spec/S06-multi/proto.t t/spec/S06-multi/redispatch.t t/spec/S06-multi/syntax.t t/spec/S06-multi/type-based.t t/spec/S06-multi/unpackability.t t/spec/S06-multi/value-based.t t/spec/S06-operator-overloading/imported-subs.t t/spec/S06-operator-overloading/methods.t t/spec/S06-operator-overloading/semicolon.t t/spec/S06-operator-overloading/sub.t t/spec/S06-operator-overloading/workout.t t/spec/S06-other/anon-hashes-vs-blocks.t t/spec/S06-other/introspection.t t/spec/S06-other/main-eval.t t/spec/S06-other/main.t t/spec/S06-other/main-usage.t t/spec/S06-other/misc.t t/spec/S06-other/pairs-as-lvalues.t t/spec/S06-routine-modifiers/lvalue-subroutines.t t/spec/S06-routine-modifiers/proxy.t t/spec/S06-routine-modifiers/scoped-named-subs.t t/spec/S06-signature/arity.t t/spec/S06-signature/caller-param.t t/spec/S06-signature/closure-over-parameters.t t/spec/S06-signature/closure-parameters.t t/spec/S06-signature/code.t t/spec/S06-signature/defaults.t t/spec/S06-signature/errors.t t/spec/S06-signature/introspection.t t/spec/S06-signature/mixed-placeholders.t t/spec/S06-signature/multidimensional.t t/spec/S06-signature/multiple-signatures.t t/spec/S06-signature/named-parameters.t t/spec/S06-signature/named-placeholders.t t/spec/S06-signature/named-renaming.t t/spec/S06-signature/optional.t t/spec/S06-signature/outside-subroutine.t t/spec/S06-signature/passing-arrays.t t/spec/S06-signature/passing-hashes.t t/spec/S06-signature/positional-placeholders.t t/spec/S06-signature/positional.t t/spec/S06-signature/scalar-type.t t/spec/S06-signature/sigilless.t t/spec/S06-signature/slurpy-and-interpolation.t t/spec/S06-signature/slurpy-blocks.t t/spec/S06-signature/slurpy-params.t t/spec/S06-signature/slurpy-placeholders.t t/spec/S06-signature/sub-ref.t t/spec/S06-signature/tree-node-parameters.t t/spec/S06-signature/type-capture.t t/spec/S06-signature/types.t t/spec/S06-signature/unpack-array.t t/spec/S06-signature/unpack-object.t t/spec/S06-signature/unspecified.t t/spec/S06-traits/as.t t/spec/S06-traits/is-assoc.t t/spec/S06-traits/is-copy.t t/spec/S06-traits/is-readonly.t t/spec/S06-traits/is-rw.t t/spec/S06-traits/misc.t t/spec/S06-traits/precedence.t t/spec/S06-traits/slurpy-is-rw.t t/spec/S07-iterators/range-iterator.t t/spec/S09-autovivification/autoincrement.t t/spec/S09-autovivification/autovivification.t t/spec/S09-hashes/objecthash.t t/spec/S09-subscript/slice.t t/spec/S09-typed-arrays/arrays.t t/spec/S09-typed-arrays/hashes.t t/spec/S10-packages/basic.t t/spec/S10-packages/export.t t/spec/S10-packages/joined-namespaces.t t/spec/S10-packages/nested-use.t t/spec/S10-packages/README t/spec/S10-packages/require-and-use.t t/spec/S10-packages/scope.t t/spec/S10-packages/use-with-class.t t/spec/S11-modules/export.t t/spec/S11-modules/importing.t t/spec/S11-modules/import-multi.t t/spec/S11-modules/import.t t/spec/S11-modules/import-tag.t t/spec/S11-modules/InnerModule.pm t/spec/S11-modules/lexical.t t/spec/S11-modules/module-file.t t/spec/S11-modules/module.t t/spec/S11-modules/need.t t/spec/S11-modules/nested.t t/spec/S11-modules/OuterModule.pm t/spec/S11-modules/re-export.t t/spec/S11-modules/require.t t/spec/S11-modules/use-perl-6.t t/spec/S12-attributes/augment-and-initialization.t t/spec/S12-attributes/class.t t/spec/S12-attributes/clone.t t/spec/S12-attributes/defaults.t t/spec/S12-attributes/delegation.t t/spec/S12-attributes/inheritance.t t/spec/S12-attributes/instance.t t/spec/S12-attributes/mutators.t t/spec/S12-attributes/recursive.t t/spec/S12-attributes/trusts.t t/spec/S12-attributes/undeclared.t t/spec/S12-class/anonymous.t t/spec/S12-class/attributes.t t/spec/S12-class/augment-supersede.t t/spec/S12-class/basic.t t/spec/S12-class/declaration-order.t t/spec/S12-class/extending-arrays.t t/spec/S12-class/inheritance-class-methods.t t/spec/S12-class/inheritance.t t/spec/S12-class/instantiate.t t/spec/S12-class/interface-consistency.t t/spec/S12-class/lexical.t t/spec/S12-class/literal.t t/spec/S12-class/magical-vars.t t/spec/S12-class/mro.t t/spec/S12-class/namespaced.t t/spec/S12-class/open_closed.t t/spec/S12-class/open.t t/spec/S12-class/parent_attributes.t t/spec/S12-class/rw.t t/spec/S12-class/self-inheritance.t t/spec/S12-class/stubs.t t/spec/S12-class/type-object.t t/spec/S12-construction/autopairs.t t/spec/S12-construction/BUILD.t t/spec/S12-construction/construction.t t/spec/S12-construction/destruction.t t/spec/S12-construction/named-params-in-BUILD.t t/spec/S12-construction/new.t t/spec/S12-enums/anonymous.t t/spec/S12-enums/as-role.t t/spec/S12-enums/basic.t t/spec/S12-enums/misc.t t/spec/S12-enums/non-int.t t/spec/S12-enums/pseudo-functional.t t/spec/S12-enums/thorough.t t/spec/S12-introspection/attributes.t t/spec/S12-introspection/can.t t/spec/S12-introspection/definite.t t/spec/S12-introspection/meta-class.t t/spec/S12-introspection/methods.t t/spec/S12-introspection/parents.t t/spec/S12-introspection/roles.t t/spec/S12-introspection/walk.t t/spec/S12-introspection/WHAT.t t/spec/S12-methods/accessors.t t/spec/S12-methods/attribute-params.t t/spec/S12-methods/calling_sets.t t/spec/S12-methods/calling_syntax.t t/spec/S12-methods/chaining.t t/spec/S12-methods/class-and-instance.t t/spec/S12-methods/default-trait.t t/spec/S12-methods/defer-call.t t/spec/S12-methods/defer-next.t t/spec/S12-methods/delegation.t t/spec/S12-methods/how.t t/spec/S12-methods/indirect_notation.t t/spec/S12-methods/instance.t t/spec/S12-methods/lastcall.t t/spec/S12-methods/lvalue.t t/spec/S12-methods/method-vs-sub.t t/spec/S12-methods/multi.t t/spec/S12-methods/parallel-dispatch.t t/spec/S12-methods/private.t t/spec/S12-methods/qualified.t t/spec/S12-methods/submethods.t t/spec/S12-methods/syntax.t t/spec/S12-methods/topic.t t/spec/S12-methods/trusts.t t/spec/S12-methods/typed-attributes.t t/spec/S12-methods/what.t t/spec/S12-subset/multi-dispatch.t t/spec/S12-subset/subtypes.t t/spec/S12-traits/basic.t t/spec/S12-traits/parameterized.t t/spec/S13-overloading/fallbacks-deep.t t/spec/S13-overloading/metaoperators.t t/spec/S13-overloading/multiple-signatures.t t/spec/S13-overloading/operators.t t/spec/S13-overloading/typecasting-long.t t/spec/S13-overloading/typecasting-mixed.t t/spec/S13-overloading/typecasting-short.t t/spec/S13-syntax/aliasing.t t/spec/S13-type-casting/methods.t t/spec/S14-roles/anonymous.t t/spec/S14-roles/attributes.t t/spec/S14-roles/basic.t t/spec/S14-roles/bool.t t/spec/S14-roles/composition.t t/spec/S14-roles/conflicts.t t/spec/S14-roles/crony.t t/spec/S14-roles/instantiation.t t/spec/S14-roles/lexical.t t/spec/S14-roles/mixin.t t/spec/S14-roles/namespaced.t t/spec/S14-roles/parameterized-basic.t t/spec/S14-roles/parameterized-mixin.t t/spec/S14-roles/parameterized-type.t t/spec/S14-roles/parameter-subtyping.t t/spec/S14-roles/stubs.t t/spec/S14-roles/submethods.t t/spec/S14-traits/attributes.t t/spec/S14-traits/package.t t/spec/S14-traits/routines.t t/spec/S14-traits/variables.t t/spec/S15-strings/NFK-types.t t/spec/S15-strings/NF-types.t t/spec/S15-strings/Str.t t/spec/S16-filehandles/chmod.t t/spec/S16-filehandles/connect.t t/spec/S16-filehandles/dir.t t/spec/S16-filehandles/filestat.t t/spec/S16-filehandles/filetest.t t/spec/S16-filehandles/io_in_for_loops.t t/spec/S16-filehandles/io_in_while_loops.t t/spec/S16-filehandles/io.t t/spec/S16-filehandles/mkdir_rmdir.t t/spec/S16-filehandles/open.t t/spec/S16-filehandles/unlink.t t/spec/S16-io/bare-say.t t/spec/S16-io/basic-open.t t/spec/S16-io/cwd.t t/spec/S16-io/getc.t t/spec/S16-io/print.t t/spec/S16-io/quoting-syntax.t t/spec/S16-io/say-and-ref.t t/spec/S16-io/say.t t/spec/S16-io/test-data t/spec/S16-io/tmpdir.t t/spec/S16-unfiled/getpeername.t t/spec/S16-unfiled/rebindstdhandles.t t/spec/S17-async/async.t t/spec/S17-async/contend.t t/spec/S17-async/syntax.t t/spec/S17-concurrency/channel.t t/spec/S17-concurrency/lock.t t/spec/S17-concurrency/promise.t t/spec/S17-concurrency/scheduler.t t/spec/S17-concurrency/supply.t t/spec/S17-concurrency/thread.t t/spec/S17-concurrency/winner.t t/spec/S19-command-line/dash-e.t t/spec/S19-command-line/help.t t/spec/S19-command-line-options/01-dash-uppercase-i.t t/spec/S19-command-line-options/01-multiple-e.t t/spec/S19-command-line-options/02-dash-n.t t/spec/S19-command-line-options/03-dash-p.t t/spec/S24-testing/0-compile.t t/spec/S24-testing/1-basic.t t/spec/S24-testing/2-force_todo.t t/spec/S24-testing/3-output.t t/spec/S24-testing/3-script.pl t/spec/S24-testing/4-version_lt.t t/spec/S24-testing/5-todo.t t/spec/S24-testing/6-done_testing.t t/spec/S24-testing/use_ok_test.pm t/spec/S26-documentation/01-delimited.t t/spec/S26-documentation/02-paragraph.t t/spec/S26-documentation/03-abbreviated.t t/spec/S26-documentation/04-code.t t/spec/S26-documentation/05-comment.t t/spec/S26-documentation/06-lists.t t/spec/S26-documentation/07-tables.t t/spec/S26-documentation/08-formattingcodes.t t/spec/S26-documentation/09-configuration.t t/spec/S26-documentation/10-doc-cli.t t/spec/S26-documentation/why.t t/spec/S28-named-variables/cwd.t t/spec/S28-named-variables/inc.t t/spec/S28-named-variables/slangs.t t/spec/S29-any/cmp.t t/spec/S29-any/isa.t t/spec/S29-context/die.t t/spec/S29-context/evalfile.t t/spec/S29-context/eval.t t/spec/S29-context/exit-in-if.t t/spec/S29-context/exit.t t/spec/S29-context/sleep.t t/spec/S29-conversions/hash.t t/spec/S29-conversions/ord_and_chr.t t/spec/S29-os/system.t t/spec/S29-type/declarations.t t/spec/S32-array/bool.t t/spec/S32-array/create.t t/spec/S32-array/delete-adverb-native.t t/spec/S32-array/delete-adverb.t t/spec/S32-array/delete.t t/spec/S32-array/elems.t t/spec/S32-array/end.t t/spec/S32-array/exists-adverb.t t/spec/S32-array/keys_values.t t/spec/S32-array/kv.t t/spec/S32-array/pairs.t t/spec/S32-array/perl.t t/spec/S32-array/pop.t t/spec/S32-array/push.t t/spec/S32-array/rotate.t t/spec/S32-array/shift.t t/spec/S32-array/splice.t t/spec/S32-array/unshift.t t/spec/S32-basics/warn.t t/spec/S32-container/cat.t t/spec/S32-container/roundrobin.t t/spec/S32-container/stringify.t t/spec/S32-container/zip.t t/spec/S32-exceptions/misc.t t/spec/S32-hash/delete-adverb.t t/spec/S32-hash/delete.t t/spec/S32-hash/exists-adverb.t t/spec/S32-hash/exists.t t/spec/S32-hash/invert.t t/spec/S32-hash/keys_values.t t/spec/S32-hash/kv.t t/spec/S32-hash/pairs.t t/spec/S32-hash/perl.t t/spec/S32-hash/push.t t/spec/S32-hash/slice.t t/spec/S32-io/chdir.t t/spec/S32-io/copy.t t/spec/S32-io/dir.t t/spec/S32-io/empty.txt t/spec/S32-io/file-tests.t t/spec/S32-io/io-handle.t t/spec/S32-io/io-path-cygwin.t t/spec/S32-io/io-path.t t/spec/S32-io/io-path-unix.t t/spec/S32-io/io-path-win.t t/spec/S32-io/IO-Socket-INET.bat t/spec/S32-io/IO-Socket-INET.pl t/spec/S32-io/IO-Socket-INET.sh t/spec/S32-io/IO-Socket-INET.t t/spec/S32-io/io-spec-cygwin.t t/spec/S32-io/io-spec-unix.t t/spec/S32-io/io-spec-win.t t/spec/S32-io/mkdir_rmdir.t t/spec/S32-io/note.t t/spec/S32-io/other.t t/spec/S32-io/path.t t/spec/S32-io/pi.txt t/spec/S32-io/slurp.t t/spec/S32-io/socket-test.bin t/spec/S32-io/spurt.t t/spec/S32-list/categorize.t t/spec/S32-list/classify.t t/spec/S32-list/combinations.t t/spec/S32-list/create.t t/spec/S32-list/end.t t/spec/S32-list/first.t t/spec/S32-list/grep.t t/spec/S32-list/join.t t/spec/S32-list/map_function_return_values.t t/spec/S32-list/map.t t/spec/S32-list/minmax.t t/spec/S32-list/numbers.data t/spec/S32-list/pick.t t/spec/S32-list/reduce.t t/spec/S32-list/reverse.t t/spec/S32-list/roll.t t/spec/S32-list/sort.t t/spec/S32-list/squish.t t/spec/S32-list/uniq.t t/spec/S32-num/abs.t t/spec/S32-num/base.t t/spec/S32-num/complex.t t/spec/S32-num/cool-num.t t/spec/S32-num/expmod.t t/spec/S32-num/exp.t t/spec/S32-num/fatrat.t t/spec/S32-num/int.t t/spec/S32-num/is-prime.t t/spec/S32-num/log.t t/spec/S32-num/pi.t t/spec/S32-num/polar.t t/spec/S32-num/power.t t/spec/S32-num/rand.t t/spec/S32-num/rat.t t/spec/S32-num/real-bridge.t t/spec/S32-num/roots.t t/spec/S32-num/rounders.t t/spec/S32-num/rshift_pos_amount.t t/spec/S32-num/sign.t t/spec/S32-num/sqrt.t t/spec/S32-num/stringify.t t/spec/S32-num/unpolar.t t/spec/S32-scalar/defined.t t/spec/S32-scalar/perl.t t/spec/S32-scalar/undef.t t/spec/S32-str/append.t t/spec/S32-str/bool.t t/spec/S32-str/capitalize.t t/spec/S32-str/chomp.t t/spec/S32-str/chop.t t/spec/S32-str/comb.t t/spec/S32-str/encode.t t/spec/S32-str/flip.t t/spec/S32-str/indent.t t/spec/S32-str/index.t t/spec/S32-str/lc.t t/spec/S32-str/length.t t/spec/S32-str/lines.t t/spec/S32-str/numeric.t t/spec/S32-str/ords.t t/spec/S32-str/pack.t t/spec/S32-str/pos.t t/spec/S32-str/quotemeta.t t/spec/S32-str/rindex.t t/spec/S32-str/sameaccent.t t/spec/S32-str/samecase.t t/spec/S32-str/split-simple.t t/spec/S32-str/split.t t/spec/S32-str/sprintf.t t/spec/S32-str/substr-rw.t t/spec/S32-str/substr.t t/spec/S32-str/tclc.t t/spec/S32-str/tc.t t/spec/S32-str/trim.t t/spec/S32-str/uc.t t/spec/S32-str/unpack.t t/spec/S32-str/words.t t/spec/S32-temporal/calendar.t t/spec/S32-temporal/Date.t t/spec/S32-temporal/DateTime-Instant-Duration.t t/spec/S32-temporal/DateTime.t t/spec/S32-temporal/local.t t/spec/S32-temporal/time.t t/spec/S32-trig/atan2.t t/spec/S32-trig/cosech.t t/spec/S32-trig/cosec.t t/spec/S32-trig/cosh.t t/spec/S32-trig/cos.t t/spec/S32-trig/cotanh.t t/spec/S32-trig/cotan.t t/spec/S32-trig/e.t t/spec/S32-trig/generate-tests.pl t/spec/S32-trig/pi.t t/spec/S32-trig/sech.t t/spec/S32-trig/sec.t t/spec/S32-trig/simple.t t/spec/S32-trig/sinh.t t/spec/S32-trig/sin.t t/spec/S32-trig/tanh.t t/spec/S32-trig/tan.t t/spec/S32-trig/trig_functions t/spec/S32-trig/TrigTestSupport t/spectest.data t/spec/test_summary t/spec/TODO VERSION rakudo-2013.12/README0000664000175000017500000001152512242026101013455 0ustar moritzmoritzRakudo Perl 6 This is Rakudo Perl, a Perl 6 compiler for the Parrot virtual machine. Rakudo Perl is Copyright (C) 2008-2013, The Perl Foundation. Rakudo Perl is distributed under the terms of the Artistic License 2.0. For more details, see the full text of the license in the file LICENSE. This directory contains only the Rakudo Perl 6 compiler itself; it does not contain any of the modules, documentation, or other items that would normally come with a full Perl 6 distribution. If you're after more than just the bare compiler, please download the latest Rakudo Star package from http://rakudo.org/downloads/star . For a high-level overview of implemented and missing features, please visit http://perl6.org/compilers/features . Building Rakudo on Parrot See the INSTALL.txt file for detailed prerequisites and build and installation instructions. The short version is $ # recommended: install libicu-dev and libreadline-dev packages $ perl Configure.pl --gen-parrot --backends=parrot $ make $ make spectest # optional $ make install # IMPORTANT, installs to install/bin/perl6 Note that the 'make install' step is necessary for running Rakudo from outside the build directory. But don't worry, it installs locally by default, so you don't need any administrator privileges for carrying out this step. Building Rakudo on JVM You need the JDK 1.7 installed and a make program. These instructions will fetch an appropriate revision of nqp, build it, and then build rakudo on the jvm. $ perl Configure.pl --gen-nqp --backends=jvm $ make Note that Rakudo on JVM implements a slightly different set of features than Rakudo on Parrot. If you get an out of memory error building rakudo on the JVM, you may need to modify your NQP runner to limit memory use. e.g. Adding -Xms500m -Xmx2g as options passed to java in the installed nqp / nqp.bat. Where to get help or answers to questions There are several mailing lists, IRC channels, and wikis available with help for Perl 6 and Rakudo on Parrot. Figuring out the right one to use is often the biggest battle. Here are some rough guidelines: The central hub for Perl 6 information is http://perl6.org/ . This is always a good starting point. If you have a question about Perl 6 syntax or the right way to approach a problem using Perl 6, you probably want the "perl6-users@perl.org" mailing list or the "irc.freenode.net/#perl6" channel. The perl6-users list is primarily for the people who want to use Perl 6 to write programs, so newbie questions are welcomed there. Newbie questions are also welcome on the #perl6 channel; the Rakudo and Perl 6 development teams tend to hang out there and are generally glad to help. You can follow "@rakudoperl" on Twitter, and there's a Perl 6 news aggregator at . Questions about NQP can also be posted to the #perl6 IRC channel. For questions about Parrot, see for links and resources, or join the #parrot IRC channel on irc.perl.org . Reporting bugs Bug reports should be sent to "rakudobug@perl.org" with the moniker [BUG] (including the brackets) at the start of the subject so that it gets appropriately tagged in the RT system (https://rt.perl.org/rt3/). Please include or attach any sample source code that exhibits the bug, and include either the release name/date or the git commit identifier. You find that information in the output from "perl6 --version" (or in the first line of "git log", if Rakudo fails to build). There's no need to cc: the perl6-compiler mailing list, as the RT system will handle this on its own. Submitting patches If you have a patch that fixes a bug or adds a new feature, please submit it to "rakudobug@perl.org" with the moniker [PATCH] (including the brackets) at the start of the subject line. We'll generally accept patches in any form if we can get them to work, but unified diff from the "git" command is greatly preferred. In general this means that in the "rakudo" directory you make your changes, and then type git commit -m 'Your commit message' changed/filename.pm git format-patch HEAD^ This will generate a file called "001-your-commit-message.patch", or more of them if you made multiple commits; please attach these to your email. (Note to the maintainers: you can apply these patches with the "git-am -s" command; it preserves meta information like author). How the compiler works See docs/compiler_overview.pod. AUTHOR Patrick Michaud "pmichaud@pobox.com" is the current pumpking for Rakudo Perl 6. See CREDITS for the many people that have contributed to the development of the Rakudo compiler. rakudo-2013.12/src/core/Any.pm0000664000175000017500000006726512255230273015430 0ustar moritzmoritzmy class MapIter { ... } my class Pair { ... } my class Range { ... } my class X::Bind::Slice { ... } my class X::Bind::ZenSlice { ... } my class Any { # declared in BOOTSTRAP # my class Any is Mu { multi method ACCEPTS(Any:D: Mu \a) { self === a } # primitives method infinite() { Nil } method exists (Any:U: $key) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); False; } method exists_key(Any:U: $key) { False } method exists_pos(Any:U: $pos) { False } method delete (Any:U: $key) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); Nil; } proto method delete_key(|) { * } multi method delete_key(Any:U: $key) { Nil } multi method delete_key(Any:D: $key) { fail "Can not remove values from a {self.^name}"; } proto method delete_pos(|) { * } multi method delete_pos(Any:U: $pos) { Nil } multi method delete_pos(Any:D: $pos) { fail "Can not remove elements from a {self.^name}"; } method list() { nqp::p6list( self.DEFINITE ?? nqp::list(self) !! nqp::list(), List, Mu ); } method flat() { nqp::p6list( self.DEFINITE ?? nqp::list(self) !! nqp::list(), List, Bool::True ); } method eager() { nqp::p6list( self.DEFINITE ?? nqp::list(self) !! nqp::list(), List, Bool::True ).eager; } method hash() { my % = self.DEFINITE ?? self !! (); } # derived from .list method elems() { self.list.elems } method end() { self.list.end } method uniq(|c) { self.list.uniq(|c) } method squish(|c) { self.list.squish(|c) } method pick($n = 1) { self.list.pick($n) } method roll($n = 1) { self.list.roll($n) } method reverse() { self.list.reverse } method sort($by = &infix:) { self.list.sort($by) } method values() { self.list } method keys() { self.list.keys } method kv() { self.list.kv } method pairs() { self.list.pairs } method reduce(&with) { self.list.reduce(&with) } proto method classify(|) { * } multi method classify($test) { {}.classify-list( $test, self.list ); } multi method classify($test, :$into!) { ( $into // $into.new ).classify-list( $test, self.list ); } proto method categorize(|) { * } multi method categorize($test) { {}.categorize-list( $test, self.list ); } multi method categorize($test, :$into!) { ( $into // $into.new ).categorize-list( $test, self.list ); } # derived from MapIter/list method lol() { MapIter.new(self.list, { .item }, Mu).list } method map($block) is rw { MapIter.new(self, $block, Bool::True).list } proto method tree(|) { * } multi method tree(Any:U:) { self } multi method tree(Any:D:) { self.lol } multi method tree(Any:D: Cool $count as Int) { $count > 1 ?? MapIter.new(self.list, { .tree($count-1).item }, Mu).list !! $count == 1 ?? self.lol !! self } multi method tree(Any:D: &c) { MapIter.new(self.list, { .&c.item }, Mu).list } method Array() { Array.new(self.flat) } # auto-vivifying proto method push(|) { * } multi method push(Any:U \SELF: *@values) { &infix:<=>(SELF, Array.new); SELF.push(@values); } proto method unshift(|) { * } multi method unshift(Any:U \SELF: *@values) { &infix:<=>(SELF, Array.new); SELF.unshift(@values); } method grep(Mu $test) is rw { self.map({ $_ if $_ ~~ $test }); } method first(Mu $test) is rw { my @results := self.grep($test); @results ?? @results[0] !! Nil; } method join($separator = '') { my $list = (self,).flat.eager; my Mu $rsa := nqp::list_s(); $list.gimme(4); # force reification of at least 4 elements unless $list.infinite { # presize array nqp::setelems($rsa, nqp::unbox_i($list.elems)); nqp::setelems($rsa, 0); } my $tmp; while $list.gimme(0) { $tmp := $list.shift; nqp::push_s($rsa, nqp::unbox_s(nqp::istype($tmp, Str) ?? $tmp !! $tmp.Str)); } nqp::push_s($rsa, '...') if $list.infinite; nqp::p6box_s(nqp::join(nqp::unbox_s($separator.Str), $rsa)) } method min($by = &infix:) { my $cmp = $by.arity == 2 ?? $by !! { $by($^a) cmp $by($^b) } my $min; for self { $min = $_ if .defined and !$min.defined || $cmp($_, $min) < 0; } $min // +$Inf; } method max($by = &infix:) { my $cmp = $by.arity == 2 ?? $by !! { $by($^a) cmp $by($^b) } my $max; for self { $max = $_ if .defined and !$max.defined || $cmp($_, $max) > 0; } $max // -$Inf; } method minmax($by = &infix:) { my $cmp = $by.arity == 2 ?? $by !! { $by($^a) cmp $by($^b) }; my $min; my $max; my $excludes_min = Bool::False; my $excludes_max = Bool::False; for @.list { .defined or next; if .isa(Range) { if !$min.defined || $cmp($_.min, $min) < 0 { $min = $_; $excludes_min = $_.excludes_min; } if !$max.defined || $cmp($_.max, $max) > 0 { $max = $_; $excludes_max = $_.excludes_max; } } else { if !$min.defined || $cmp($_, $min) < 0 { $min = $_; $excludes_min = Bool::False; } if !$max.defined || $cmp($_, $max) > 0 { $max = $_; $excludes_max = Bool::False; } } } Range.new($min // +$Inf, $max // -$Inf, :excludes_min($excludes_min), :excludes_max($excludes_max)); } proto method at_pos(|) {*} multi method at_pos(Any:D: $pos) { fail X::OutOfRange.new( what => 'Index', got => $pos, range => (0..0) ) if $pos != 0; self; } multi method at_pos(Any:U \SELF: $pos) is rw { nqp::bindattr(my $v, Scalar, '$!whence', -> { SELF.defined || &infix:<=>(SELF, Array.new); SELF.bind_pos($pos, $v) }); $v } method all() { all(self.list) } method any() { any(self.list) } method one() { one(self.list) } method none() { none(self.list) } # internals proto method at_key(|) { * } multi method at_key(Any:D: $key) { fail "postcircumfix:<\{ \}> not defined for type {self.WHAT.perl}"; } multi method at_key(Any:U \SELF: $key) is rw { nqp::bindattr(my $v, Scalar, '$!whence', -> { SELF.defined || &infix:<=>(SELF, Hash.new); SELF.bind_key($key, $v) }); $v } proto method bind_key(|) { * } multi method bind_key(Any:D: $key, $BIND ) { fail "postcircumfix:<\{ \}> binding not defined for type {self.WHAT.perl}"; } multi method bind_key(Any:U \SELF: $key, $BIND ) is rw { &infix:<=>(SELF, Hash.new); SELF.bind_key($key, $BIND); $BIND } method FLATTENABLE_LIST() { my $list := self.list; nqp::findmethod($list, 'FLATTENABLE_LIST')($list); } method FLATTENABLE_HASH() { nqp::hash() } method Set() { Set.new-fp(self.list) } method SetHash() { SetHash.new-fp(self.list) } method Bag() { Bag.new-fp(self.list) } method BagHash() { BagHash.new-fp(self.list) } method Mix() { Mix.new-fp(self.list) } method MixHash() { MixHash.new-fp(self.list) } method KeySet() { DEPRECATED("'SetHash'"); self.SetHash } method KeyBag() { DEPRECATED("'BagHash'"); self.BagHash } } Metamodel::ClassHOW.exclude_parent(Any); # builtin ops proto infix:<===>($?, $?) is pure { * } multi infix:<===>($a?) { Bool::True } multi infix:<===>($a, $b) { nqp::p6bool(nqp::iseq_s(nqp::unbox_s($a.WHICH), nqp::unbox_s($b.WHICH))) } proto infix:($, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { (a cmp b) < 0 } proto infix:($, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { (a cmp b) > 0 } # XXX: should really be '$a is rw' (no \) in the next four operators proto prefix:<++>(|) { * } multi prefix:<++>(Mu:D \a is rw) { a = a.succ } multi prefix:<++>(Mu:U \a is rw) { a = 1 } proto prefix:<-->(|) { * } multi prefix:<-->(Mu:D \a is rw) { a = a.pred } multi prefix:<-->(Mu:U \a is rw) { a = -1 } proto postfix:<++>(|) { * } multi postfix:<++>(Mu:D \a is rw) { my $b = a; a = a.succ; $b } multi postfix:<++>(Mu:U \a is rw) { a = 1; 0 } proto postfix:<-->(|) { * } multi postfix:<-->(Mu:D \a is rw) { my $b = a; a = a.pred; $b } multi postfix:<-->(Mu:U \a is rw) { a = -1; 0 } # builtins proto infix:(|) is pure { * } multi infix:(*@args) { @args.min } # XXX the multi version suffers from a multi dispatch bug # where the mandatory named is ignored in the presence of a slurpy #proto sub min(|) { * } #multi sub min(*@args) { @args.min() } #multi sub min(*@args, :&by!) { @args.min(&by) } sub min(*@args, :&by = &infix:) { @args.min(&by) } proto infix:(|) is pure { * } multi infix:(*@args) { @args.max } #proto sub max(|) { * } #multi sub max(*@args) { @args.max() } #multi sub max(*@args, :&by!) { @args.max(&by) } sub max(*@args, :&by = &infix:) { @args.max(&by) } proto infix:(|) is pure { * } multi infix:(*@args) { @args.minmax } #proto sub minmax(|) { * } #multi sub minmax(*@args) { @args.minmax() } #multi sub minmax(*@args, :&by!) { @args.minmax(&by) } sub minmax(*@args, :&by = &infix:) { @args.minmax(&by) } proto map(|) {*} multi map(&code, *@values) { @values.map(&code) } multi map(&code, Whatever) { (1..Inf).map(&code) } proto grep(|) {*} multi grep(Mu $test, *@values) { @values.grep($test) } proto first(|) {*} multi first(Mu $test, *@values) { @values.first($test) } proto join(|) { * } multi join($sep = '', *@values) { @values.join($sep) } proto pick(|) { * } multi pick($n, *@values) { @values.pick($n) } proto roll(|) { * } multi roll($n, *@values) { @values.roll($n) } proto keys(|) { * } multi keys($x) { $x.keys } proto values(|) { * } multi values($x) { $x.values } proto pairs(|) { * } multi pairs($x) { $x.pairs } proto kv(|) { * } multi kv($x) { $x.kv } proto elems(|) { * } multi elems($a) { $a.elems } proto end(|) { * } multi end($a) { $a.end } proto classify(|) { * } multi classify( $test, *@items ) { {}.classify-list( $test, @items ) } #multi classify( $test, *@items, :$into! ) { # problem in MMD # ( $into // $into.new).classify-list( $test, @items ); #} proto categorize(|) { * } multi categorize( $test, *@items ) { {}.categorize-list( $test, @items ) } #multi categorize( $test, *@items, :$into! ) { # problem in MMD # ( $into // $into.new).categorize-list( $test, @items ); #} proto uniq(|) { * } multi uniq(*@values, |c) { @values.uniq(|c) } proto squish(|) { * } multi squish(*@values, |c) { @values.squish(|c) } proto sub sort(|) {*} multi sub sort(*@values) { @values.at_pos(0).^does(Callable) ?? do { my $cmp := @values.shift; @values.sort($cmp) } !! @values.sort; } proto sub item(|) is pure { * } multi sub item(*@a) { my $ = @a } multi sub item(Mu $a) { $a } my $default= []; # so that we can check missing parameters sub RWPAIR(\k, \v) { # internal fast pair creation my \p := nqp::create(Pair); nqp::bindattr(p, Enum, '$!key', k); nqp::bindattr(p, Enum, '$!value', v); p } sub OBJECT_HUH (\SELF) { my $huh = SELF.WHAT.perl; try { $huh ~= " {SELF.VAR.name}" }; $huh; } sub SLICE_HUH ( \SELF, @nogo, %a, %adv ) is hidden_from_backtrace { @nogo.unshift('delete') # recover any :delete if necessary if @nogo && @nogo[0] ne 'delete' && %adv.exists_key('delete'); @nogo.push( %a:delete:k ); # all valid params if %a.elems { %a.elems > 1 ?? fail "{%a.elems} unexpected named parameters ({%a.keys.join(', ')}) passed to {OBJECT_HUH(SELF)}" !! fail "Unexpected named parameter '{%a.keys}' passed to {OBJECT_HUH(SELF)}"; } else { fail "Unsupported combination of named parameters ({@nogo.join(', ')}) passed to {OBJECT_HUH(SELF)}"; } } #SLICE_HUH # internal 1 element hash/array access with adverbs sub SLICE_ONE ( \SELF, $one, $array, *%adv ) is hidden_from_backtrace { fail "Cannot use negative index $one on {SELF.WHAT.perl}" if $array && $one < 0; my $ex = SELF.can( $array ?? 'exists_pos' !! 'exists_key' )[0]; my %a = %adv.clone; my @nogo; my \result = do { if %a.delete_key('delete') { # :delete:* my $de = SELF.can( $array ?? 'delete_pos' !! 'delete_key' )[0]; if %a.delete_key('SINK') { # :delete:SINK $de(SELF,$one); Nil; } elsif !%a { # :delete $de(SELF,$one); } elsif %a.exists_key('exists') { # :delete:exists(0|1):* my $exists := %a.delete_key('exists'); my $wasthere := $ex(SELF,$one); $de(SELF,$one); if !%a { # :delete:exists(0|1) !( $wasthere ?^ $exists ) } elsif %a.exists_key('kv') { # :delete:exists(0|1):kv(0|1) my $kv := %a.delete_key('kv'); if !%a { !$kv | $wasthere ?? ( $one, !( $wasthere ?^ $exists ) ) !! (); } else { @nogo = ; } } elsif %a.exists_key('p') { # :delete:exists(0|1):p(0|1) my $p := %a.delete_key('p'); if !%a { !$p | $wasthere ?? RWPAIR($one, !($wasthere ?^ $exists) ) !! (); } else { @nogo = ; } } else { @nogo = ; } } elsif %a.exists_key('kv') { # :delete:kv(0|1) my $kv := %a.delete_key('kv'); if !%a { !$kv | $ex(SELF,$one) ?? ( $one, $de(SELF,$one) ) !! (); } else { @nogo = ; } } elsif %a.exists_key('p') { # :delete:p(0|1) my $p := %a.delete_key('p'); if !%a { !$p | $ex(SELF,$one) ?? RWPAIR($one, $de(SELF,$one)) !! (); } else { @nogo = ; } } elsif %a.exists_key('k') { # :delete:k(0|1) my $k := %a.delete_key('k'); if !%a { !$k | $ex(SELF,$one) ?? do { $de(SELF,$one); $one } !! (); } else { @nogo = ; } } elsif %a.exists_key('v') { # :delete:v(0|1) my $v := %a.delete_key('v'); if !%a { !$v | $ex(SELF,$one) ?? $de(SELF,$one) !! (); } else { @nogo = ; } } else { @nogo = ; } } elsif %a.exists_key('exists') { # :!delete?:exists(0|1):* my $exists := %a.delete_key('exists'); my $wasthere = $ex(SELF,$one); if !%a { # :!delete?:exists(0|1) !( $wasthere ?^ $exists ) } elsif %a.exists_key('kv') { # :!delete?:exists(0|1):kv(0|1) my $kv := %a.delete_key('kv'); if !%a { !$kv | $wasthere ?? ( $one, !( $wasthere ?^ $exists ) ) !! (); } else { @nogo = ; } } elsif %a.exists_key('p') { # :!delete?:exists(0|1):p(0|1) my $p := %a.delete_key('p'); if !%a { !$p | $wasthere ?? RWPAIR($one, !( $wasthere ?^ $exists )) !! (); } else { @nogo = ; } } else { @nogo = ; } } elsif %a.exists_key('kv') { # :!delete?:kv(0|1):* my $kv := %a.delete_key('kv'); if !%a { # :!delete?:kv(0|1) !$kv | $ex(SELF,$one) ?? ($one, $array ?? SELF.at_pos($one) !! SELF.at_key($one)) !! (); } else { @nogo = ; } } elsif %a.exists_key('p') { # :!delete?:p(0|1):* my $p := %a.delete_key('p'); if !%a { # :!delete?:p(0|1) !$p | $ex(SELF,$one) ?? RWPAIR($one, $array ?? SELF.at_pos($one) !! SELF.at_key($one)) !! (); } else { @nogo =

; } } elsif %a.exists_key('k') { # :!delete?:k(0|1):* my $k := %a.delete_key('k'); if !%a { # :!delete?:k(0|1) !$k | $ex(SELF,$one) ?? $one !! (); } else { @nogo = ; } } elsif %a.exists_key('v') { # :!delete?:v(0|1):* my $v := %a.delete_key('v'); # :!delete?:v(0|1) if !%a { !$v | $ex(SELF,$one) ?? ($array ?? SELF.at_pos($one) !! SELF.at_key($one)) !! (); } else { @nogo = ; } } elsif !%a { # :!delete $array ?? SELF.at_pos($one) !! SELF.at_key($one); } }; @nogo || %a ?? SLICE_HUH( SELF, @nogo, %a, %adv ) !! result; } #SLICE_ONE # internal >1 element hash/array access with adverbs sub SLICE_MORE ( \SELF, $more, $array, *%adv ) is hidden_from_backtrace { my %a = %adv.clone; my @nogo; my $at = SELF.can( $array ?? 'at_pos' !! 'at_key' )[0]; my $ex = SELF.can( $array ?? 'exists_pos' !! 'exists_key' )[0]; my \result = do { if %a.delete_key('delete') { # :delete:* my $de = SELF.can( $array ?? 'delete_pos' !! 'delete_key' )[0]; if %a.delete_key('SINK') { # :delete:SINK $de(SELF,$_) for $more; Nil; } elsif !%a { # :delete $more.list.map( { $de(SELF,$_) } ).eager.Parcel; } elsif %a.exists_key('exists') { # :delete:exists(0|1):* my $exists := %a.delete_key('exists'); my $wasthere; # no need to initialize every iteration of map if !%a { # :delete:exists(0|1) $more.list.map( { $de(SELF,$_) if $wasthere = $ex(SELF,$_); !( $wasthere ?^ $exists ); } ).eager.Parcel } elsif %a.exists_key('kv') { # :delete:exists(0|1):kv(0|1):* my $kv := %a.delete_key('kv'); if !%a { # :delete:exists(0|1):kv(0|1) $more.list.map( { $de(SELF,$_) if $wasthere = $ex(SELF,$_); !$kv | $wasthere ?? ($_, !( $wasthere ?^ $exists )) !! () } ).eager.Parcel } else { @nogo = ; } } elsif %a.exists_key('p') { # :delete:exists(0|1):p(0|1):* my $p := %a.delete_key('p'); if !%a { # :delete:exists(0|1):p(0|1) $more.list.map( { $de(SELF,$_) if $wasthere = $ex(SELF,$_); !$p | $wasthere ?? RWPAIR($_,!($wasthere ?^ $exists)) !! () } ).eager.Parcel } else { @nogo = ; } } else { @nogo = ; } } elsif %a.exists_key('kv') { # :delete:kv(0|1):* my $kv := %a.delete_key('kv'); if !%a { # :delete:kv(0|1) $kv ?? $more.list.map( { $ex(SELF,$_) ?? ( $_, $de(SELF,$_) ) !! () } ).eager.Parcel !! $more.list.map( { ( $_, $de(SELF,$_) ) } ).eager.Parcel; } else { @nogo = ; } } elsif %a.exists_key('p') { # :delete:p(0|1):* my $p := %a.delete_key('p'); if !%a { # :delete:p(0|1) $p ?? $more.list.map( { $ex(SELF,$_) ?? RWPAIR($_, $de(SELF,$_)) !! () } ).eager.Parcel !! $more.list.map( { RWPAIR($_, $de(SELF,$_)) } ).eager.Parcel; } else { @nogo = ; } } elsif %a.exists_key('k') { # :delete:k(0|1):* my $k := %a.delete_key('k'); if !%a { # :delete:k(0|1) $k ?? $more.list.map( { $ex(SELF,$_) ?? ( $de(SELF,$_); $_ ) !! () } ).eager.Parcel !! $more.list.map( { $de(SELF,$_); $_ } ).eager.Parcel; } else { @nogo = ; } } elsif %a.exists_key('v') { # :delete:v(0|1):* my $v := %a.delete_key('v'); if !%a { # :delete:v(0|1) $v ?? $more.list.map( { $ex(SELF,$_) ?? $de(SELF,$_) !! () } ).eager.Parcel !! $more.list.map( { $de(SELF,$_) } ).eager.Parcel; } else { @nogo = ; } } else { @nogo = ; } } elsif %a.exists_key('exists') { # :!delete?:exists(0|1):* my $exists := %a.delete_key('exists'); if !%a { # :!delete?:exists(0|1) $more.list.map({ !( $ex(SELF,$_) ?^ $exists ) }).eager.Parcel; } elsif %a.exists_key('kv') { # :!delete?:exists(0|1):kv(0|1):* my $kv := %a.delete_key('kv'); if !%a { # :!delete?:exists(0|1):kv(0|1) $kv ?? $more.list.map( { $ex(SELF,$_) ?? ( $_, $exists ) !! () } ).eager.Parcel !! $more.list.map( { ( $_, !( $ex(SELF,$_) ?^ $exists ) ) } ).eager.Parcel; } else { @nogo = ; } } elsif %a.exists_key('p') { # :!delete?:exists(0|1):p(0|1):* my $p := %a.delete_key('p'); if !%a { # :!delete?:exists(0|1):p(0|1) $p ?? $more.list.map( { $ex(SELF,$_) ?? RWPAIR( $_, $exists ) !! () } ).eager.Parcel !! $more.list.map( { RWPAIR( $_, !( $ex(SELF,$_) ?^ $exists ) ) } ).eager.Parcel; } else { @nogo = ; } } else { @nogo = ; } } elsif %a.exists_key('kv') { # :!delete?:kv(0|1):* my $kv := %a.delete_key('kv'); if !%a { # :!delete?:kv(0|1) $kv ?? $more.list.map( { $ex(SELF,$_) ?? ($_, $at(SELF,$_)) !! () } ).eager.Parcel !! $more.list.map( { ($_, $at(SELF,$_)) } ).eager.Parcel; } else { @nogo = ; } } elsif %a.exists_key('p') { # :!delete?:p(0|1):* my $p := %a.delete_key('p'); if !%a { # :!delete?:p(0|1) $p ?? $more.list.map( { $ex(SELF,$_) ?? RWPAIR($_, $at(SELF,$_)) !! () } ).eager.Parcel !! $more.list.map( { RWPAIR( $_, $at(SELF,$_) ) } ).eager.Parcel; } else { @nogo =

} } elsif %a.exists_key('k') { # :!delete?:k(0|1):* my $k := %a.delete_key('k'); if !%a { # :!delete?:k(0|1) $k ?? $more.list.map( { $ex(SELF,$_) ?? $_ !! () } ).eager.Parcel !! $more.list.eager.Parcel; } else { @nogo = ; } } elsif %a.exists_key('v') { # :!delete?:v(0|1):* my $v := %a.delete_key('v'); if !%a { # :!delete?:v(0|1) $v ?? $more.list.map( { $ex(SELF,$_) ?? $at(SELF,$_) !! () } ).eager.Parcel !! $more.list.map( { $at(SELF,$_) } ).eager.Parcel; } else { @nogo = ; } } elsif !%a { # :!delete $more.list.map( { $at(SELF,$_) } ).eager.Parcel; } } @nogo || %a ?? SLICE_HUH( SELF, @nogo, %a, %adv ) !! result; } #SLICE_MORE rakudo-2013.12/src/core/Array.pm0000664000175000017500000001701012225320406015731 0ustar moritzmoritzmy class X::Item { ... }; my class X::TypeCheck { ... }; class Array { # declared in BOOTSTRAP # class Array is List { # has Mu $!descriptor; method new(|) { my Mu $args := nqp::p6argvmarray(); nqp::shift($args); nqp::p6list($args, self.WHAT, Bool::True); } multi method at_pos(Array:D: $pos) is rw { #?if jvm if nqp::istype($pos, Num) && nqp::isnanorinf($pos) { #?endif #?if !jvm if nqp::isnanorinf($pos) { #?endif X::Item.new(aggregate => self, index => $pos).throw; } my int $p = nqp::unbox_i($pos.Int); my Mu $items := nqp::p6listitems(self); # hotpath check for element existence (RT #111848) if nqp::existspos($items, $p) || nqp::getattr(self, List, '$!nextiter').defined && self.exists_pos($p) { nqp::atpos($items, $p); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc($!descriptor)), Scalar, '$!whence', -> { nqp::bindpos($items, $p, v) } ); } } multi method at_pos(Array:D: int $pos) is rw { my Mu $items := nqp::p6listitems(self); # hotpath check for element existence (RT #111848) if nqp::existspos($items, $pos) || nqp::getattr(self, List, '$!nextiter').defined && self.exists_pos($pos) { nqp::atpos($items, $pos); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc($!descriptor)), Scalar, '$!whence', -> { nqp::bindpos($items, $pos, v) } ); } } proto method bind_pos(|) { * } multi method bind_pos($pos is copy, Mu \bindval) is rw { $pos = $pos.Int; self.gimme($pos + 1); nqp::bindpos(nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos), bindval); } multi method bind_pos(int $pos, Mu \bindval) is rw { self.gimme($pos + 1); nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, bindval) } method delete (\pos) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_pos(pos); } method delete_pos(\pos) { fail "Cannot use negative index {pos} on {self.WHAT.perl}" if pos < 0; my $value := self.at_pos(pos); # needed for reification my $items := nqp::getattr(self,List,'$!items'); my $end := self.end; if pos == $end { my $pos = pos; nqp::pop($items); nqp::pop($items) while --$pos >= 0 && nqp::isnull(nqp::atpos($items,$pos)); } elsif pos < $end { nqp::bindpos($items, pos, nqp::null()); } else { return self.default; } $value; } method flattens() { 1 } # introspection method name() { my $d := $!descriptor; nqp::isnull($d) ?? Str !! $d.name() } method of() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! $d.of; } method default() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! $d.default; } method dynamic() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! so $d.dynamic; } multi method perl(Array:D \SELF:) { nqp::iscont(SELF) ?? '[' ~ self.map({.perl}).join(', ') ~ ']' !! self.WHAT.perl ~ '.new(' ~ self.map({.perl}).join(', ') ~ ')' } method REIFY(Parcel \parcel, Mu \nextiter) { my Mu $rpa := nqp::getattr(parcel, Parcel, '$!storage'); my Mu $iter := nqp::iterator($rpa); my int $i = 0; while $iter { nqp::bindpos($rpa, $i, nqp::p6scalarfromdesc($!descriptor) = nqp::shift($iter)); $i = $i + 1; } nqp::findmethod(List, 'REIFY')(self, parcel, nextiter) } method STORE(|) { # get arguments, shift off invocant my $args := nqp::p6argvmarray(); nqp::shift($args); # make an array from them (we can't just use ourself for this, # or @a = @a will go terribly wrong); make it eager my $list := nqp::p6list($args, Array, Mu); nqp::bindattr($list, List, '$!flattens', True); $list.eager; # clear our items and set our next iterator to be one over # the array we just created nqp::bindattr(self, List, '$!items', Mu); nqp::bindattr(self, List, '$!nextiter', nqp::p6listiter(nqp::list($list), self)); self } my role TypedArray[::TValue] does Positional[TValue] { method new(|) { my Mu $args := nqp::p6argvmarray(); nqp::shift($args); my $list := nqp::p6list($args, self.WHAT, Bool::True); my $of = self.of; if ( $of !=:= Mu ) { for @$list { if $_ !~~ $of { X::TypeCheck.new( operation => '.new', expected => $of, got => $_, ).throw; } } } $list; } multi method at_pos($pos is copy) is rw { $pos = $pos.Int; if self.exists_pos($pos) { nqp::atpos( nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos) ); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc(nqp::getattr(self, Array, '$!descriptor'))), Scalar, '$!whence', -> { nqp::bindpos( nqp::getattr(self,List,'$!items'), nqp::unbox_i($pos), v) } ); } } multi method at_pos(int $pos, TValue $v? is copy) is rw { if self.exists_pos($pos) { nqp::atpos(nqp::getattr(self, List, '$!items'), $pos); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc(nqp::getattr(self, Array, '$!descriptor'))), Scalar, '$!whence', -> { nqp::bindpos(nqp::getattr(self, List,'$!items'), $pos, v)} ); } } multi method bind_pos($pos is copy, TValue \bindval) is rw { $pos = $pos.Int; self.gimme($pos + 1); nqp::bindpos(nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos), bindval) } multi method bind_pos(int $pos, TValue \bindval) is rw { self.gimme($pos + 1); nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, bindval) } multi method perl(::?CLASS:D \SELF:) { 'Array[' ~ TValue.perl ~ '].new(' ~ self.map({.perl}).join(', ') ~ ')'; } # XXX some methods to come here... } method PARAMETERIZE_TYPE(Mu $t, |c) { if c.elems == 0 { # my $what := self but TypedArray[$t.WHAT]; # too early in bootstrap my $what := self.HOW.mixin(self.WHAT, TypedArray[$t.WHAT]); # needs to be done in COMPOSE phaser when that works $what.HOW.set_name(self,"{self.HOW.name(self)}[{$t.HOW.name($t)}]"); $what; } else { die "Can only type-constraint Array with [ValueType]" } } } sub circumfix:<[ ]>(*@elems) is rw { my $x = @elems.eager } rakudo-2013.12/src/core/array_slice.pm0000664000175000017500000001715612255230273017170 0ustar moritzmoritz# all sub postcircumfix [] candidates here please sub POSITIONS (\SELF, \pos) { # handle possible infinite slices my $positions = pos.flat; $positions.gimme(*); return $positions.map( { $_ ~~ Callable ?? $_(|(SELF.elems xx $_.count)) !! $_ } ).eager.Parcel unless $positions.infinite; my $list = SELF.list; $positions.map( { last if $_ >= $list.gimme( $_ + 1 ); $_; } ).eager.Parcel; } proto sub postcircumfix:<[ ]>(|) { * } # @a[1] multi sub postcircumfix:<[ ]>( \SELF, int $pos ) is rw { fail "Cannot use negative index $pos on {SELF.WHAT.perl}" if $pos < 0; SELF.at_pos($pos); } multi sub postcircumfix:<[ ]>(\SELF, int $pos, Mu :$BIND! is parcel) is rw { fail "Cannot use negative index $pos on {SELF.WHAT.perl}" if $pos < 0; SELF.bind_pos($pos, $BIND); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$SINK!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$SINK, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$delete!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$delete, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$exists!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$exists, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$kv!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$kv, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$p!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$p, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$k!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$k, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$v!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$v, |%other ); } # @a[$x] multi sub postcircumfix:<[ ]>( \SELF, $pos ) is rw { fail "Cannot use negative index $pos on {SELF.WHAT.perl}" if $pos < 0; SELF.at_pos($pos); } multi sub postcircumfix:<[ ]>(\SELF, $pos, Mu :$BIND! is parcel) is rw { fail "Cannot use negative index $pos on {SELF.WHAT.perl}" if $pos < 0; SELF.bind_pos($pos, $BIND); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$SINK!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$SINK, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$delete!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$delete, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$exists!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$exists, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$kv!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$kv, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$p!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$p, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$k!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$k, |%other ); } multi sub postcircumfix:<[ ]>( \SELF, $pos, :$v!, *%other ) is rw { SLICE_ONE( SELF, $pos, True, :$v, |%other ); } # @a[@i] multi sub postcircumfix:<[ ]>( \SELF, Positional \pos ) is rw { if nqp::iscont(pos) { fail "Cannot use negative index {pos} on {SELF.WHAT.perl}" if pos < 0; SELF.at_pos(pos); } else { POSITIONS(SELF,pos).map({ SELF[$_] }).eager.Parcel; } } multi sub postcircumfix:<[ ]>(\SELF, Positional \pos, :$BIND!) is rw { X::Bind::Slice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<[ ]>(\SELF, Positional \pos, :$SINK!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$SINK, |%other ); } multi sub postcircumfix:<[ ]>(\SELF,Positional \pos,:$delete!,*%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$delete, |%other ); } multi sub postcircumfix:<[ ]>(\SELF,Positional \pos,:$exists!,*%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$exists, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Positional \pos, :$kv!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$kv, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Positional \pos, :$p!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$p, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Positional \pos, :$k!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$k, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Positional \pos, :$v!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,pos), True, :$v, |%other ); } # @a[->{}] multi sub postcircumfix:<[ ]>( \SELF, Callable $block ) is rw { SELF[$block(|(SELF.elems xx $block.count))]; } multi sub postcircumfix:<[ ]>(\SELF, Callable $block, :$BIND!) is rw { X::Bind::Slice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<[ ]>(\SELF, Callable $block, :$SINK!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$SINK, |%other ); } multi sub postcircumfix:<[ ]>(\SELF,Callable $block,:$delete!,*%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$delete, |%other ); } multi sub postcircumfix:<[ ]>(\SELF,Callable $block,:$exists!,*%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$exists, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Callable $block, :$kv!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$kv, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Callable $block, :$p!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$p, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Callable $block, :$k!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$k, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Callable $block, :$v!, *%other) is rw { SLICE_MORE( SELF, POSITIONS(SELF,$block), True, :$v, |%other ); } # @a[*] multi sub postcircumfix:<[ ]>( \SELF, Whatever ) is rw { SELF[SELF.keys]; } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$BIND!) is rw { X::Bind::Slice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$SINK!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$SINK, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$delete!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$delete, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$exists!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$exists, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$kv!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$kv, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$p!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$p, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$k!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$k, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, Whatever, :$v!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$v, |%other ); } # @a[] multi sub postcircumfix:<[ ]>( \SELF ) is rw { SELF.list; } multi sub postcircumfix:<[ ]>(\SELF, :$BIND!) is rw { X::Bind::ZenSlice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<[ ]>(\SELF, :$SINK!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$SINK, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, :$delete!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$delete, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, :$exists!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$exists, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, :$kv!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$kv, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, :$p!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$p, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, :$k!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$k, |%other ); } multi sub postcircumfix:<[ ]>(\SELF, :$v!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, True, :$v, |%other ); } rakudo-2013.12/src/core/Associative.pm0000664000175000017500000000007012224263172017130 0ustar moritzmoritzmy role Associative[::T = Mu] { method of() { T } } rakudo-2013.12/src/core/AST.pm0000664000175000017500000000215112224263172015307 0ustar moritzmoritz# XXX: Would like to have this class as Perl6::AST, but ran up against # problems with the serialization context calling it that. my class AST { has $!past; has $!quasi_context; submethod BUILD(:$past) { $!past := $past; } method incarnate($quasi_context, @unquote_asts) { my $incarnation = self.clone(); nqp::bindattr(nqp::decont($incarnation), AST, '$!past', $incarnation.evaluate_unquotes(@unquote_asts)); nqp::bindattr(nqp::decont($incarnation), AST, '$!quasi_context', $quasi_context); return $incarnation; } method evaluate_unquotes(@unquote_asts) { my $pasts := nqp::list(); for @unquote_asts { # TODO: find and report macro name X::TypeCheck::Splice.new( got => $_, expected => AST, action => 'unquote evaluation', ).throw unless $_ ~~ AST; nqp::push($pasts, nqp::getattr(nqp::decont($_), AST, '$!past')) } $!past.evaluate_unquotes($pasts); } method is_quasi_ast { so $!quasi_context; } } rakudo-2013.12/src/core/Attribute.pm0000664000175000017500000001116312224263172016626 0ustar moritzmoritzmy class Attribute { # declared in BOOTSTRAP # class Attribute is Any { # has str $!name; # has int $!rw; # has int $!has_accessor; # has Mu $!type; # has Mu $!container_descriptor; # has Mu $!auto_viv_container; # has Mu $!build_closure; # has Mu $!package; # has int $!positional_delegate; # has int $!associative_delegate; method compose(Mu $package) { # Generate accessor method, if we're meant to have one. if self.has_accessor { my $name := self.name; my $meth_name := nqp::substr(nqp::unbox_s($name), 2); unless $package.HOW.declares_method($package, $meth_name) { my $dcpkg := nqp::decont($package); my $meth; my int $attr_type = nqp::objprimspec($!type); if self.rw { $meth := nqp::p6bool(nqp::iseq_i($attr_type, 0)) ?? method (Mu $self:) is rw { nqp::getattr( nqp::decont($self), $dcpkg, nqp::unbox_s($name)) } !! nqp::die("Cannot create rw-accessors for natively typed attribute '$name'"); } else { # ro accessor $meth := nqp::p6bool(nqp::iseq_i($attr_type, 0)) ?? method (Mu $self:) { nqp::getattr( nqp::decont($self), $dcpkg, nqp::unbox_s($name)) } !! nqp::p6bool(nqp::iseq_i($attr_type, 1)) ?? method (Mu $self:) { nqp::p6box_i( nqp::getattr_i( nqp::decont($self), $dcpkg, nqp::unbox_s($name)) ); } !! nqp::p6bool(nqp::iseq_i($attr_type, 2)) ?? method (Mu $self:) { nqp::p6box_n( nqp::getattr_n( nqp::decont($self), $dcpkg, nqp::unbox_s($name)) ); } !! method (Mu $self:) { nqp::p6box_s( nqp::getattr_s( nqp::decont($self), $dcpkg, nqp::unbox_s($name)) ); } } $meth.set_name($meth_name); $package.HOW.add_method($package, $meth_name, $meth); } } # Apply any handles trait we may have. self.apply_handles($package); } method apply_handles(Mu $pkg) { # None by default. } method get_value(Mu $obj) { my $decont := nqp::decont($obj); given nqp::p6box_i(nqp::objprimspec($!type)) { when 0 { nqp::getattr($decont, $!package, $!name) } when 1 { nqp::p6box_i(nqp::getattr_i($decont, $!package, $!name)) } when 2 { nqp::p6box_n(nqp::getattr_n($decont, $!package, $!name)) } when 3 { nqp::p6box_s(nqp::getattr_s($decont, $!package, $!name)) } } } method set_value(Mu $obj, Mu \value) { my $decont := nqp::decont($obj); given nqp::p6box_i(nqp::objprimspec($!type)) { when 0 { nqp::bindattr($decont, $!package, $!name, value) } when 1 { nqp::p6box_i(nqp::bindattr_i($decont, $!package, $!name, value)) } when 2 { nqp::p6box_n(nqp::bindattr_n($decont, $!package, $!name, value)) } when 3 { nqp::p6box_s(nqp::bindattr_s($decont, $!package, $!name, value)) } } } method container() is rw { nqp::isnull($!auto_viv_container) ?? Mu !! $!auto_viv_container } method has-accessor() { ?$!has_accessor } method readonly() { !self.rw } method package() { $!package } multi method Str(Attribute:D:) { self.name } multi method gist(Attribute:D:) { self.type.^name ~ " " ~ self.name } } rakudo-2013.12/src/core/Backtrace.pm0000664000175000017500000001363512255230276016553 0ustar moritzmoritzmy class Exception { ... } my class Backtrace { ... } my class Backtrace::Frame { has Str $.file; has Int $.line; has Mu $.code; has Str $.subname; method subtype(Backtrace::Frame:D:) { my $s = $!code.^name.lc.split('+', 2)[0]; $s eq 'mu' ?? '' !! $s; } method package(Backtrace::Frame:D:) { $.code.package; } multi method Str(Backtrace::Frame:D:) { my $s = self.subtype; $s ~= ' ' if $s.chars; " in {$s}$.subname at {$.file}:$.line\n" } method is-hidden(Backtrace::Frame:D:) { $!code.?is_hidden_from_backtrace } method is-routine(Backtrace::Frame:D:) { $!code ~~ Routine } method is-setting(Backtrace::Frame:D:) { $!file.chars > 12 && $!file.substr(*-12) eq 'CORE.setting' } } my class Backtrace is List { proto method new(|) {*} multi method new(Exception $e, Int $offset = 0) { #?if parrot self.new(nqp::getattr(nqp::decont($e), Exception, '$!ex').backtrace, $offset); #?endif #?if jvm self.new(nqp::backtrace(nqp::getattr(nqp::decont($e), Exception, '$!ex')), $offset); #?endif } multi method new() { try { die() }; self.new($!, 3); } # note that parrot backtraces are RPAs, marshalled to us as Parcel multi method new(Parcel $bt, Int $offset = 0) { my $new = self.bless(); for $offset .. $bt.elems - 1 { next unless defined $bt[$_]; my Mu $sub := nqp::getattr(nqp::decont($bt[$_]), ForeignCode, '$!do'); next if nqp::isnull($sub); my $code; try { $code = nqp::getcodeobj($sub); }; my $line = $bt[$_]; my $file = $bt[$_]; next unless $line && $file; # now *that's* an evil hack next if $file eq 'src/gen/BOOTSTRAP.nqp' || $file eq 'src\\gen\\BOOTSTRAP.nqp'; last if $file eq 'src/stage2/gen/NQPHLL.nqp' || $file eq 'src\\stage2\\gen\\NQPHLL.nqp' || $file eq 'gen/parrot/stage2/NQPHLL.nqp' || $file eq 'gen\\parrot\\stage2\\NQPHLL.nqp' || $file eq 'gen/jvm/stage2/NQPHLL.nqp' || $file eq 'gen\\jvm\\stage2\\NQPHLL.nqp'; # XXX extend for moar my $subname = nqp::p6box_s(nqp::getcodename($sub)); $subname = '' if $subname.substr(0, 6) eq '_block'; $new.push: Backtrace::Frame.new( :$line, :$file, :$subname, :$code, ); } $new; } method next-interesting-index(Backtrace:D: Int $idx is copy = 0, :$named, :$noproto) { ++$idx; # NOTE: the < $.end looks like an off-by-one error # but it turns out that a simple perl6 -e 'die "foo"' # has two bt frames from the mainline; so it's OK to never # consider the last one loop (; $idx < self.end; ++$idx) { my $cand = self.at_pos($idx); next if $cand.is-hidden; # hidden is never interesting next if $named && !$cand.subname; # only want named ones next if $noproto # no proto's please && $cand.code.?is_dispatcher; # if a dispatcher return $idx; } Int; } method outer-caller-idx(Backtrace:D: Int $startidx is copy) { my %print; my $start = self.at_pos($startidx).code; return $startidx.list unless $start; my $current = $start.outer; my %outers; while $current.DEFINITE { %outers{$current.static_id} = $start; $current = $current.outer; } my @outers; loop (my Int $i = $startidx; $i < $.end; ++$i) { if self.at_pos($i).code.DEFINITE && %outers{self.at_pos($i).code.static_id}.DEFINITE { @outers.push: $i; return @outers if self.at_pos($i).is-routine; } } return @outers; } method nice(Backtrace:D: :$oneline) { try { my @frames; my Int $i = self.next-interesting-index(-1); while $i.defined { $i = self.next-interesting-index($i) while $oneline && $i.defined && self.at_pos($i).is-setting; last unless $i.defined; my $prev = self.at_pos($i); if $prev.is-routine { @frames.push: $prev; } else { my @outer_callers := self.outer-caller-idx($i); my ($target_idx) = @outer_callers.keys.grep({self.at_pos($i).code.^isa(Routine)}); $target_idx ||= @outer_callers[0] || $i; my $current = self.at_pos($target_idx); @frames.push: $current.clone(line => $prev.line); $i = $target_idx; } last if $oneline; $i = self.next-interesting-index($i); } return @frames.join; CATCH { default { return ""; } } } } method concise(Backtrace:D:) { self.grep({ !.is-hidden && .is-routine && !.is-setting }).join } multi method Str(Backtrace:D:) { self.nice; } method full(Backtrace:D:) { self.join } method summary(Backtrace:D:) { self.grep({ !.is-hidden && (.is-routine || !.is-setting )}).join } } rakudo-2013.12/src/core/Baggy.pm0000664000175000017500000001266612255230273015725 0ustar moritzmoritzmy role Baggy does QuantHash { has %!elems; # key.WHICH => (key,value) method BUILD (:%!elems) {} method default(--> Int) { 0 } method keys { %!elems.values.map( {.key} ) } method values { %!elems.values.map( {.value} ) } method elems(--> Int) { %!elems.elems } method total(--> Int) { [+] self.values } method exists ($k --> Bool) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_key($k); } method exists_key($k --> Bool) { %!elems.exists_key($k.WHICH); } method Bool { %!elems.Bool } method hash(--> Hash) { %!elems.values.hash } method invert(--> List) { %!elems.values.map: { ( .value => .key ) } } method new(*@args --> Baggy) { my %e; # need explicit signature because of #119609 -> $_ { (%e{$_.WHICH} //= ($_ => 0)).value++ } for @args; self.bless(:elems(%e)); } method new-fp(*@pairs --> Baggy) { my %e; for @pairs { when Pair { (%e{$_.key.WHICH} //= ($_.key => 0)).value += $_.value.Int; } default { (%e{$_.WHICH} //= ($_ => 0)).value++; } } my @toolow; for %e -> $p { my $pair := $p.value; @toolow.push( $pair.key ) if $pair.value < 0; %e.delete_key($p.key) if $pair.value <= 0; } fail "Found negative values for {@toolow} in {self.^name}" if @toolow; self.bless(:elems(%e)); } method ACCEPTS($other) { self.defined ?? $other (<+) self && self (<+) $other !! $other.^does(self); } multi method Str(Baggy:D $ : --> Str) { ~ %!elems.values.map( { .value == 1 ?? .key.gist !! "{.key.gist}({.value})" } ); } multi method gist(Baggy:D $ : --> Str) { my $name := self.^name; ( $name eq 'Bag' ?? 'bag' !! "$name.new" ) ~ '(' ~ %!elems.values.map( { .value == 1 ?? .key.gist !! "{.key.gist}({.value})" } ).join(', ') ~ ')'; } multi method perl(Baggy:D $ : --> Str) { '(' ~ %!elems.values.map( {"{.key.perl}=>{.value}"} ).join(',') ~ ").{self.^name}" } method list() { self.keys } method pairs() { %!elems.values } method grab ($count = 1) { my @grab = ROLLPICKGRAB(self, $count, %!elems.values); %!elems{ @grab.map({.WHICH}).grep: { %!elems{$_}.value == 0 } }:delete; @grab; } method grabpairs($count = 1) { (%!elems{ %!elems.keys.pick($count) }:delete).list; } method pick ($count = 1) { ROLLPICKGRAB(self, $count, %!elems.values.map: { (.key => .value) }); } method pickpairs ($count = 1) { (%!elems{ %!elems.keys.pick($count) }).list; } method roll ($count = 1) { ROLLPICKGRAB(self, $count, %!elems.values, :keep); } sub ROLLPICKGRAB ($self, $count, @pairs is rw, :$keep) is hidden_from_backtrace { my $total = $self.total; my $todo = $count ~~ Num ?? $total min $count !! ($count ~~ Whatever ?? ( $keep ?? $Inf !! $total ) !! $count); map { my $rand = $total.rand.Int; my $seen = 0; my $selected; for @pairs -> $pair { next if ( $seen += $pair.value ) <= $rand; $selected = $pair.key; last if $keep; $pair.value--; $total--; last; } $selected; }, 1 .. $todo; } proto method classify-list(|) { * } multi method classify-list( &test, *@list ) { fail 'Cannot .classify an infinite list' if @list.infinite; if @list { # multi-level classify if test(@list[0]) ~~ List { for @list -> $l { my @keys = test($l); my $last := @keys.pop; my $bag = self; $bag = $bag{$_} //= self.new for @keys; $bag{$last}++; } } # just a simple classify else { self{test $_}++ for @list; } } self; } multi method classify-list( %test, *@list ) { samewith( { %test{$^a} }, @list ); } multi method classify-list( @test, *@list ) { samewith( { @test[$^a] }, @list ); } proto method categorize-list(|) { * } multi method categorize-list( &test, *@list ) { fail 'Cannot .categorize an infinite list' if @list.infinite; if @list { # multi-level categorize if test(@list[0])[0] ~~ List { for @list -> $l { for test($l) -> $k { my @keys = @($k); my $last := @keys.pop; my $bag = self; $bag = $bag{$_} //= self.new for @keys; $bag{$last}++; } } } # just a simple categorize else { for @list -> $l { self{$_}++ for test($l); } } } self; } multi method categorize-list( %test, *@list ) { samewith( { %test{$^a} }, @list ); } multi method categorize-list( @test, *@list ) { samewith( { @test[$^a] }, @list ); } } rakudo-2013.12/src/core/BagHash.pm0000664000175000017500000000256212255230273016163 0ustar moritzmoritzmy class BagHash does Baggy { method at_key($k) { Proxy.new( FETCH => { my $key := $k.WHICH; %!elems.exists_key($key) ?? %!elems{$key}.value !! 0; }, STORE => -> $, $value { if $value > 0 { (%!elems{$k.WHICH} //= ($k => 0)).value = $value; } elsif $value == 0 { self.delete_key($k); } else { fail "Cannot put negative value $value for $k in {self.^name}"; } $value; } ); } method delete($k) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($k); } method delete_key($k) { my $key := $k.WHICH; if %!elems.exists_key($key) { my $value = %!elems{$key}.value; %!elems.delete_key($key); $value; } else { 0; } } method Bag (:$view) { if $view { my $bag := nqp::create(Bag); $bag.BUILD( :elems(%!elems) ); $bag; } else { Bag.new-fp(%!elems.values); } } method BagHash { self } method Mix { Mix.new-fp(%!elems.values) } method MixHash { MixHash.new-fp(%!elems.values) } } rakudo-2013.12/src/core/Bag.pm0000664000175000017500000000252612255230273015357 0ustar moritzmoritzmy class Bag does Baggy { has Int $!total; has $!WHICH; method total { $!total //= [+] %!elems.values.map( { .value } ); } submethod WHICH { $!WHICH } submethod BUILD (:%elems) { my @keys := %elems.keys.sort; $!WHICH := self.^name ~ '|' ~ @keys.map( { $_ ~ '(' ~ %elems{$_}.value ~ ')' } ); nqp::bindattr(self, Bag, '%!elems', %elems); } method at_key($k --> Int) { my $key := $k.WHICH; %!elems.exists_key($key) ?? %!elems{$key}.value !! 0; } method delete ($a --> Int) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($a); } method delete_key($a --> Int) is hidden_from_backtrace { X::Immutable.new( method => 'delete_key', typename => self.^name ).throw; } method grab($count = 1 --> Int) is hidden_from_backtrace { X::Immutable.new( method => 'grab', typename => self.^name ).throw; } method grabpairs($count = 1 --> Int) is hidden_from_backtrace { X::Immutable.new( method => 'grabpairs', typename => self.^name ).throw; } method Bag { self } method BagHash { BagHash.new-fp(%!elems.values) } method Mix { Mix.new-fp(%!elems.values) } method MixHash { MixHash.new-fp(%!elems.values) } } rakudo-2013.12/src/core/Block.pm0000664000175000017500000000245012224263172015714 0ustar moritzmoritzmy class Block { # declared in BOOTSTRAP # class Block is Code { # has Mu $!phasers; method add_phaser(Str $name, &block) { nqp::isnull($!phasers) && nqp::bindattr(self, Block, '$!phasers', nqp::hash()); nqp::existskey($!phasers, nqp::unbox_s($name)) || nqp::bindkey($!phasers, nqp::unbox_s($name), nqp::list()); if $name eq any() { nqp::unshift(nqp::atkey($!phasers, nqp::unbox_s($name)), &block); self.add_phaser('!LEAVE-ORDER', &block); } elsif $name eq any() { nqp::unshift(nqp::atkey($!phasers, nqp::unbox_s($name)), &block); } else { nqp::push(nqp::atkey($!phasers, nqp::unbox_s($name)), &block); } } method fire_phasers(str $name) { if !nqp::isnull($!phasers) && nqp::existskey($!phasers, $name) { my Mu $iter := nqp::iterator(nqp::atkey($!phasers, $name)); nqp::shift($iter).() while $iter; } } method phasers(Str $name) { unless nqp::isnull($!phasers) { if nqp::existskey($!phasers, nqp::unbox_s($name)) { return nqp::p6parcel(nqp::atkey($!phasers, nqp::unbox_s($name)), Mu); } } () } } rakudo-2013.12/src/core/Bool.pm0000664000175000017500000000710712224263172015561 0ustar moritzmoritzmy class Bool { # declared in BOOTSTRAP # class Bool is Cool { # has int $!value; multi method Bool(Bool:D:) { self } multi method Numeric(Bool:D:) { self ?? 1 !! 0 } multi method Str(Bool:D:) { self ?? 'True' !! 'False' } multi method gist(Bool:D:) { self ?? 'True' !! 'False' } multi method DUMP(Bool:D:) { self.Str } method Int() { self ?? 1 !! 0 } method pred() { Bool::False } method succ() { Bool::True } method key() { self.Str } method value() { self.Numeric } method pick(Bool:U: $n = 1) { (Bool::True, Bool::False).pick($n) } method roll(Bool:U: $n = 1) { (Bool::True, Bool::False).roll($n) } multi method ACCEPTS(Bool:D: Mu \topic ) { self } multi method perl(Bool:D:) { self ?? 'Bool::True' !! 'Bool::False' } method enums() { my % = False => 0, True => 1 } } multi prefix:<++>(Bool:U \a is rw) { a = True; } multi prefix:<-->(Bool:U \a is rw) { a = False; } multi postfix:<++>(Bool:U \a is rw) { a = True; False; } multi postfix:<-->(Bool:U \a is rw) { a = False; } proto prefix:(Mu $) is pure { * } multi prefix:(Bool:D \a) { a } multi prefix:(Mu \a) { a.Bool } proto prefix:(Mu $) is pure { * } multi prefix:(Bool:D \a) { a } multi prefix:(Mu \a) { a.Bool } proto prefix:(Mu $) is pure { * } multi prefix:(Bool \a) { nqp::p6bool(a ?? 0 !! 1) } multi prefix:(Mu \a) { nqp::p6bool(a.Bool ?? 0 !! 1) } proto prefix:(Mu $) is pure { * } multi prefix:(Bool \a) { nqp::p6bool(a ?? 0 !! 1) } multi prefix:(Mu \a) { nqp::p6bool(a.Bool ?? 0 !! 1) } proto prefix:(Mu $) is pure { * } multi prefix:(Mu \a) { not a } proto infix:(|) is pure { * } multi infix:(Mu $x = Bool::True) { $x.Bool } multi infix:(Mu \a, Mu \b) { a.Bool && b.Bool } proto infix:(|) is pure { * } multi infix:(Mu $x = Bool::False) { $x.Bool } multi infix:(Mu \a, Mu \b) { a.Bool || b.Bool } proto infix:(|) is pure { * } multi infix:(Mu $x = Bool::False) { $x.Bool } multi infix:(Mu \a, Mu \b) { nqp::p6bool(nqp::ifnull(nqp::xor(a.Bool,b.Bool), 0)) } # These operators are normally handled as macros in the compiler; # we define them here for use as arguments to functions. proto infix:<&&>(|) { * } multi infix:<&&>(Mu $x = Bool::True) { $x } multi infix:<&&>(Mu \a, Mu \b) { a && b } proto infix:<||>(|) { * } multi infix:<||>(Mu $x = Bool::False) { $x } multi infix:<||>(Mu \a, Mu \b) { a || b } proto infix:<^^>(|) { * } multi infix:<^^>(Mu $x = Bool::False) { $x } multi infix:<^^>(Mu \a, Mu \b) { a ^^ b } multi infix:<^^>(*@a) { my $a = shift @a; while @a { my $b := shift @a; next unless $b; return Nil if $a; $a := $b; } $a; } proto infix:(|) { * } multi infix:(Mu $x = Any) { $x } multi infix:(Mu \a, Mu \b) { a // b } proto infix:(|) { * } multi infix:(Mu $x = Bool::True) { $x } multi infix:(Mu \a, Mu \b) { a && b } proto infix:(|) { * } multi infix:(Mu $x = Bool::False) { $x } multi infix:(Mu \a, Mu \b) { a || b } proto infix:(|) { * } multi infix:(Mu $x = Bool::False) { $x } multi infix:(Mu \a, Mu \b) { a ^^ b } multi infix:(*@a) { &infix:<^^>(@a); } proto infix:(|) { * } multi infix:(Mu $x = Any) { $x } multi infix:(Mu \a, Mu \b) { a // b } rakudo-2013.12/src/core/Buf.pm0000664000175000017500000003014512224263172015400 0ustar moritzmoritzmy class X::Buf::AsStr { ... } my class X::Buf::Pack { ... } my class X::Buf::Pack::NonASCII { ... } my role Blob[::T = uint8] does Positional[T] does Stringy is repr('VMArray') is array_type(T) { proto method new(|) { * } multi method new() { nqp::create(self) } multi method new(@values) { my $buf := nqp::create(self); my int $n = @values.elems; my int $i; nqp::setelems($buf, $n); while $i < $n { nqp::bindpos_i($buf, $i, @values.at_pos($i)); $i = $i + 1; } $buf } multi method new(*@values) { self.new(@values) } multi method at_pos(Blob:D: $i) { nqp::atpos_i(self, $i.Int) } multi method at_pos(Blob:D: Int $i) { nqp::atpos_i(self, $i) } multi method at_pos(Blob:D: int $i) { nqp::atpos_i(self, $i) } multi method Bool(Blob:D:) { nqp::p6bool(nqp::elems(self)); } method elems(Blob:D:) { nqp::p6box_i(nqp::elems(self)); } method bytes(Blob:D:) { self.elems } method chars(Blob:D:) { X::Buf::AsStr.new(method => 'chars').throw } multi method Str(Blob:D:) { X::Buf::AsStr.new(method => 'Str' ).throw } multi method Stringy(Blob:D:) { self } method Numeric(Blob:D:) { self.elems } method Int(Blob:D:) { self.elems } method decode(Blob:D: $encoding = 'utf-8') { nqp::p6box_s(nqp::decode(self, NORMALIZE_ENCODING($encoding))) } method list(Blob:D:) { my @l; my int $n = nqp::elems(self); my int $i = 0; while $i < $n { @l[$i] = nqp::atpos_i(self, $i); $i = $i + 1; } @l; } multi method gist(Blob:D:) { 'Buf:0x<' ~ self.list.fmt('%02x', ' ') ~ '>' } multi method perl(Blob:D:) { self.^name ~ '.new(' ~ self.list.join(', ') ~ ')'; } method subbuf(Blob:D: $from = 0, $len is copy = self.elems - $from) { if ($len < 0) { X::OutOfRange.new( what => "Len element to subbuf", got => $len, range => (0..self.elems)).fail; } my $ret := nqp::create(self); my int $ifrom = nqp::unbox_i( nqp::istype($from, Callable) ?? $from(nqp::p6box_i(self.elems)) !! $from.Int); if ($ifrom < 0) { X::OutOfRange.new( what => 'From argument to subbuf', got => $from, range => (0..self.elems), comment => "use *{$ifrom} if you want to index relative to the end" ).fail; } if ($ifrom > self.elems) { X::OutOfRange.new( what => 'From argument to subbuf', got => $from, range => (0..self.elems), ).fail; } return $ret if $ifrom == self.elems; $len = self.elems - $ifrom if $len > self.elems; my int $llen = $len.Int; nqp::setelems($ret, $llen); my int $i = 0; while $i < $llen { nqp::bindpos_i($ret, $i, nqp::atpos_i(self, $ifrom)); $i = $i + 1; $ifrom = $ifrom + 1; } $ret } method unpack(Blob:D: $template) { my @bytes = self.list; my @fields; for $template.comb(/<[a..zA..Z]>[\d+|'*']?/) -> $unit { my $directive = $unit.substr(0, 1); my $amount = $unit.substr(1); given $directive { when 'A' { my $asciistring; if $amount eq '*' { $amount = @bytes.elems; } for ^$amount { $asciistring ~= chr(shift @bytes); } @fields.push($asciistring); } when 'H' { my $hexstring; while @bytes { my $byte = shift @bytes; $hexstring ~= ($byte +> 4).fmt('%x') ~ ($byte % 16).fmt('%x'); } @fields.push($hexstring); } when 'x' { if $amount eq '*' { $amount = 0; } elsif $amount eq '' { $amount = 1; } splice @bytes, 0, $amount; } when 'C' { @fields.push: shift @bytes; } when 'S' | 'v' { @fields.push: shift(@bytes) + (shift(@bytes) +< 0x08); } when 'L' | 'V' { @fields.push: shift(@bytes) + (shift(@bytes) +< 0x08) + (shift(@bytes) +< 0x10) + (shift(@bytes) +< 0x18); } when 'n' { @fields.push: (shift(@bytes) +< 0x08) + shift(@bytes); } when 'N' { @fields.push: (shift(@bytes) +< 0x18) + (shift(@bytes) +< 0x10) + (shift(@bytes) +< 0x08) + shift(@bytes); } X::Buf::Pack.new(:$directive).throw; } } return |@fields; } # XXX: the pack.t spectest file seems to require this method # not sure if it should be changed to list there... method contents(Blob:D:) { self.list } method encoding() { Any } } constant blob8 = Blob[uint8]; constant blob16 = Blob[uint16]; constant blob32 = Blob[uint32]; constant blob64 = Blob[uint64]; my class utf8 does Blob[uint8] is repr('VMArray') { method decode(utf8:D: $encoding = 'utf-8') { my $enc = NORMALIZE_ENCODING($encoding); die "Can not decode a utf-8 buffer as if it were $encoding" unless $enc eq 'utf8'; nqp::p6box_s(nqp::decode(self, 'utf8')) } method encoding() { 'utf-8' } multi method Str(utf8:D:) { self.decode } } my class utf16 does Blob[uint16] is repr('VMArray') { method decode(utf16:D: $encoding = 'utf-16') { my $enc = NORMALIZE_ENCODING($encoding); die "Can not decode a utf-16 buffer as if it were $encoding" unless $enc eq 'utf16'; nqp::p6box_s(nqp::decode(self, 'utf16')) } method encoding() { 'utf-16' } multi method Str(utf16:D:) { self.decode } } my class utf32 does Blob[uint32] is repr('VMArray') { method decode(utf32:D: $encoding = 'utf-32') { my $enc = NORMALIZE_ENCODING($encoding); die "Can not decode a utf-32 buffer as if it were $encoding" unless $enc eq 'utf32'; nqp::p6box_s(nqp::decode(self, 'utf32')) } method encoding() { 'utf-32' } multi method Str(utf32:D:) { self.decode } } my role Buf[::T = uint8] does Blob[T] is repr('VMArray') is array_type(T) { # TODO: override at_pos so we get mutability } constant buf8 = Buf[uint8]; constant buf16 = Buf[uint16]; constant buf32 = Buf[uint32]; constant buf64 = Buf[uint64]; multi sub pack(Str $template, *@items) { my @bytes; for $template.comb(/<[a..zA..Z]>[\d+|'*']?/) -> $unit { my $directive = $unit.substr(0, 1); my $amount = $unit.substr(1); given $directive { when 'A' { my $ascii = shift @items // ''; for $ascii.comb -> $char { X::Buf::Pack::NonASCII.new(:$char).throw if ord($char) > 0x7f; @bytes.push: ord($char); } if $amount ne '*' { @bytes.push: 0x20 xx ($amount - $ascii.chars); } } when 'H' { my $hexstring = shift @items // ''; if $hexstring % 2 { $hexstring ~= '0'; } @bytes.push: map { :16($_) }, $hexstring.comb(/../); } when 'x' { if $amount eq '*' { $amount = 0; } elsif $amount eq '' { $amount = 1; } @bytes.push: 0x00 xx $amount; } when 'C' { my $number = shift(@items); @bytes.push: $number % 0x100; } when 'S' | 'v' { my $number = shift(@items); @bytes.push: ($number, $number +> 0x08) >>%>> 0x100; } when 'L' | 'V' { my $number = shift(@items); @bytes.push: ($number, $number +> 0x08, $number +> 0x10, $number +> 0x18) >>%>> 0x100; } when 'n' { my $number = shift(@items); @bytes.push: ($number +> 0x08, $number) >>%>> 0x100; } when 'N' { my $number = shift(@items); @bytes.push: ($number +> 0x18, $number +> 0x10, $number +> 0x08, $number) >>%>> 0x100; } X::Buf::Pack.new(:$directive).throw; } } return Buf.new(@bytes); } multi infix:<~>(Blob:D $a, Blob:D $b) { my $res := ($a.WHAT === $b.WHAT ?? $a !! Buf).new; my $adc := nqp::decont($a); my $bdc := nqp::decont($b); my int $alen = nqp::elems($adc); my int $blen = nqp::elems($bdc); nqp::setelems($res, $alen + $blen); my int $s = 0; my int $d = 0; while $s < $alen { nqp::bindpos_i($res, $d, nqp::atpos_i($adc, $s)); $s = $s + 1; $d = $d + 1; } $s = 0; while $s < $blen { nqp::bindpos_i($res, $d, nqp::atpos_i($bdc, $s)); $s = $s + 1; $d = $d + 1; } $res } multi prefix:<~^>(Blob:D $a) { $a ~~ Blob[int16] ?? $a.new($a.list.map: 0xFFFF - *) !! $a ~~ Blob[int32] ?? $a.new($a.list.map: 0xFFFFFFFF - *) !! $a.new($a.list.map: 0xFF - *); } multi sub infix:<~&>(Blob:D $a, Blob:D $b) { my $minlen := $a.elems min $b.elems; my @anded-contents = $a.list[^$minlen] >>+&<< $b.list[^$minlen]; @anded-contents.push: 0 xx ($a.elems - @anded-contents.elems); @anded-contents.push: 0 xx ($b.elems - @anded-contents.elems); ($a.WHAT === $b.WHAT ?? $a !! Buf).new(@anded-contents); } multi sub infix:<~|>(Blob:D $a, Blob:D $b) { my $minlen = $a.elems min $b.elems; my @ored-contents = $a.list[^$minlen] «+|» $b.list[^$minlen]; @ored-contents.push: $a.list[@ored-contents.elems ..^ $a.elems]; @ored-contents.push: $b.list[@ored-contents.elems ..^ $b.elems]; ($a.WHAT === $b.WHAT ?? $a !! Buf).new(@ored-contents); } multi sub infix:<~^>(Blob:D $a, Blob:D $b) { my $minlen = $a.elems min $b.elems; my @xored-contents = $a.list[^$minlen] «+^» $b.list[^$minlen]; @xored-contents.push: $a.list[@xored-contents.elems ..^ $a.elems]; @xored-contents.push: $b.list[@xored-contents.elems ..^ $b.elems]; ($a.WHAT === $b.WHAT ?? $a !! Buf).new(@xored-contents); } multi infix:(Blob:D $a, Blob:D $b) { if $a.WHAT === $b.WHAT && $a.elems == $b.elems { my int $n = $a.elems; my int $i = 0; my Mu $da := nqp::decont($a); my Mu $db := nqp::decont($b); while $i < $n { return False unless nqp::iseq_i(nqp::atpos_i($da, $i), nqp::atpos_i($db, $i)); $i = $i + 1; } True } else { False } } multi sub infix:(Blob:D $a, Blob:D $b) { [||] $a.list Z<=> $b.list or $a.elems <=> $b.elems } multi sub infix:(Blob:D $a, Blob:D $b) { $a.elems == $b.elems && $a.list eq $b.list } multi sub infix:(Blob:D $a, Blob:D $b) { not $a eq $b; } multi sub infix:(Blob:D $a, Blob:D $b) { ($a cmp $b) == -1 } multi sub infix:(Blob:D $a, Blob:D $b) { ($a cmp $b) == 1 } multi sub infix:(Blob:D $a, Blob:D $b) { ($a cmp $b) != 1 } multi sub infix:(Blob:D $a, Blob:D $b) { ($a cmp $b) != -1 } rakudo-2013.12/src/core/Callable.pm0000664000175000017500000000012012224263172016351 0ustar moritzmoritzmy role Callable[::T = Mu] { method of() { T } method returns() { T } } rakudo-2013.12/src/core/CallFrame.pm0000664000175000017500000000374712255230276016525 0ustar moritzmoritzmy class CallFrame { has Int $.level; has %.annotations; has %.my; method new(Int :$level = 0) { my $l = $level + 1; my $self := nqp::create(CallFrame); #?if parrot my Mu $interp := pir::getinterp__P; nqp::bindattr($self, CallFrame, '%!annotations', Q:PIR { .local pmc interp, annon .local int level interp = find_lex '$interp' $P0 = find_lex '$l' level = repr_unbox_int $P0 annon = interp["annotations"; level] %r = nqp_hllize annon } ); my Mu $lexpad := Q:PIR { .local pmc interp .local int level interp = find_lex '$interp' $P0 = find_lex '$l' level = $P0 # no idea why we need this: %r = interp["lexpad"; level] }; my $h := nqp::create(EnumMap); nqp::bindattr($h, EnumMap, '$!storage', $lexpad); nqp::bindattr($self, CallFrame, '%!my', $h); #?endif #?if !parrot my $i = $l; my Mu $ctx := nqp::ctx(); while $i-- { $ctx := nqp::ctxcaller($ctx); } my $h := nqp::create(EnumMap); nqp::bindattr($h, EnumMap, '$!storage', $ctx); nqp::bindattr($self, CallFrame, '%!my', $h); nqp::bindattr($self, CallFrame, '$!level', $l); my $e := nqp::handle(nqp::die(''), 'CATCH', nqp::exception()); my $bt := nqp::backtrace($e); nqp::bindattr($self, CallFrame, '%!annotations', nqp::hllize(nqp::atkey(nqp::atpos($bt, $l), 'annotations'))); #?endif $self; } method line() { %.annotations; } method file() { %.annotations; } method callframe(Int $level = 0) { X::NYI.new(feature => 'Callframe.callframe').throw; } } sub callframe(Int $level = 0) { CallFrame.new(level => ($level + 1)); } # vim: ft=perl6 rakudo-2013.12/src/core/Capture.pm0000664000175000017500000000672112225320406016265 0ustar moritzmoritzmy class Capture { # declared in BOOTSTRAP # class Capture is Any { # has Mu $!list; # positional parameters # has Mu $!hash; # named parameters submethod BUILD(:@list, :%hash) { nqp::bindattr(self, Capture, '$!list', nqp::getattr(nqp::decont(@list.Parcel), Parcel, '$!storage') ); nqp::bindattr(self, Capture, '$!hash', nqp::getattr(nqp::decont(%hash), EnumMap, '$!storage') ); 1; } method at_key(Capture:D: $key is copy) { $key = $key.Str; nqp::existskey($!hash, nqp::unbox_s($key)) ?? nqp::atkey($!hash, nqp::unbox_s($key)) !! Any } method at_pos(Capture:D: $pos is copy) { $pos = $pos.Int; nqp::existspos($!list, nqp::unbox_i($pos)) ?? nqp::atpos($!list, nqp::unbox_i($pos)) !! Any } method hash(Capture:D:) { my $enum := nqp::create(EnumMap); nqp::bindattr($enum, EnumMap, '$!storage', $!hash); $enum; } method exists (Capture:D: $key ) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_key($key); } method exists_key(Capture:D: $key ) { nqp::p6bool(nqp::existskey($!hash, nqp::unbox_s($key.Str))); } method list(Capture:D:) { nqp::p6list(nqp::clone($!list), List, Mu); } method elems(Capture:D:) { nqp::p6box_i(nqp::elems($!list)) } multi method gist(Capture:D:) { my Mu $gist := nqp::list(); if $!list { my Mu $iter := nqp::iterator($!list); nqp::push($gist, nqp::unbox_s(nqp::shift($iter).gist)) while $iter; } if $!hash { my Mu $iter := nqp::iterator($!hash); while $iter { my $kv := nqp::shift($iter); nqp::push($gist, nqp::unbox_s((nqp::p6box_s($kv) => $kv.value).gist)); } } nqp::p6box_s(nqp::join(' ', $gist)) } multi method Str(Capture:D:) { my Mu $str := nqp::list_s(); if $!list { my Mu $iter := nqp::iterator($!list); nqp::push_s($str, nqp::unbox_s(nqp::shift($iter).Str)) while $iter; } if $!hash { my Mu $iter := nqp::iterator($!hash); while $iter { my $kv := nqp::shift($iter); nqp::push_s($str, nqp::unbox_s((nqp::p6box_s($kv) => $kv.value).Str)); } } nqp::p6box_s(nqp::join(' ', $str)) } multi method Bool(Capture:D:) { $!list || $!hash ?? True !! False } method Capture(Capture:D:) { self } multi method Numeric(Capture:D:) { self.elems } method FLATTENABLE_LIST() { $!list ?? $!list !! nqp::list() } method FLATTENABLE_HASH() { $!hash ?? $!hash !! nqp::hash() } method pairs(Capture:D:) { (self.list.pairs, self.hash.pairs).flat } method values(Capture:D:) { (self.list.values, self.hash.values).flat } method keys(Capture:D:) { (self.list.keys, self.hash.keys).flat } method kv(Capture:D:) { (self.list.kv, self.hash.kv).flat } multi method perl(Capture:D:) { join '', self.^name, '.new( list => ', self.list.perl, ', hash => ', self.hash.perl, ')'; } } multi sub infix:(Capture $a, Capture $b) { $a.WHAT === $b.WHAT && $a.list eqv $b.list && $a.hash eqv $b.hash } rakudo-2013.12/src/core/Code.pm0000664000175000017500000000155012224263172015534 0ustar moritzmoritzmy class Code does Callable { # declared in BOOTSTRAP # class Code is Any { # has Mu $!do; # Low level code object # has Mu $!signature; # Signature object # has Mu $!compstuff; # Place for the compiler to hang stuff multi method ACCEPTS(Code:D $self: Mu $topic) { $self.count ?? $self($topic) !! $self() } method arity(Code:D:) { $!signature.arity } method count(Code:D:) { $!signature.count } method signature(Code:D:) { $!signature } multi method Str(Code:D:) { self.name } method outer(Code:D:) { nqp::getcodeobj(nqp::p6staticouter($!do)) } # returns an identifier for this code object # that is the same even for cloned closures method static_id(Code:D:) { nqp::p6box_i(nqp::where(nqp::getstaticcode($!do))); } } rakudo-2013.12/src/core/Complex.pm0000664000175000017500000002700012224263172016267 0ustar moritzmoritzmy class Complex is Cool does Numeric { has num $.re; has num $.im; proto method new(|) { * } multi method new(Real \re, Real \im) { my $new = nqp::create(self); $new.BUILD(re.Num, im.Num); $new; } method BUILD(Num \re, Num \im) { $!re = re; $!im = im; } method reals(Complex:D:) { (self.re, self.im); } method isNaN(Complex:D:) { self.re.isNaN || self.im.isNaN; } my class X::Numeric::Real { ... }; method coerce-to-real(Complex:D: $exception-target) { unless $!im == 0 { fail X::Numeric::Real.new(target => $exception-target, reason => "imaginary part not zero", source => self);} $!re; } multi method Real(Complex:D:) { self.coerce-to-real(Real); } # should probably be eventually supplied by role Numeric method Num(Complex:D:) { self.coerce-to-real(Num).Num; } method Int(Complex:D:) { self.coerce-to-real(Int).Int; } method Rat(Complex:D:) { self.coerce-to-real(Rat).Rat; } multi method Bool(Complex:D:) { $!re != 0e0 || $!im != 0e0; } method Complex() { self } multi method Str(Complex:D:) { my Str $i = nqp::isnanorinf($!im) ?? '\\i' !! 'i'; $!im < 0e0 ?? nqp::p6box_s($!re) ~ '-' ~ nqp::p6box_s(nqp::abs_n($!im)) ~ $i !! nqp::p6box_s($!re) ~ '+' ~ nqp::p6box_s($!im) ~ $i; } multi method perl(Complex:D:) { "Complex.new($.re, $.im)"; } method conj(Complex:D:) { Complex.new($.re, -$.im); } method abs(Complex $x:) { nqp::p6box_n(nqp::sqrt_n( nqp::add_n( nqp::mul_n($!re, $!re), nqp::mul_n($!im, $!im), ) )) } method polar() { $.abs, $!im.atan2($!re); } multi method log(Complex:D:) { my Num ($mag, $angle) = self.polar; Complex.new($mag.log, $angle); } method sqrt(Complex:D:) { my Num ($mag, $angle) = self.polar; $mag.sqrt.unpolar($angle/2); } multi method exp(Complex:D:) { my Num $mag = $!re.exp; Complex.new($mag * $!im.cos, $mag * $!im.sin); } method roots(Complex:D: $an) { my Int $n = $an.Int; return $NaN if $n < 1; return self if $n == 1; for $!re, $!im { return $NaN if $_ eq 'Inf' || $_ eq '-Inf' || $_ eq 'NaN'; } my ($mag, $angle) = self.polar; $mag **= 1e0 / $n; (^$n).map: { $mag.unpolar( ($angle + $_ * 2e0 * pi) / $n) }; } method sin(Complex:D:) { $!re.sin * $!im.cosh + ($!re.cos * $!im.sinh)i; } method asin(Complex:D:) { (Complex.new(0, -1) * log((self)i + sqrt(1 - self * self))); } method cos(Complex:D:) { $!re.cos * $!im.cosh - ($!re.sin * $!im.sinh)i; } method acos(Complex:D:) { (pi / 2) - self.asin; } method tan(Complex:D:) { self.sin / self.cos; } method atan(Complex:D:) { ((log(1 - (self)i) - log(1 + (self)i))i / 2); } method sec(Complex:D:) { 1 / self.cos; } method asec(Complex:D:) { (1 / self).acos; } method cosec(Complex:D:) { 1 / self.sin; } method acosec(Complex:D:) { (1 / self).asin; } method cotan(Complex:D:) { self.cos / self.sin; } method acotan(Complex:D:) { (1 / self).atan; } method sinh(Complex:D:) { -((Complex.new(0, 1) * self).sin)i; } method asinh(Complex:D:) { (self + sqrt(1 + self * self)).log; } method cosh(Complex:D:) { (Complex.new(0, 1) * self).cos; } method acosh(Complex:D:) { (self + sqrt(self * self - 1)).log; } method tanh(Complex:D:) { -((Complex.new(0, 1) * self).tan)i; } method atanh(Complex:D:) { (((1 + self) / (1 - self)).log / 2); } method sech(Complex:D:) { 1 / self.cosh; } method asech(Complex:D:) { (1 / self).acosh; } method cosech(Complex:D:) { 1 / self.sinh; } method acosech(Complex:D:) { (1 / self).asinh; } method cotanh(Complex:D:) { 1 / self.tanh; } method acotanh(Complex:D:) { (1 / self).atanh; } method floor(Complex:D:) { Complex.new( self.re.floor, self.im.floor ); } method ceiling(Complex:D:) { Complex.new( self.re.ceiling, self.im.ceiling ); } proto method round(|) {*} multi method round(Complex:D: $scale as Real = 1) { Complex.new( self.re.round($scale), self.im.round($scale) ); } method truncate(Complex:D:) { Complex.new( self.re.truncate, self.im.truncate ); } } multi sub prefix:<->(Complex:D \a) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n( $new, Complex, '$!re', nqp::neg_n( nqp::getattr_n(nqp::decont(a), Complex, '$!re') ) ); nqp::bindattr_n( $new, Complex, '$!im', nqp::neg_n( nqp::getattr_n(nqp::decont(a), Complex, '$!im') ) ); $new; } multi sub abs(Complex:D \a) returns Num:D { my num $re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); my num $im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); nqp::p6box_n(nqp::sqrt_n(nqp::add_n(nqp::mul_n($re, $re), nqp::mul_n($im, $im)))); } multi sub infix:<+>(Complex:D \a, Complex:D \b) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n( $new, Complex, '$!re', nqp::add_n( nqp::getattr_n(nqp::decont(a), Complex, '$!re'), nqp::getattr_n(nqp::decont(b), Complex, '$!re'), ) ); nqp::bindattr_n( $new, Complex, '$!im', nqp::add_n( nqp::getattr_n(nqp::decont(a), Complex, '$!im'), nqp::getattr_n(nqp::decont(b), Complex, '$!im'), ) ); $new; } multi sub infix:<+>(Complex:D \a, Real \b) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n( $new, Complex, '$!re', nqp::add_n( nqp::getattr_n(nqp::decont(a), Complex, '$!re'), nqp::unbox_n(b.Num) ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::getattr_n(nqp::decont(a), Complex, '$!im'), ); $new } multi sub infix:<+>(Real \a, Complex:D \b) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n($new, Complex, '$!re', nqp::add_n( nqp::unbox_n(a.Num), nqp::getattr_n(nqp::decont(b), Complex, '$!re'), ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::getattr_n(nqp::decont(b), Complex, '$!im'), ); $new; } multi sub infix:<->(Complex:D \a, Complex:D \b) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n( $new, Complex, '$!re', nqp::sub_n( nqp::getattr_n(nqp::decont(a), Complex, '$!re'), nqp::getattr_n(nqp::decont(b), Complex, '$!re'), ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::sub_n( nqp::getattr_n(nqp::decont(a), Complex, '$!im'), nqp::getattr_n(nqp::decont(b), Complex, '$!im'), ) ); $new } multi sub infix:<->(Complex:D \a, Real \b) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n( $new, Complex, '$!re', nqp::sub_n( nqp::getattr_n(nqp::decont(a), Complex, '$!re'), b.Num, ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::getattr_n(nqp::decont(a), Complex, '$!im') ); $new } multi sub infix:<->(Real \a, Complex:D \b) returns Complex:D { my $new := nqp::create(Complex); nqp::bindattr_n( $new, Complex, '$!re', nqp::sub_n( a.Num, nqp::getattr_n(nqp::decont(b), Complex, '$!re'), ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::neg_n( nqp::getattr_n(nqp::decont(b), Complex, '$!im') ) ); $new } multi sub infix:<*>(Complex:D \a, Complex:D \b) returns Complex:D { my num $a_re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); my num $a_im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); my num $b_re = nqp::getattr_n(nqp::decont(b), Complex, '$!re'); my num $b_im = nqp::getattr_n(nqp::decont(b), Complex, '$!im'); my $new := nqp::create(Complex); nqp::bindattr_n($new, Complex, '$!re', nqp::sub_n(nqp::mul_n($a_re, $b_re), nqp::mul_n($a_im, $b_im)), ); nqp::bindattr_n($new, Complex, '$!im', nqp::add_n(nqp::mul_n($a_re, $b_im), nqp::mul_n($a_im, $b_re)), ); $new; } multi sub infix:<*>(Complex:D \a, Real \b) returns Complex:D { my $new := nqp::create(Complex); my num $b_num = b.Num; nqp::bindattr_n($new, Complex, '$!re', nqp::mul_n( nqp::getattr_n(nqp::decont(a), Complex, '$!re'), $b_num, ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::mul_n( nqp::getattr_n(nqp::decont(a), Complex, '$!im'), $b_num, ) ); $new } multi sub infix:<*>(Real \a, Complex:D \b) returns Complex:D { my $new := nqp::create(Complex); my num $a_num = a.Num; nqp::bindattr_n($new, Complex, '$!re', nqp::mul_n( $a_num, nqp::getattr_n(nqp::decont(b), Complex, '$!re'), ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::mul_n( $a_num, nqp::getattr_n(nqp::decont(b), Complex, '$!im'), ) ); $new } multi sub infix:(Complex:D \a, Complex:D \b) returns Complex:D { my num $a_re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); my num $a_im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); my num $b_re = nqp::getattr_n(nqp::decont(b), Complex, '$!re'); my num $b_im = nqp::getattr_n(nqp::decont(b), Complex, '$!im'); my num $d = nqp::add_n(nqp::mul_n($b_re, $b_re), nqp::mul_n($b_im, $b_im)); my $new := nqp::create(Complex); nqp::bindattr_n($new, Complex, '$!re', nqp::div_n( nqp::add_n(nqp::mul_n($a_re, $b_re), nqp::mul_n($a_im, $b_im)), $d, ) ); nqp::bindattr_n($new, Complex, '$!im', nqp::div_n( nqp::sub_n(nqp::mul_n($a_im, $b_re), nqp::mul_n($a_re, $b_im)), $d, ) ); $new; } multi sub infix:(Complex:D \a, Real \b) returns Complex:D { Complex.new(a.re / b, a.im / b); } multi sub infix:(Real \a, Complex:D \b) returns Complex:D { Complex.new(a, 0) / b; } multi sub infix:<**>(Complex:D \a, Complex:D \b) returns Complex:D { (a.re == 0e0 && a.im == 0e0) ?? Complex.new(0e0, 0e0) !! (b * a.log).exp } multi sub infix:<**>(Real \a, Complex:D \b) returns Complex:D { a == 0 ?? Complex.new(0e0, 0e0) !! (b * a.log).exp } multi sub infix:<**>(Complex:D \a, Real \b) returns Complex:D { (b * a.log).exp } multi sub infix:<==>(Complex:D \a, Complex:D \b) returns Bool:D { a.re == b.re && a.im == b.im } multi sub infix:<==>(Complex:D \a, Real \b) returns Bool:D { a.re == b && a.im == 0e0 } multi sub infix:<==>(Real \a, Complex:D \b) returns Bool:D { a == b.re && 0e0 == b.im } proto postfix:(|) returns Complex:D is pure { * } multi postfix:(Real \a) returns Complex:D { Complex.new(0e0, a); } multi postfix:(Complex:D \a) returns Complex:D { Complex.new(-a.im, a.re) } multi postfix:(Numeric \a) returns Complex:D { a * Complex.new(0e0, 1e0) } multi postfix:(Cool \a) returns Complex:D { a.Numeric * Complex.new(0e0, 1e0) } constant i = Complex.new(0e0, 1e0); # vim: ft=perl6 rakudo-2013.12/src/core/control.pm0000664000175000017500000001424512242026101016334 0ustar moritzmoritzmy class X::Eval::NoSuchLang { ... } my class PseudoStash { ... } my &THROW := -> | { my Mu $args := nqp::p6argvmarray(); my Mu $ex := nqp::newexception(); nqp::setpayload($ex, nqp::atpos($args, 0)); nqp::setextype($ex, nqp::atpos($args, 1)); #?if parrot pir::setattribute__vPsP($ex, 'severity', pir::const::EXCEPT_NORMAL); #?endif nqp::throw($ex); 0 }; my &RETURN-PARCEL := -> Mu \parcel { my Mu $storage := nqp::getattr(parcel, Parcel, '$!storage'); nqp::iseq_i(nqp::elems($storage), 0) ?? Nil !! (nqp::iseq_i(nqp::elems($storage), 1) ?? nqp::shift($storage) !! parcel) } my &return-rw := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); nqp::p6routinereturn($parcel); $parcel }; my &return := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); nqp::p6routinereturn(nqp::p6recont_ro($parcel)); $parcel }; my &take-rw := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); THROW($parcel, nqp::const::CONTROL_TAKE); $parcel }; my &take := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); THROW(nqp::p6recont_ro($parcel), nqp::const::CONTROL_TAKE); $parcel }; my &last := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); THROW(nqp::decont($parcel), nqp::const::CONTROL_LAST) }; my &next := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); THROW(nqp::decont($parcel), nqp::const::CONTROL_NEXT) }; my &redo := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); THROW(nqp::decont($parcel), nqp::const::CONTROL_REDO) }; my &succeed := -> | { my $parcel := &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil)); THROW(nqp::decont($parcel), nqp::const::CONTROL_SUCCEED) }; my &proceed := -> { THROW(Nil, nqp::const::CONTROL_PROCEED) } my &callwith := -> *@pos, *%named { my Mu $dispatcher := nqp::p6finddispatcher('callwith'); $dispatcher.exhausted ?? Nil !! $dispatcher.call_with_args(|@pos, |%named) }; my &nextwith := -> *@pos, *%named { my Mu $dispatcher := nqp::p6finddispatcher('nextwith'); unless $dispatcher.exhausted { nqp::p6routinereturn(nqp::p6recont_ro( $dispatcher.call_with_args(|@pos, |%named))) } Nil }; my &callsame := -> { my Mu $dispatcher := nqp::p6finddispatcher('callsame'); $dispatcher.exhausted ?? Nil !! $dispatcher.call_with_capture( nqp::p6argsfordispatcher($dispatcher)) }; my &nextsame := -> { my Mu $dispatcher := nqp::p6finddispatcher('nextsame'); unless $dispatcher.exhausted { nqp::p6routinereturn(nqp::p6recont_ro( $dispatcher.call_with_capture( nqp::p6argsfordispatcher($dispatcher)))) } Nil }; my &lastcall := -> { nqp::p6finddispatcher('lastcall').last(); True }; my &samewith := -> *@pos, *%named { my $my = callframe(1).my; my $self = $my; die "Could not find 'self'" if !$self.DEFINITE; my $dispatcher = $my<&?ROUTINE>.dispatcher || die "Could not find dispatcher"; $dispatcher( $self, |@pos, |%named ); } proto sub die(|) is hidden_from_backtrace {*}; multi sub die(Exception $e) is hidden_from_backtrace { $e.throw } multi sub die($payload) is hidden_from_backtrace { X::AdHoc.new(:$payload).throw } multi sub die(*@msg) is hidden_from_backtrace { X::AdHoc.new(payload => @msg.join).throw } multi sub warn(*@msg) is hidden_from_backtrace { my $ex := nqp::newexception(); nqp::setmessage($ex, nqp::unbox_s(@msg.join(''))); nqp::setextype($ex, nqp::const::CONTROL_WARN); #?if parrot nqp::bindattr($ex, Exception, 'severity', nqp::p6box_i(pir::const::EXCEPT_WARNING)); #?endif nqp::throw($ex); 0; } proto sub eval($, *%) {*} multi sub eval(Str $code, :$lang = 'perl6', PseudoStash :$context) { my $eval_ctx := nqp::getattr(nqp::decont($context // CALLER::CALLER::), PseudoStash, '$!ctx'); my $?FILES := 'eval_' ~ (state $no)++; my $compiler := nqp::getcomp($lang); X::Eval::NoSuchLang.new(:$lang).throw if nqp::isnull($compiler); my $compiled := $compiler.compile($code, :outer_ctx($eval_ctx), :global(GLOBAL)); nqp::forceouterctx(nqp::getattr($compiled, ForeignCode, '$!do'), $eval_ctx); $compiled(); } sub exit($status = 0) { $_() for nqp::hllize(nqp::getcurhllsym('@END_PHASERS')); nqp::exit(nqp::unbox_i($status.Int)); $status; } my class Proc::Status { ... } sub run(*@args ($, *@)) { my $status = Proc::Status.new( :exit(255) ); try { my Mu $hash := nqp::getattr(%*ENV, EnumMap, '$!storage'); $status.status( nqp::p6box_i( nqp::spawn(nqp::getattr(@args.eager, List, '$!items'), $*CWD.Str, $hash) ) ); } $status } sub shell($cmd) { my $status = Proc::Status.new( :exit(255) ); try { my Mu $hash := nqp::getattr(%*ENV, EnumMap, '$!storage'); $status.status( nqp::p6box_i(nqp::shell($cmd, $*CWD.Str, $hash)) ); } $status } # XXX: Temporary definition of $Inf and $NaN until we have constants ava # need to come pretty early, because we use it in lots of setting files # constant Inf = ... # constant NaN = ... my $Inf = nqp::p6box_n(nqp::inf()); my $NaN = nqp::p6box_n(nqp::nan()); # EM 20130627 attempt at using constants failed during optimizing phase sub QX($cmd) { #?if parrot nqp::chdir($*CWD); my Mu $pio := nqp::open(nqp::unbox_s($cmd), 'rp'); fail "Unable to execute '$cmd'" unless $pio; $pio.encoding('utf8'); my $result = nqp::p6box_s($pio.readall()); $pio.close(); $result; #?endif #?if !parrot my Mu $env := nqp::getattr(%*ENV, EnumMap, '$!storage'); my Mu $pio := nqp::openpipe(nqp::unbox_s($cmd), $*CWD.Str, $env, ''); fail "Unable to execute '$cmd'" unless $pio; my $result = nqp::p6box_s(nqp::readallfh($pio)); nqp::closefh($pio); $result; #?endif } sub EXHAUST(|) { X::ControlFlow::Return.new.throw(); } rakudo-2013.12/src/core/Cool.pm0000664000175000017500000002116212242026101015544 0ustar moritzmoritzmy role IO { ... } my class IO::Handle { ... } my class SprintfHandler { method mine($x) { nqp::reprname($x) eq "P6opaque"; } method int($x) { $x.Int } } my $sprintfHandlerInitialized = False; my class Cool { # declared in BOOTSTRAP # class Cool is Any { ## numeric methods method abs() { self.Numeric.abs } method conj() { self.Numeric.conj } method sqrt() { self.Numeric.sqrt } method sign() { self.Numeric.sign } method rand() { self.Num.rand } method sin() { self.Numeric.sin } method asin() { self.Numeric.asin } method cos() { self.Numeric.cos } method acos() { self.Numeric.acos } method tan() { self.Numeric.tan } method atan() { self.Numeric.atan } method atan2($y = 1e0) { self.Numeric.atan2($y.Numeric) } method sec() { self.Numeric.sec } method asec() { self.Numeric.asec } method cosec() { self.Numeric.cosec } method acosec() { self.Numeric.acosec } method cotan() { self.Numeric.cotan } method acotan() { self.Numeric.acotan } method sinh() { self.Numeric.sinh } method asinh() { self.Numeric.asinh } method cosh() { self.Numeric.cosh } method acosh() { self.Numeric.acosh } method tanh() { self.Numeric.tanh } method atanh() { self.Numeric.atanh } method sech() { self.Numeric.sech } method asech() { self.Numeric.asech } method cosech() { self.Numeric.cosech } method acosech() { self.Numeric.acosech } method cotanh() { self.Numeric.cotanh } method acotanh() { self.Numeric.acotanh } method cis() { self.Numeric.cis } proto method log(|) {*} multi method log(Cool:D: ) { self.Numeric.log } multi method log(Cool:D: $base) { self.Numeric.log($base.Numeric) } proto method exp(|) {*} multi method exp(Cool:D: ) { self.Numeric.exp } multi method exp(Cool:D: $base) { self.Numeric.exp($base.Numeric) } method roots(Cool $n) { self.Numeric.roots($n) } method log10() { self.Numeric.log10 } method unpolar($n) { self.Numeric.unpolar($n.Numeric) } method round($base = 1) { self.Numeric.round($base) } method floor() { self.Numeric.floor } method ceiling() { self.Numeric.ceiling } method truncate() { self.Numeric.truncate } ## string methods method chars() { nqp::p6box_i(nqp::chars(nqp::unbox_s(self.Str))); } method codes() { nqp::p6box_i(nqp::chars(nqp::unbox_s(self.Str))); } method fmt($format = '%s') { unless $sprintfHandlerInitialized { nqp::sprintfaddargumenthandler(SprintfHandler.new); $sprintfHandlerInitialized = True; } nqp::p6box_s( nqp::sprintf(nqp::unbox_s($format.Stringy), nqp::list(self)) ) } method substr($start, $length?) { self.Stringy.substr($start, $length); } method uc() { nqp::p6box_s(nqp::uc(nqp::unbox_s(self.Str))) } method lc() { nqp::p6box_s(nqp::lc(nqp::unbox_s(self.Str))) } method tc() { my $u := nqp::unbox_s(self.Str); nqp::p6box_s(nqp::uc(nqp::substr($u,0,1)) ~ nqp::substr($u,1)); } method tclc() { nqp::p6box_s(nqp::tclc(nqp::unbox_s(self.Str))) } method ucfirst() { # is DEPRECATED doesn't work in settings DEPRECATED("'tc'"); self.tc; } method wordcase() { self.Str.wordcase } method chomp() { self.Str.chomp; } method chop() { self.Str.chop } method ord(--> Int) { my $s := self.Str; $s.chars ?? nqp::p6box_i(nqp::ord(nqp::unbox_s($s))) !! Int; } method chr() { self.Int.chr; } method chrs(Cool:D:) { self>>.chr.join; } method flip() { nqp::p6box_s(nqp::flip(nqp::unbox_s(self.Str))) } method trans(*@a) { self.Str.trans(@a) } proto method index(|) {*} multi method index(Cool $needle, Cool $pos = 0) { if $needle eq '' { my $chars = self.chars; return $pos < $chars ?? $pos !! $chars; } my $result := nqp::p6box_i(nqp::index( nqp::unbox_s(self.Str), nqp::unbox_s($needle.Str), nqp::unbox_i($pos.Int) )); # TODO: fail() instead of returning Int $result < 0 ?? Int !! $result; } proto method rindex(|) {*} multi method rindex(Cool $needle, Cool $pos?) { if $needle eq '' { return $pos.defined && $pos < self.chars ?? $pos !! self.chars; } my $result = $pos.defined ?? nqp::p6box_i( nqp::rindex( nqp::unbox_s(self.Str), nqp::unbox_s($needle.Str), nqp::unbox_i($pos.Int) )) !! nqp::p6box_i( nqp::rindex( nqp::unbox_s(self.Str), nqp::unbox_s($needle.Str), )); fail "substring not found" if $result < 0; $result; } method ords(Cool:D:) { self.Str.ords } proto method split(|) {*} multi method split(Regex $pat, $limit = $Inf, :$all) { self.Stringy.split($pat, $limit, :$all); } multi method split(Cool $pat, $limit = $Inf, :$all) { self.Stringy.split($pat.Stringy, $limit, :$all); } proto method match(|) {*} multi method match(Cool:D: $target, *%adverbs) { self.Stringy.match($target, |%adverbs) } proto method comb(|) {*} multi method comb() { self.Str.comb() } multi method comb(Regex $matcher, $limit = $Inf) { self.Str.comb($matcher, $limit) } proto method lines(|) {*} multi method lines(Cool:D:) { self.Str.lines() } proto method subst(|) { $/ := nqp::getlexdyn('$/'); {*} } multi method subst($matcher, $replacement, *%adverbs) { $/ := nqp::getlexdyn('$/'); self.Stringy.subst($matcher, $replacement, |%adverbs); } method sprintf(*@args) { sprintf(self, @args) }; method printf (*@args) { printf(self, @args) }; method samecase(Cool:D: Cool $pattern) { self.Stringy.samecase($pattern) } method IO() { IO::Handle.new(:path(self.Stringy)) } method path() { self.Stringy.path } method trim () { self.Stringy.trim }; method trim-leading () { self.Stringy.trim-leading }; method trim-trailing() { self.Stringy.trim-trailing }; method eval(*%opts) { eval(self.Stringy, context => CALLER::, |%opts); } multi method Real() { self.Numeric.Real } method Int() { self.Numeric.Int } method Num() { self.Numeric.Num } method Rat() { self.Numeric.Rat } } Metamodel::ClassHOW.exclude_parent(Cool); sub ucfirst(Cool $s) { # is DEPRECATED doesn't work in settings DEPRECATED("'tc'"); $s.tc; } sub chop(Cool $s) { $s.chop } sub chomp(Cool $s) { $s.chomp } sub flip(Cool $s) { $s.flip } sub index(Cool $s,$needle,$pos=0) { $s.index($needle,$pos) } sub lc(Cool $s) { $s.lc } sub ord(Cool $s) { $s.ord } sub substr(Cool $s,$pos,$chars?) { $s.substr($pos,$chars) } sub uc(Cool $s) { $s.uc } sub tc(Cool $s) { $s.tc } sub tclc(Cool $s) { $s.tclc } proto sub rindex($, $, $?) is pure { * }; multi sub rindex(Cool $s, Cool $needle, Cool $pos) { $s.rindex($needle, $pos) }; multi sub rindex(Cool $s, Cool $needle) { $s.rindex($needle) }; proto sub ords($) is pure { * } multi sub ords(Cool $s) { ords($s.Stringy) } proto sub comb($, $, $?) { * } multi sub comb(Regex $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } proto sub wordcase($) is pure { * } multi sub wordcase(Str:D $x) {$x.wordcase } multi sub wordcase(Cool $x) {$x.Str.wordcase } sub sprintf(Cool $format, *@args) { unless $sprintfHandlerInitialized { nqp::sprintfaddargumenthandler(SprintfHandler.new); $sprintfHandlerInitialized = True; } @args.gimme(*); nqp::p6box_s( nqp::sprintf(nqp::unbox_s($format.Stringy), nqp::clone(nqp::getattr(@args, List, '$!items')) ) ); } sub printf(Cool $format, *@args) { print sprintf $format, @args }; sub samecase(Cool $string, Cool $pattern) { $string.samecase($pattern) } sub split($pat, Cool $target, $limit = $Inf, :$all) { $target.split($pat, $limit, :$all); } proto sub chars($) is pure {*} multi sub chars(Cool $x) { $x.Str.chars } multi sub chars(Str:D $x) { nqp::p6box_i(nqp::chars($x)) } multi sub chars(str $x) returns int { nqp::chars($x) } rakudo-2013.12/src/core/core_epilogue.pm0000664000175000017500000000211512225320406017474 0ustar moritzmoritz# Re-parent meta-objects so they appear to be under Any. BEGIN { Perl6::Metamodel::ClassHOW.HOW.reparent(Perl6::Metamodel::ClassHOW, Any); Perl6::Metamodel::ConcreteRoleHOW.HOW.reparent(Perl6::Metamodel::ConcreteRoleHOW, Any); Perl6::Metamodel::CurriedRoleHOW.HOW.reparent(Perl6::Metamodel::CurriedRoleHOW, Any); Perl6::Metamodel::EnumHOW.HOW.reparent(Perl6::Metamodel::EnumHOW, Any); Perl6::Metamodel::GenericHOW.HOW.reparent(Perl6::Metamodel::GenericHOW, Any); Perl6::Metamodel::ModuleHOW.HOW.reparent(Perl6::Metamodel::ModuleHOW, Any); Perl6::Metamodel::NativeHOW.HOW.reparent(Perl6::Metamodel::NativeHOW, Any); Perl6::Metamodel::PackageHOW.HOW.reparent(Perl6::Metamodel::PackageHOW, Any); Perl6::Metamodel::ParametricRoleGroupHOW.HOW.reparent(Perl6::Metamodel::ParametricRoleGroupHOW, Any); Perl6::Metamodel::ParametricRoleHOW.HOW.reparent(Perl6::Metamodel::ParametricRoleHOW, Any); Perl6::Metamodel::SubsetHOW.HOW.reparent(Perl6::Metamodel::SubsetHOW, Any); Perl6::Metamodel::GrammarHOW.HOW.compose(Perl6::Metamodel::GrammarHOW); } {YOU_ARE_HERE} rakudo-2013.12/src/core/core_prologue.pm0000664000175000017500000000045312224263172017527 0ustar moritzmoritzuse Perl6::BOOTSTRAP; # Stub a few things the compiler wants to have really early on. my class Pair { ... } my class Whatever { ... } my class WhateverCode { ... } # Stub these or we can't use any sigil other than $. my role Positional { ... } my role Associative { ... } my role Callable { ... } rakudo-2013.12/src/core/Cursor.pm0000664000175000017500000002014712224263172016142 0ustar moritzmoritzmy class Cursor does NQPCursorRole { has $!ast; # Need it to survive re-creations of the match object. # Some bits to support my $last_match; method MATCH() { my $match := nqp::getattr(self, Cursor, '$!match'); return $match if nqp::istype($match, Match) && nqp::isconcrete($match); $match := nqp::create(Match); nqp::bindattr($match, Match, '$!orig', nqp::findmethod(self, 'orig')(self)); nqp::bindattr_i($match, Match, '$!from', nqp::getattr_i(self, Cursor, '$!from')); nqp::bindattr_i($match, Match, '$!to', nqp::getattr_i(self, Cursor, '$!pos')); nqp::bindattr($match, Match, '$!ast', nqp::getattr(self, Cursor, '$!ast')); nqp::bindattr($match, Match, '$!CURSOR', self); my Mu $list := nqp::list(); my Mu $hash := nqp::hash(); if $match.Bool { my Mu $caphash := nqp::findmethod(Cursor, 'CAPHASH')(self); my Mu $capiter := nqp::iterator($caphash); while $capiter { my Mu $kv := nqp::shift($capiter); my str $key = nqp::iterkey_s($kv); my Mu $value := nqp::hllize(nqp::atkey($caphash, $key)); if $key eq '$!from' || $key eq '$!to' { nqp::bindattr_i($match, Match, $key, $value.from); } else { $value := nqp::p6list($value, List, Mu) if nqp::islist($value); nqp::iscclass(nqp::const::CCLASS_NUMERIC, $key, 0) ?? nqp::bindpos($list, $key, $value) !! nqp::bindkey($hash, $key, $value); } } } nqp::bindattr($match, Capture, '$!list', $list); nqp::bindattr($match, Capture, '$!hash', $hash); nqp::bindattr(self, Cursor, '$!match', $match); $match; } method MATCH_SAVE() { return Nil if nqp::getattr_i(self, Cursor, '$!pos') < 0; my $match := self.MATCH(); $last_match := $match if $match; $match; } # INTERPOLATE will iterate over the string $tgt beginning at position 0. # If it can't match against pattern $var (or any element of $var if it is an array) # it will increment $pos and try again. Therefor it is important to only match # against the current position. # $i is case insensitive flag # $s is for sequential matching instead of junctive # $a is true if we are in an assertion method INTERPOLATE($var, $i = 0, $s = 0, $a = 0) { if nqp::isconcrete($var) { # Call it if it is a routine. This will capture if requested. return $var(self) if $var ~~ Callable; my $maxlen := -1; my $cur := self.'!cursor_start_cur'(); my $pos := nqp::getattr_i($cur, $?CLASS, '$!from'); my $tgt := $cur.target; my $eos := nqp::chars($tgt); my Mu $nfa := QRegex::NFA.new; my $fate := 0; my $count := 0; my $start := 1; my Mu $alts := nqp::list(); my Mu $order := nqp::list(); if nqp::istype($var, Positional) { if $s { # The order matters for sequential matching, therefor no NFA involved. $order := $var.list; } else { # prepare to run the NFA if $var is array-ish. for $var.list -> $topic { nqp::push($alts, $topic); if $a { # We are in a regex assertion, the strings we get will be treated as # regex rules. my $rx := eval( $i ?? "my \$x = anon regex \{:i ^$topic \}" !! "my \$x = anon regex \{ ^$topic \}" ); my Mu $nfas := nqp::findmethod($rx, 'NFA')($rx); $nfa.mergesubstates($start, 0, $fate, $nfas, Mu); } elsif $topic ~~ Regex { # A Regex already. my Mu $nfas := nqp::findmethod($topic, 'NFA')($topic); $nfa.mergesubstates($start, 0, $fate, $nfas, Mu); } else { # The pattern is a string. my Mu $lit := QAST::Regex.new( :rxtype, $topic, :subtype( $i ?? 'ignorecase' !! '') ); my Mu $nfa2 := QRegex::NFA.new; my Mu $node := nqp::findmethod($nfa2, 'addnode')($nfa2, $lit); my Mu $save := nqp::findmethod($node, 'save')($node, :non_empty(1)); $nfa.mergesubstates($start, 0, $fate, $save, Mu); } $fate := $fate + 1; } # Now run the NFA my Mu $fates := nqp::findmethod($nfa, 'run')($nfa, $tgt, $pos); $fate := 0; $count := nqp::elems($fates); while nqp::islt_i($fate, $count) { my $thing := nqp::atpos_i($fates, $fate); nqp::push($order, nqp::atpos($alts, $thing)); $fate := nqp::add_i($fate, 1); } } } else { # Use the $var as it is if it's not array-ish. $order := $var; } for $order -> $topic { my $match; my $len; if $a { # We are in a regex assertion, the strings we get will be treated as # regex rules. my $rx := eval( $i ?? "my \$x = anon regex \{:i ^$topic \}" !! "my \$x = anon regex \{ ^$topic \}" ); $match := (nqp::substr($tgt, $pos, $eos - $pos) ~~ $rx).Str; $len := nqp::chars( $match ); } elsif $topic ~~ Regex { # A Regex already. $match := nqp::substr($tgt, $pos, $eos - $pos) ~~ $topic; # In order to return the correct result we need to match from the # current position only. next if $match.from; $match := ~$match; $len := nqp::chars( $match ); } else { # The pattern is a string. my str $topic_str = $topic.Str; $len := nqp::chars( $topic_str ); $match := $len < 1 || ($i ?? nqp::lc(nqp::substr($tgt, $pos, $len)) eq nqp::lc($topic_str) !! nqp::substr($tgt, $pos, $len) eq $topic_str); } if $match && $len > $maxlen && $pos + $len <= $eos { $maxlen := $len; last if $s; # stop here for sequential alternation } } $cur.'!cursor_pass'($pos + $maxlen, '') if $maxlen >= 0; $cur } else { self."!cursor_start_cur"() } } method OTHERGRAMMAR($grammar, $name, |) { my $lang_cursor := $grammar.'!cursor_init'(self.target(), :p(self.pos())); $lang_cursor."$name"(); } method RECURSE() { nqp::getlexdyn('$?REGEX')(self) } method prior() { nqp::isconcrete($last_match) ?? self."!LITERAL"(nqp::unbox_s(~$last_match)) !! self."!cursor_start_cur"() } } sub MAKE_REGEX($arg) { my role CachedCompiledRegex { has $.regex; } if $arg ~~ Regex { $arg } elsif nqp::istype($arg, CachedCompiledRegex) { $arg.regex } else { my $rx := eval("my \$x = anon regex \{ $arg \}"); $arg does CachedCompiledRegex($rx); $rx } } rakudo-2013.12/src/core/Deprecations.pm0000664000175000017500000000447012255230273017306 0ustar moritzmoritz my %DEPRECATIONS; # where we keep our deprecation info class Deprecation { has $.file; # file of the code that is deprecated has $.type; # type of code (sub/method etc.) that is deprecated has $.package; # package of code that is deprecated has $.name; # name of code that is deprecated has $.alternative; # alternative for code that is deprecated has %.callsites; # places where called (file -> line -> count) method WHICH { ($!file,$!type,$!package,$!name).join(':') } proto method report (|) { * } multi method report (Deprecation:U:) { return Nil unless %DEPRECATIONS; my $message = "Saw {+%DEPRECATIONS} call{ 's' if +%DEPRECATIONS != 1 } to deprecated code during execution.\n"; $message ~= ("=" x 80) ~ "\n"; for %DEPRECATIONS.values -> $d { $message ~= $d.report; $message ~= ("-" x 80) ~ "\n"; } %DEPRECATIONS = (); # reset for new batches if applicable $message.chop; } multi method report (Deprecation:D:) { my $message = "$.type $.name (from $.package) called at:\n"; for %.callsites.kv -> $file, $lines { $message ~= " $file, line{ 's' if +$lines > 1 } {$lines.keys.join(',')}\n"; } $message ~= "Please use $.alternative instead.\n"; $message; } } sub DEPRECATED ($alternative) { my $bt = Backtrace.new; my $deprecated = $bt[ my $index = $bt.next-interesting-index(2, :named) ]; my $callsite = $bt[$index = $bt.next-interesting-index($index, :noproto)]; # get object, existing or new my $what = Deprecation.new( file => $deprecated.file, type => $deprecated.subtype.tc, package => try { $deprecated.package.HOW.name($deprecated) } // 'unknown', name => $deprecated.subname, :$alternative, ); $what = %DEPRECATIONS{$what.WHICH} //= $what; # update callsite $what.callsites{$callsite.file}{$callsite.line}++; } END { if my $message = Deprecation.report { my Mu $err := nqp::getstderr(); my sub say2 ($s) { nqp::printfh($err, "$s\n") } say2 $message; say2 "Please contact the author to have these calls to deprecated code adapted,"; say2 "so that this message will disappear!"; } } rakudo-2013.12/src/core/Duration.pm0000664000175000017500000000164312224263172016452 0ustar moritzmoritzmy class Duration is Cool does Real { has Rat $.x = 0; # A linear count of seconds. method new($x) { self.bless: x => $x.Rat } method Bridge(Duration:D:) { $!x.Num } method Rat(Duration:D:) { $!x } method Num(Duration:D:) { $!x.Num } multi method Str(Duration:D:) { ~$.x } multi method perl(Duration:D:) { "Duration.new({$.x.perl})" } } multi sub prefix:<->(Duration:D $a) { Duration.new: -$a.x; } multi sub infix:<+>(Duration:D $a, Real $b) { Duration.new: $a.x + $b; } multi sub infix:<+>(Real $a, Duration:D $b) { Duration.new: $a + $b.x; } multi sub infix:<+>(Duration:D $a, Duration:D $b) { Duration.new: $a.x + $b.x; } multi sub infix:<->(Duration:D $a, Real $b) { Duration.new: $a.x - $b; } multi sub infix:<->(Duration:D $a, Duration:D $b) { Duration.new: $a.x - $b.x; } multi sub infix:<%>(Duration:D $a, Real $b) { Duration.new: $a.x % $b } rakudo-2013.12/src/core/Enumeration.pm0000664000175000017500000000402712224263172017152 0ustar moritzmoritz# Method that we have on enumeration types. my role Enumeration { has $.key; has $.value; multi method Numeric(::?CLASS:D:) { $!value.Numeric } method enums() { self.^enum_values } multi method gist(::?CLASS:D:) { $!key } method kv(::?CLASS:D:) { ($!key, $!value) } method pair(::?CLASS:D:) { $!key => $!value } method perl() { self.defined ?? (self.^name ~ '::' ~ $!key) !! self.^name; } method pick(*@pos, *%named) { self.^enum_value_list.pick(|@pos, |%named) } method roll(*@pos, *%named) { self.^enum_value_list.roll(|@pos, |%named) } method Int(::?CLASS:D:) { self.value.Int } method postcircumfix:<( )>($ ($x)) { $x ~~ ::?CLASS ?? $x !! self.^enum_from_value($x) } } # Methods that we also have if the base type of an enumeration is # Numeric. my role NumericEnumeration { multi method Str(::?CLASS:D:) { self.key } } my role StringyEnumeration { multi method Str(::?CLASS:D:) { self.value } } sub ANON_ENUM(*@args) { my Mu $prev = -1; my %res; for @args { if .^isa(Enum) { %res{.key} = .value; } else { %res{$_} = $prev.=succ; } } my $r := nqp::create(EnumMap); nqp::bindattr($r, EnumMap, '$!storage', nqp::getattr(%res, EnumMap, '$!storage')); $r; } Metamodel::EnumHOW.set_composalizer(-> $type, $name, %enum_values { my Mu $r := Metamodel::ParametricRoleHOW.new_type(:name($name)); $r.HOW.add_attribute($r, Attribute.new( :name('$!' ~ $name), :type(nqp::decont($type)), :has_accessor(1), :package($r))); for %enum_values.kv -> $key, $value { my $meth = method () { self."$name"() === $value } $meth.set_name($key); $r.HOW.add_method($r, $key, $meth); } $r.HOW.set_body_block($r, -> |c { nqp::list($r, nqp::hash('$?CLASS', c<$?CLASS>)) }); $r.HOW.compose($r); $r }); rakudo-2013.12/src/core/EnumMap.pm0000664000175000017500000000753712225320406016232 0ustar moritzmoritzmy class EnumMap does Associative { # declared in BOOTSTRAP # my class EnumMap is Iterable is Cool { # has Mu $!storage; multi method Bool(EnumMap:D:) { nqp::p6bool(nqp::defined($!storage) ?? nqp::elems($!storage) !! 0) } method elems(EnumMap:) { self.DEFINITE && nqp::defined($!storage) ?? nqp::p6box_i(nqp::elems($!storage)) !! 0 } multi method ACCEPTS(EnumMap:D: Any $topic) { so self.exists_key($topic.any); } multi method ACCEPTS(EnumMap:D: Cool:D $topic) { so self.exists_key($topic); } multi method ACCEPTS(EnumMap:D: Positional $topic) { so self.exists_key($topic.any); } multi method ACCEPTS(EnumMap:D: Regex $topic) { so self.keys.any.match($topic); } proto method exists(|) {*} multi method exists (EnumMap:U:) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_key; } multi method exists (EnumMap:D: \key) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_key(key); } proto method exists_key(|) {*} multi method exists_key(EnumMap:U:) { False } multi method exists_key(EnumMap:D: Str:D \key) { nqp::p6bool( nqp::defined($!storage) && nqp::existskey($!storage, nqp::unbox_s(key)) ) } multi method exists_key(EnumMap:D: \key) { nqp::p6bool( nqp::defined($!storage) && nqp::existskey($!storage, nqp::unbox_s(key.Stringy)) ) } multi method perl(EnumMap:D:) { self.^name ~ '.new(' ~ self.keys.map({ .perl ~ ', ' ~ self.at_key($_).perl ~ ', '}).join ~ ')'; } method iterator(EnumMap:) { self.pairs.iterator } method list(EnumMap:) { self.pairs } method keys(EnumMap:) { return unless self.DEFINITE && nqp::defined($!storage); HashIter.new(self, :k).list } method kv(EnumMap:) { return unless self.DEFINITE && nqp::defined($!storage); HashIter.new(self, :kv).list } method values(EnumMap:) { return unless self.DEFINITE && nqp::defined($!storage); HashIter.new(self, :v).list } method pairs(EnumMap:) { return unless self.DEFINITE && nqp::defined($!storage); HashIter.new(self, :pairs).list } method invert(EnumMap:) { return unless self.DEFINITE && nqp::defined($!storage); HashIter.new(self, :invert).list } method at_key($key) is rw { my str $skey = nqp::unbox_s($key.Str); nqp::defined($!storage) && nqp::existskey($!storage, $skey) ?? nqp::atkey($!storage, $skey) !! Any } method STORE_AT_KEY(\key, Mu \value) is rw { nqp::defined($!storage) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); nqp::bindkey($!storage, nqp::unbox_s(key.Str), value) } method Capture(EnumMap:D:) { my $cap := nqp::create(Capture); nqp::bindattr($cap, Capture, '$!hash', $!storage); $cap } method FLATTENABLE_LIST() { nqp::list() } method FLATTENABLE_HASH() { nqp::defined($!storage) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); $!storage } method fmt(EnumMap: Cool $format = "%s\t\%s", $sep = "\n") { if nqp::p6box_i(nqp::sprintfdirectives( nqp::unbox_s($format.Stringy) )) == 1 { self.keys.fmt($format, $sep); } else { self.pairs.fmt($format, $sep); } } method hash(\SELF:) is rw { SELF } } multi sub infix:(EnumMap:D $a, EnumMap:D $b) { if +$a != +$b { return Bool::False } for $a.kv -> $k, $v { unless $b.exists_key($k) && $b{$k} eqv $v { return Bool::False; } } Bool::True; } rakudo-2013.12/src/core/Enum.pm0000664000175000017500000000275112224263172015572 0ustar moritzmoritzmy class Enum does Associative { has $.key; has $.value; method new(:$key, Mu :$value) { nqp::create(self).BUILD($key, $value) } method BUILD(\key, Mu \value) { $!key = key; $!value = value; self } multi method ACCEPTS(Enum:D: Associative:D $topic) { $topic{$.key} ~~ $.value } multi method ACCEPTS(Enum:D: Mu $topic) { my $method = $.key; $topic."$method"() === $.value; } method invert() { self.new(key => $.value, value => $.key); } method key(Enum:D:) { $!key } method kv(Enum:D:) { $!key, $!value } method value(Enum:D:) { $!value } method keys(Enum:D:) { ($!key,).list } method values(Enum:D:){ ($!value,).list } method pairs(Enum:D:) { (self,).list } multi method Str(Enum:D:) { $.key ~ "\t" ~ $.value } multi method perl(Enum:D:) { if $.key ~~ Enum { '(' ~ $.key.perl ~ ') => ' ~ $.value.perl; } else { $.key.perl ~ ' => ' ~ $.value.perl; } } method fmt($format = "%s\t%s") { sprintf($format, $.key, $.value); } method at_key($key) { $key eq $!key ?? $!value !! Mu } method FLATTENABLE_LIST() { nqp::list() } method FLATTENABLE_HASH() { nqp::hash($!key, $!value) } } multi sub infix:(Enum:D $a, Enum:D $b) { $a.WHAT === $b.WHAT && $a.key eqv $b.key && $a.value eqv $b.value } multi infix:(Enum:D \a, Enum:D \b) { (a.key cmp b.key) || (a.value cmp b.value) } rakudo-2013.12/src/core/Exception.pm0000664000175000017500000012130412255230273016620 0ustar moritzmoritzmy class Failure { ... } my role X::Comp { ... } my class X::ControlFlow { ... } my class Exception { has $!ex; method backtrace() { Backtrace.new(self) } multi method Str(Exception:D:) { self.?message.Str // 'Something went wrong' } multi method gist(Exception:D:) { my $str = try self.?message; return "Error while creating error string: $!" if $!; $str ~= "\n"; try $str ~= self.backtrace; return "$str\nError while creating backtrace: $!.message()\n$!.backtrace.full();" if $!; return $str; } method throw() is hidden_from_backtrace { nqp::bindattr(self, Exception, '$!ex', nqp::newexception()) unless nqp::isconcrete($!ex); nqp::setpayload($!ex, nqp::decont(self)); my $msg := self.?message; nqp::setmessage($!ex, nqp::unbox_s($msg.Str)) if $msg.defined; nqp::throw($!ex) } method rethrow() is hidden_from_backtrace { nqp::setpayload($!ex, nqp::decont(self)); nqp::rethrow($!ex) } method resumable() { nqp::p6bool(nqp::istrue(nqp::atkey($!ex, 'resume'))); } method resume() { my Mu $resume := nqp::atkey($!ex, 'resume'); if $resume { $resume(); } else { die "Exception is not resumable"; } } method fail(Exception:D:) { try self.throw; my $fail := Failure.new($!); my Mu $return := nqp::getlexcaller('RETURN'); $return($fail) unless nqp::isnull($return); $fail } method is-compile-time { False } } my class X::AdHoc is Exception { has $.payload; method message() { $.payload.Str } method Numeric() { $.payload.Numeric } } my class X::Method::NotFound is Exception { has $.method; has $.typename; has Bool $.private = False; method message() { $.private ?? "No such private method '$.method' for invocant of type '$.typename'" !! "No such method '$.method' for invocant of type '$.typename'"; } } my class X::Method::InvalidQualifier is Exception { has $.method; has $.invocant; has $.qualifier-type; method message() { "Cannot dispatch to method $.method on {$.qualifier-type.^name} " ~ "because it is not inherited or done by {$.invocant.^name}"; } } sub EXCEPTION(|) { my Mu $vm_ex := nqp::shift(nqp::p6argvmarray()); my Mu $payload := nqp::getpayload($vm_ex); if nqp::p6bool(nqp::istype($payload, Exception)) { nqp::bindattr($payload, Exception, '$!ex', $vm_ex); $payload; } else { my int $type = nqp::getextype($vm_ex); my $ex; #?if parrot if $type == pir::const::EXCEPTION_METHOD_NOT_FOUND && #?endif #?if !parrot if #?endif nqp::p6box_s(nqp::getmessage($vm_ex)) ~~ /"Method '" (.*?) "' not found for invocant of class '" (.+)\'$/ { $ex := X::Method::NotFound.new( method => ~$0, typename => ~$1, ); } else { $ex := nqp::create(X::AdHoc); nqp::bindattr($ex, X::AdHoc, '$!payload', nqp::p6box_s(nqp::getmessage($vm_ex))); } nqp::bindattr($ex, Exception, '$!ex', $vm_ex); $ex; } } my class X::Comp::AdHoc { ... } sub COMP_EXCEPTION(|) { my Mu $vm_ex := nqp::shift(nqp::p6argvmarray()); my Mu $payload := nqp::getpayload($vm_ex); if nqp::p6bool(nqp::istype($payload, Exception)) { nqp::bindattr($payload, Exception, '$!ex', $vm_ex); $payload; } else { my $ex := nqp::create(X::Comp::AdHoc); nqp::bindattr($ex, Exception, '$!ex', $vm_ex); nqp::bindattr($ex, X::AdHoc, '$!payload', nqp::p6box_s(nqp::getmessage($vm_ex))); $ex; } } do { sub is_runtime($bt) { for $bt.keys { try { my Mu $sub := nqp::getattr(nqp::decont($bt[$_]), ForeignCode, '$!do'); my Mu $codeobj := nqp::ifnull(nqp::getcodeobj($sub), Mu); my $is_nqp = $codeobj && $codeobj.HOW.name($codeobj) eq 'NQPRoutine'; return True if nqp::iseq_s(nqp::getcodename($sub), 'eval') && $is_nqp; return False if nqp::iseq_s(nqp::getcodename($sub), 'compile') && $is_nqp; } } return False; } sub print_exception(|) is hidden_from_backtrace { my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 0); try { my $e := EXCEPTION($ex); my Mu $err := nqp::getstderr(); #?if parrot if $e.is-compile-time || is_runtime($ex.backtrace) { #?endif #?if jvm if $e.is-compile-time || is_runtime(nqp::backtrace($ex)) { #?endif nqp::printfh($err, $e.gist); nqp::printfh($err, "\n"); } else { nqp::printfh($err, "===SORRY!===\n"); nqp::printfh($err, $e.Str); nqp::printfh($err, "\n"); } $_() for nqp::hllize(nqp::getcurhllsym('@END_PHASERS')); } if $! { #?if parrot pir::perl6_based_rethrow__0PP(nqp::getattr(nqp::decont($!), Exception, '$!ex'), $ex); #?endif #?if !parrot nqp::rethrow(nqp::getattr(nqp::decont($!), Exception, '$!ex')); $ex #?endif } } sub print_control(|) is hidden_from_backtrace { my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 0); my int $type = nqp::getextype($ex); if ($type == nqp::const::CONTROL_WARN) { my Mu $err := nqp::getstderr(); my $msg = nqp::p6box_s(nqp::getmessage($ex)); nqp::printfh($err, $msg ?? "$msg" !! "Warning"); #?if parrot nqp::printfh($err, Backtrace.new($ex.backtrace, 0).nice(:oneline)); #?endif #?if jvm # XXX Backtraces busted # nqp::printfh($err, Backtrace.new(nqp::backtrace($ex), 0).nice(:oneline)); #?endif nqp::printfh($err, "\n"); #?if parrot my $resume := nqp::atkey($ex, 'resume'); if ($resume) { $resume(); } #?endif #?if !parrot nqp::resume($ex) #?endif } if ($type == nqp::const::CONTROL_LAST) { X::ControlFlow.new(illegal => 'last', enclosing => 'loop construct').throw; } if ($type == nqp::const::CONTROL_NEXT) { X::ControlFlow.new(illegal => 'next', enclosing => 'loop construct').throw; } if ($type == nqp::const::CONTROL_REDO) { X::ControlFlow.new(illegal => 'redo', enclosing => 'loop construct').throw; } if ($type == nqp::const::CONTROL_PROCEED) { X::ControlFlow.new(illegal => 'proceed', enclosing => 'when clause').throw; } if ($type == nqp::const::CONTROL_SUCCEED) { # XXX: should work like leave() ? X::ControlFlow.new(illegal => 'succeed', enclosing => 'when clause').throw; } if ($type == nqp::const::CONTROL_TAKE) { X::ControlFlow.new(illegal => 'take', enclosing => 'gather').throw; } } my Mu $comp := nqp::getcomp('perl6'); $comp.HOW.add_method($comp, 'handle-exception', method (|) { my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 1); #?if parrot pir::perl6_invoke_catchhandler__vPP(&print_exception, $ex); #?endif #?if !parrot print_exception($ex); #?endif nqp::exit(1); 0; } ); $comp.HOW.add_method($comp, 'handle-control', method (|) { my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 1); #?if parrot pir::perl6_invoke_catchhandler__vPP(&print_control, $ex); #?endif #?if !parrot print_control($ex); #?endif nqp::rethrow($ex); } ); } my role X::OS { has $.os-error; } my role X::IO does X::OS { }; my class X::IO::Rename does X::IO is Exception { has $.from; has $.to; method message() { "Failed to rename '$.from' to '$.to': $.os-error" } } my class X::IO::Copy does X::IO is Exception { has $.from; has $.to; method message() { "Failed to copy '$.from' to '$.to': $.os-error" } } my class X::IO::Symlink does X::IO is Exception { has $.target; has $.name; method message() { "Failed to create symlink called '$.name' on target '$.target': $.os-error" } } my class X::IO::Link does X::IO is Exception { has $.target; has $.name; method message() { "Failed to create link called '$.name' on target '$.target': $.os-error" } } my class X::IO::Mkdir does X::IO is Exception { has $.path; has $.mode; method message() { "Failed to create directory '$.path' with mode '0o{$.mode.fmt("%03o")}': $.os-error" } } my class X::IO::Chdir does X::IO is Exception { has $.path; method message() { "Failed to change the working directory to '$.path': $.os-error" } } my class X::IO::Dir does X::IO is Exception { has $.path; method message() { "Failed to get the directory contents of '$.path': $.os-error" } } my class X::IO::Cwd does X::IO is Exception { method message() { "Failed to get the working directory: $.os-error" } } my class X::IO::Rmdir does X::IO is Exception { has $.path; method message() { "Failed to remove the directory '$.path': $.os-error" } } my class X::IO::Unlink does X::IO is Exception { has $.path; method message() { "Failed to remove the file '$.path': $.os-error" } } my class X::IO::Chmod does X::IO is Exception { has $.path; has $.mode; method message() { "Failed to set the mode of '$.path' to '0o{$.mode.fmt("%03o")}': $.os-error" } } my role X::Comp is Exception { has $.filename; has $.line; has $.column; has @.modules; has $.is-compile-time = False; has $.pre; has $.post; has @.highexpect; multi method gist(::?CLASS:D: :$sorry = True, :$expect = True) { if $.is-compile-time { my $color = %*ENV // $*OS ne 'MSWin32'; my ($red, $green, $yellow, $clear) = $color ?? ("\e[31m", "\e[32m", "\e[33m", "\e[0m") !! ("", "", "", ""); my $eject = $*OS eq 'MSWin32' ?? "" !! "\x[23CF]"; my $r = $sorry ?? self.sorry_heading() !! ""; $r ~= "$.message\nat $.filename():$.line\n------> "; $r ~= "$green$.pre$yellow$eject$red$.post$clear" if defined $.pre; if $expect && @.highexpect { $r ~= "\n expecting any of:"; for @.highexpect { $r ~= "\n $_"; } } for @.modules.reverse[1..*] { $r ~= $_.defined ?? "\n from module $_ ($_:$_)" !! "\n from $_:$_"; } $r; } else { self.Exception::gist; } } method sorry_heading() { my $color = %*ENV // $*OS ne 'MSWin32'; my ($red, $clear) = $color ?? ("\e[31m", "\e[0m") !! ("", ""); "$red==={$clear}SORRY!$red===$clear Error while compiling $.filename\n" } method SET_FILE_LINE($file, $line) { $!filename = $file; $!line = $line; $!is-compile-time = True; } } my class X::Comp::Group is Exception { has $.panic; has @.sorrows; has @.worries; method is-compile-time() { True } multi method gist(::?CLASS:D:) { my $r = ""; if $.panic || @.sorrows { my $color = %*ENV // $*OS ne 'MSWin32'; my ($red, $clear) = $color ?? ("\e[31m", "\e[0m") !! ("", ""); $r ~= "$red==={$clear}SORRY!$red===$clear\n"; for @.sorrows { $r ~= .gist(:!sorry, :!expect) ~ "\n"; } if $.panic { $r ~= $.panic.gist(:!sorry) ~ "\n"; } } if @.worries { $r ~= $.panic || @.sorrows ?? "Other potential difficulties:\n" !! "Potential difficulties:\n"; for @.worries { $r ~= .gist(:!sorry, :!expect).indent(4) ~ "\n"; } } $r } method message() { my @m; for @.sorrows { @m.push(.message); } if $.panic { @m.push($.panic.message); } for @.worries { @m.push(.message); } @m.join("\n") } } # XXX a hack for getting line numbers from exceptions from the metamodel my class X::Comp::AdHoc is X::AdHoc does X::Comp { method is-compile-time() { True } } my role X::Syntax does X::Comp { } my role X::Pod { } my class X::NYI is Exception { has $.feature; method message() { "$.feature not yet implemented. Sorry. " } } my class X::Comp::NYI is X::NYI does X::Comp { }; my class X::Trait::Unknown is Exception { has $.type; # is, will, of etc. has $.subtype; # wrong subtype being tried has $.declaring; # variable, sub, parameter, etc. method message () { "Can't use unknown trait '$.type $.subtype' in a$.declaring declaration." } } my class X::Comp::Trait::Unknown is X::Trait::Unknown does X::Comp { }; my class X::Trait::NotOnNative is Exception { has $.type; # is, will, of etc. has $.subtype; # wrong subtype being tried has $.native; # type of native (optional) method message () { "Can't use trait '$.type $.subtype' on a native" ~ ( $.native ?? " $.native." !! "." ); } } my class X::Comp::Trait::NotOnNative is X::Trait::NotOnNative does X::Comp { }; my class X::OutOfRange is Exception { has $.what = 'Argument'; has $.got = ''; has $.range = ''; has $.comment; method message() { $.comment.defined ?? "$.what out of range. Is: $.got, should be in $.range.gist(); $.comment" !! "$.what out of range. Is: $.got, should be in $.range.gist()" } } my class X::Buf::AsStr is Exception { has $.method; method message() { "Cannot use a Buf as a string, but you called the $.method method on it"; } } my class X::Buf::Pack is Exception { has $.directive; method message() { "Unrecognized directive '$.directive'"; } } my class X::Buf::Pack::NonASCII is Exception { has $.char; method message() { "non-ASCII character '$.char' while processing an 'A' template in pack"; } } my class X::Signature::Placeholder does X::Comp { has $.placeholder; method message() { "Placeholder variable '$.placeholder' cannot override existing signature"; } } my class X::Placeholder::Block does X::Comp { has $.placeholder; method message() { "Placeholder variable $.placeholder may not be used here because the surrounding block takes no signature"; } } my class X::Placeholder::Mainline is X::Placeholder::Block { method message() { "Cannot use placeholder parameter $.placeholder in the mainline" } } my class X::Undeclared does X::Comp { has $.what = 'Variable'; has $.symbol; has @.suggestions; method message() { my $message := "$.what '$.symbol' is not declared"; if +@.suggestions == 1 { $message := "$message. Did you mean '@.suggestions[0]'?"; } elsif +@.suggestions > 1 { $message := "$message. Did you mean any of these?\n { @.suggestions.join("\n ") }\n"; } $message; } } my class X::Attribute::Undeclared is X::Undeclared { has $.package-kind; has $.package-name; method message() { "Attribute $.symbol not declared in $.package-kind $.package-name"; } } my class X::Undeclared::Symbols does X::Comp { has %.post_types; has %.unk_types; has %.unk_routines; has %.routine_suggestion; has %.type_suggestion; multi method gist(:$sorry = True) { ($sorry ?? self.sorry_heading() !! "") ~ self.message } method message() { sub l(@l) { my @lu = @l.map({ nqp::hllize($_) }).uniq.sort; 'used at line' ~ (@lu == 1 ?? ' ' !! 's ') ~ @lu.join(', ') } sub s(@s) { "Did you mean '{ @s.join("', '") }'?"; } my $r = ""; if %.post_types { $r ~= "Illegally post-declared type" ~ (%.post_types.elems == 1 ?? "" !! "s") ~ ":\n"; for %.post_types.sort(*.key) { $r ~= " $_.key() &l($_.value)\n"; } } if %.unk_types { $r ~= "Undeclared name" ~ (%.unk_types.elems == 1 ?? "" !! "s") ~ ":\n"; for %.unk_types.sort(*.key) { $r ~= " $_.key() &l($_.value)"; if +%.type_suggestion{$_.key()} { $r ~= ". " ~ s(%.type_suggestion{$_.key()}); } $r ~= "\n"; } } if %.unk_routines { $r ~= "Undeclared routine" ~ (%.unk_routines.elems == 1 ?? "" !! "s") ~ ":\n"; for %.unk_routines.sort(*.key) { $r ~= " $_.key() &l($_.value)"; if +%.routine_suggestion{$_.key()} { $r ~= ". " ~ s(%.routine_suggestion{$_.key()}); } $r ~= "\n"; } } $r } } my class X::Redeclaration does X::Comp { has $.symbol; has $.postfix = ''; has $.what = 'symbol'; method message() { "Redeclaration of $.what $.symbol$.postfix"; } } my class X::Redeclaration::Outer does X::Comp { has $.symbol; method message() { "Lexical symbol '$.symbol' is already bound to an outer symbol;\n" ~ "the implicit outer binding must be rewritten as OUTER::<$.symbol>\n" ~ "before you can unambiguously declare a new '$.symbol' in this scope"; } } my class X::Import::Redeclaration does X::Comp { has @.symbols; has $.source-package-name; method message() { @.symbols == 1 ?? "Cannot import symbol @.symbols[0] from $.source-package-name, because it already exists in this lexical scope" !! ("Cannot import the following symbols from $.source-package-name, because they already exist in this lexical scope: ", @.symbols.join(', ')); } } my class X::Import::OnlystarProto does X::Comp { has @.symbols; has $.source-package-name; method message() { @.symbols == 1 ?? "Cannot import symbol @.symbols[0] from $.source-package-name, only onlystar-protos can be merged" !! ("Cannot import the following symbols from $.source-package-name, only onlystar-protos can be merged: ", @.symbols.join(', ')); } } my class X::Phaser::Multiple does X::Comp { has $.block; method message() { "Only one $.block block is allowed" } } my class X::Obsolete does X::Comp { has $.old; has $.replacement; # can't call it $.new, collides with constructor has $.when = 'in Perl 6'; method message() { "Unsupported use of $.old; $.when please use $.replacement" } } my class X::Parameter::Default does X::Comp { has $.how; has $.parameter; method message() { $.parameter ?? "Cannot put default on $.how parameter $.parameter" !! "Cannot put default on anonymous $.how parameter"; } } my class X::Parameter::Placeholder does X::Comp { has $.parameter; has $.right; method message() { "In signature parameter, placeholder variables like $.parameter are illegal\n" ~ "you probably meant a named parameter: '$.right'"; } } my class X::Parameter::Twigil does X::Comp { has $.parameter; has $.twigil; method message() { "In signature parameter $.parameter, it is illegal to use the $.twigil twigil"; } } my class X::Parameter::MultipleTypeConstraints does X::Comp { has $.parameter; method message() { ($.parameter ?? "Parameter $.parameter" !! 'A parameter') ~ " may only have one prefix type constraint"; } } my class X::Parameter::WrongOrder does X::Comp { has $.misplaced; has $.parameter; has $.after; method message() { "Cannot put $.misplaced parameter $.parameter after $.after parameters"; } } my class X::Parameter::InvalidType does X::Comp { has $.typename; has @.suggestions; method message() { my $msg := "Invalid typename '$.typename' in parameter declaration."; if +@.suggestions > 0 { $msg := $msg ~ " Did you mean '" ~ @.suggestions.join("', '") ~ "'?"; } return $msg; } } my class X::Signature::NameClash does X::Comp { has $.name; method message() { "Name $.name used for more than one named parameter"; } } my class X::Method::Private::Permission does X::Comp { has $.method; has $.source-package; has $.calling-package; method message() { "Cannot call private method '$.method' on package $.source-package because it does not trust $.calling-package"; } } my class X::Method::Private::Unqualified does X::Comp { has $.method; method message() { "Private method call to $.method must be fully qualified with the package containing the method"; } } my class X::Bind is Exception { has $.target; method message() { $.target.defined ?? "Cannot bind to $.target" !! 'Cannot use bind operator with this left-hand side' } } my class X::Bind::NativeType does X::Comp { has $.name; method message() { "Cannot bind to natively typed variable '$.name'; use assignment instead" } } my class X::Bind::Slice is Exception { has $.type; method message() { "Cannot bind to {$.type.^name} slice"; } } my class X::Bind::ZenSlice is X::Bind::Slice { method message() { "Cannot bind to {$.type.^name} zen slice"; } } my class X::Value::Dynamic does X::Comp { has $.what; method message() { "$.what value must be known at compile time" } } my class X::Syntax::Name::Null does X::Syntax { method message() { 'Name component may not be null'; } } my class X::Syntax::UnlessElse does X::Syntax { method message() { '"unless" does not take "else", please rewrite using "if"' } } my class X::Syntax::KeywordAsFunction does X::Syntax { has $.word; has $.needparens; method message { "Word '$.word' interpreted as '{$.word}()' function call; please use whitespace " ~ ($.needparens ?? 'around the parens' !! 'instead of parens') } } my class X::Syntax::Malformed::Elsif does X::Syntax { has $.what = 'else if'; method message() { qq{In Perl 6, please use "elsif' instead of "$.what"} } } my class X::Syntax::Reserved does X::Syntax { has $.reserved; has $.instead = ''; method message() { "The $.reserved is reserved$.instead" } } my class X::Syntax::P5 does X::Syntax { method message() { 'This appears to be Perl 5 code' } } my class X::Syntax::NegatedPair does X::Syntax { has $.key; method message() { "Argument not allowed on negated pair with key '$.key'" } } my class X::Syntax::Variable::Numeric does X::Syntax { has $.what = 'variable'; method message() { "Cannot declare a numeric $.what" } } my class X::Syntax::Variable::Match does X::Syntax { method message() { 'Cannot declare a match variable' } } my class X::Syntax::Variable::Twigil does X::Syntax { has $.twigil; has $.scope; method message() { "Cannot use $.twigil twigil on $.scope variable" } } my class X::Syntax::Variable::IndirectDeclaration does X::Syntax { method message() { 'Cannot declare a variable by indirect name (use a hash instead?)' } } my class X::Syntax::Augment::WithoutMonkeyTyping does X::Syntax { method message() { "augment not allowed without 'use MONKEY_TYPING'" }; } my class X::Syntax::Augment::Illegal does X::Syntax { has $.package; method message() { "Cannot augment $.package because it is closed" }; } my class X::Syntax::Argument::MOPMacro does X::Syntax { has $.macro; method message() { "Cannot give arguments to $.macro" }; } my class X::Does::TypeObject is Exception { method message() { "Cannot use 'does' operator with a type object." } } my class X::Role::Initialization is Exception { has $.role; method message() { "Can only supply an initialization value for a role if it has a single public attribute, but this is not the case for '{$.role.^name}'" } } my class X::Syntax::Comment::Embedded does X::Syntax { method message() { "Opening bracket required for #` comment" } } my class X::Syntax::Pod::BeginWithoutIdentifier does X::Syntax does X::Pod { method message() { '=begin must be followed by an identifier; (did you mean "=begin pod"?)' } } my class X::Syntax::Pod::BeginWithoutEnd does X::Syntax does X::Pod { method message() { '=begin without matching =end' } } my class X::Syntax::Confused does X::Syntax { has $.reason = 'unknown'; method message() { $.reason eq 'unknown' ?? 'Confused' !! $.reason } } my class X::Syntax::Malformed does X::Syntax { has $.what; method message() { "Malformed $.what" } } my class X::Syntax::Missing does X::Syntax { has $.what; method message() { "Missing $.what" } } my class X::Syntax::Perl5Var does X::Syntax { has $.name; my %m = '$*' => '^^ and $$', '$"' => '.join() method', '$$' => '$*PID', '$(' => '$*GID', '$)' => '$*EGID', '$<' => '$*UID', '$>' => '$*EUID', '$;' => 'real multidimensional hashes', '$&' => '$<>', '$`' => 'explicit pattern before <(', '$\'' => 'explicit pattern after )>', '$,' => '$*OUT.output_field_separator()', '$.' => "the filehandle's .line method", '$\\' => "the filehandle's .ors attribute", '$|' => ':autoflush on open', '$?' => '$! for handling child errors also', '$@' => '$!', '$#' => '.fmt', '$[' => 'user-defined array indices', '$]' => '$*PERL_VERSION', '$^C' => 'COMPILING namespace', '$^D' => '$*DEBUGGING', '$^E' => '$!.extended_os_error', '$^F' => '$*SYSTEM_FD_MAX', '$^H' => '$?FOO variables', '$^I' => '$*INPLACE', '$^M' => 'a global form such as $*M', '$^N' => '$/[*-1]', '$^O' => '$?OS or $*OS', '$^R' => 'an explicit result variable', '$^S' => 'context function', '$^T' => '$*BASETIME', '$^V' => '$*PERL_VERSION', '$^W' => '$*WARNING', '$^X' => '$*EXECUTABLE_NAME', '$:' => 'Form module', '$-' => 'Form module', '$+' => 'Form module', '$=' => 'Form module', '$%' => 'Form module', '$^' => 'Form module', '$~' => 'Form module', '$^A' => 'Form module', '$^L' => 'Form module', '@-' => '.from method', '@+' => '.to method', '%-' => '.from method', '%+' => '.to method', '%^H' => '$?FOO variables', ; method message() { my $v = $.name ~~ m/ <[ $ @ % & ]> [ \^ <[ A..Z ]> | \W ] /; $v ?? %m{~$v} ?? "Unsupported use of $v variable; in Perl 6 please use {%m{~$v}}" !! "Unsupported use of $v variable" !! 'Non-declarative sigil is missing its name'; } } my class X::Syntax::Self::WithoutObject does X::Syntax { method message() { "'self' used where no object is available" } } my class X::Syntax::VirtualCall does X::Syntax { has $.call; method message() { "Virtual call $.call may not be used on partially constructed objects" } } my class X::Syntax::NoSelf does X::Syntax { has $.variable; method message() { "Variable $.variable used where no 'self' is available" } } my class X::Syntax::Number::RadixOutOfRange does X::Syntax { has $.radix; method message() { "Radix $.radix out of range (allowed: 2..36)" } } my class X::Syntax::NonAssociative does X::Syntax { has $.left; has $.right; method message() { "Operators '$.left' and '$.right' are non-associative and require parenthesis"; } } my class X::Syntax::Regex::Adverb does X::Syntax { has $.adverb; has $.construct; method message() { "Adverb $.adverb not allowed on $.construct" } } my class X::Syntax::Regex::UnrecognizedMetachar does X::Syntax { has $.metachar; method message() { "Unrecognized regex metacharacter $.metachar (must be quoted to match literally)" } } my class X::Syntax::Regex::NullRegex does X::Syntax { method message() { 'Null regex not allowed' } } my class X::Syntax::Signature::InvocantMarker does X::Syntax { method message() { "Can only use : as invocant marker in a signature after the first parameter" } } my class X::Syntax::Extension::Category does X::Syntax { has $.category; method message() { "Cannot add tokens of category '$.category'"; } } my class X::Syntax::Extension::Null does X::Syntax { method message() { "Null operator is not allowed"; } } my class X::Syntax::InfixInTermPosition does X::Syntax { has $.infix; method message() { "Preceding context expects a term, but found infix $.infix instead"; } } my class X::Attribute::Package does X::Comp { has $.package-kind; has $.name; method message() { "A $.package-kind cannot have attributes, but you tried to declare '$.name'" } } my class X::Attribute::NoPackage does X::Comp { has $.name; method message() { "You cannot declare attribute '$.name' here; maybe you'd like a class or a role?" } } my class X::Declaration::Scope does X::Comp { has $.scope; has $.declaration; method message() { "Cannot use '$.scope' with $.declaration declaration" } } my class X::Declaration::Scope::Multi is X::Declaration::Scope { method message() { "Cannot use '$.scope' with individual multi candidates. Please declare an {$.scope}-scoped proto instead"; } } my class X::Anon::Multi does X::Comp { has $.multiness; has $.routine-type = 'routine'; method message() { "Cannot put $.multiness on anonymous $.routine-type" } } my class X::Anon::Augment does X::Comp { has $.package-kind; method message() { "Cannot augment anonymous $.package-kind" } } my class X::Augment::NoSuchType does X::Comp { has $.package-kind; has $.package; method message() { "You tried to augment $.package-kind $.package, but it does not exist" } } my class X::Routine::Unwrap is Exception { method message() { "Cannot unwrap routine: invalid wrap handle" } } my class X::Constructor::Positional is Exception { has $.type; method message() { "Default constructor for '" ~ $.type.^name ~ "' only takes named arguments" } } my class X::Hash::Store::OddNumber is Exception { method message() { "Odd number of elements found where hash expected" } } my class X::Package::Stubbed does X::Comp { has @.packages; # TODO: suppress display of line number method message() { "The following packages were stubbed but not defined:\n " ~ @.packages.join("\n "); } } my class X::Phaser::PrePost is Exception { has $.phaser = 'PRE'; has $.condition; method message { my $what = $.phaser eq 'PRE' ?? 'Precondition' !! 'Postcondition'; $.condition.defined ?? "$what '$.condition.trim()' failed" !! "$what failed"; } } my class X::Str::Numeric is Exception { has $.source; has $.pos; has $.reason; method source-indicator { constant marker = chr(0x23CF); join '', "in '", $.source.substr(0, $.pos), marker, $.source.substr($.pos), "' (indicated by ", marker, ")", ; } method message() { "Cannot convert string to number: $.reason $.source-indicator"; } } my class X::Str::Match::x is Exception { has $.got; method message() { "in Str.match, got invalid value of type {$.got.^name} for :x, must be Int or Range" } } my class X::Str::Trans::IllegalKey is Exception { has $.key; method message { "in Str.trans, got illegal substitution key of type {$.key.^name} (should be a Regex or Str)" } } my class X::Str::Trans::InvalidArg is Exception { has $.got; method message() { "Only Pair objects are allowed as arguments to Str.trans, got {$.got.^name}"; } } my class X::Range::InvalidArg is Exception { has $.got; method message() { "{$.got.^name} objects are not valid endpoints for Ranges"; } } my class X::Sequence::Deduction is Exception { method message() { 'Unable to deduce sequence' } } my class X::Backslash::UnrecognizedSequence does X::Syntax { has $.sequence; method message() { "Unrecognized backslash sequence: '\\$.sequence'" } } my class X::Backslash::NonVariableDollar does X::Syntax { method message() { "Non-variable \$ must be backslashed" } } my class X::ControlFlow is Exception { has $.illegal; # something like 'next' has $.enclosing; # .... outside a loop method message() { "$.illegal without $.enclosing" } } my class X::ControlFlow::Return is X::ControlFlow { method illegal() { 'return' } method enclosing() { 'Routine' } method message() { 'Attempt to return outside of any Routine' } } my class X::Composition::NotComposable does X::Comp { has $.target-name; has $.composer; method message() { $.composer.^name ~ " is not composable, so $.target-name cannot compose it"; } } my class X::TypeCheck is Exception { has $.operation; has $.got; has $.expected; method message() { "Type check failed in $.operation; expected '{$.expected.^name}' but got '{$.got.^name}'"; } } my class X::TypeCheck::Binding is X::TypeCheck { method operation { 'binding' } } my class X::TypeCheck::Return is X::TypeCheck { method operation { 'returning' } method message() { "Type check failed for return value; expected '{$.expected.^name}' but got '{$.got.^name}'"; } } my class X::TypeCheck::Assignment is X::TypeCheck { has $.symbol; method operation { 'assignment' } method message { $.symbol.defined ?? "Type check failed in assignment to '$.symbol'; expected '{$.expected.^name}' but got '{$.got.^name}'" !! "Type check failed in assignment; expected '{$.expected.^name}' but got '{$.got.^name}'"; } } my class X::TypeCheck::Splice is X::TypeCheck does X::Comp { has $.action; method message { "Type check failed in {$.action}; expected {$.expected.^name} but got {$.got.^name}"; } } my class X::Assignment::RO is Exception { method message { "Cannot modify an immutable value"; } } my class X::Immutable is Exception { has $.typename; has $.method; method message { "Cannot call '$.method' on an immutable '$.typename'"; } } my class X::NoDispatcher is Exception { has $.redispatcher; method message() { "$.redispatcher is not in the dynamic scope of a dispatcher"; } } my class X::Localizer::NoContainer is Exception { has $.localizer; method message() { "Can only use '$.localizer' on a container"; } } my class X::Mixin::NotComposable is Exception { has $.target; has $.rolish; method message() { "Cannot mix in non-composable type {$.rolish.^name} into object of type {$.target.^name}"; } } my class X::Inheritance::Unsupported does X::Comp { # note that this exception is thrown before the child type object # has been composed, so it's useless to carry it around. Use the # name instead. has $.child-typename; has $.parent; method message { $.parent.^name ~ ' does not support inheritance, so ' ~ $.child-typename ~ ' cannot inherit from it'; } } my class X::Inheritance::UnknownParent is Exception { has $.child; has $.parent; has @.suggestions is rw; method message { my $message := "'" ~ $.child ~ "' cannot inherit from '" ~ $.parent ~ "' because it is unknown."; if +@.suggestions > 1 { $message := $message ~ "\nDid you mean one of these?\n '" ~ @.suggestions.join("'\n '") ~ "'\n"; } elsif +@.suggestions == 1 { $message := $message ~ "\nDid you mean '" ~ @.suggestions[0] ~ "'?\n"; } return $message; } } my class X::Inheritance::SelfInherit is Exception { has $.name; method message { "'$.name' cannot inherit from itself." } } my class X::Export::NameClash does X::Comp { has $.symbol; method message() { "A symbol '$.symbol' has already been exported"; } } my class X::HyperOp::NonDWIM is Exception { has &.operator; has $.left-elems; has $.right-elems; method message() { "Lists on both side of non-dwimmy hyperop of &.operator.name() are not of the same length\n" ~ "left: $.left-elems elements, right: $.right-elems elements"; } } my class X::Set::Coerce is Exception { has $.thing; method message { "Cannot coerce object of type {$.thing.^name} to Set. To create a one-element set, pass it to the 'set' function"; } } my role X::Temporal is Exception { } my class X::Temporal::InvalidFormat does X::Temporal { has $.invalid-str; has $.target = 'Date'; has $.format; method message() { "Invalid $.target string '$.invalid-str'; use $.format instead"; } } my class X::DateTime::TimezoneClash does X::Temporal { method message() { 'DateTime.new(Str): :timezone argument not allowed with a timestamp offset'; } } my class X::DateTime::InvalidDeltaUnit does X::Temporal { has $.unit; method message() { "Cannnot use unit $.unit with Date.delta"; } } my class X::Eval::NoSuchLang is Exception { has $.lang; method message() { "No compiler available for language '$.lang'"; } } my class X::Import::MissingSymbols is Exception { has $.from; has @.missing; method message() { "Trying to import from '$.from', but the following symbols are missing: " ~ @.missing.join(', '); } } my class X::Numeric::Real is Exception { has $.target; has $.reason; has $.source; method message() { "Can not convert $.source to {$.target.^name}: $.reason"; } } my class X::Numeric::DivideByZero is Exception { has $.using; method message() { "Divide by zero" ~ ( $.using ?? " using $.using" !! '' ); } } my class X::PseudoPackage::InDeclaration does X::Comp { has $.pseudo-package; has $.action; method message() { "Cannot use pseudo package $.pseudo-package in $.action"; } } my class X::NoSuchSymbol is Exception { has $.symbol; method message { "No such symbol '$.symbol'" } } my class X::Item is Exception { has $.aggregate; has $.index; method message { "Cannot index {$.aggregate.^name} with $.index" } } my class X::Multi::Ambiguous is Exception { has $.dispatcher; has @.ambiguous; method message { join "\n", "Ambiguous call to '$.dispatcher.name()'; these signatures all match:", @.ambiguous.map(*.signature.perl) } } my class X::Multi::NoMatch is Exception { has $.dispatcher; method message { join "\n", "Cannot call '$.dispatcher.name()'; none of these signatures match:", $.dispatcher.dispatchees.map(*.signature.perl) } } my class X::Caller::NotDynamic is Exception { has $.symbol; method message() { "Cannot access '$.symbol' through CALLER, because it is not declared as dynamic"; } } { my %c_ex; %c_ex{'X::TypeCheck::Binding'} := sub ($got, $expected) is hidden_from_backtrace { X::TypeCheck::Binding.new(:$got, :$expected).throw; }; %c_ex := sub ($symbol, $got, $expected) is hidden_from_backtrace { X::TypeCheck::Assignment.new(:$symbol, :$got, :$expected).throw; }; %c_ex{'X::TypeCheck::Return'} := sub ($got, $expected) is hidden_from_backtrace { X::TypeCheck::Return.new(:$got, :$expected).throw; }; %c_ex := sub () is hidden_from_backtrace { X::Assignment::RO.new.throw; }; %c_ex{'X::ControlFlow::Return'} := sub () is hidden_from_backtrace { X::ControlFlow::Return.new().throw; }; %c_ex{'X::NoDispatcher'} := sub ($redispatcher) is hidden_from_backtrace { X::NoDispatcher.new(:$redispatcher).throw; }; %c_ex{'X::Multi::Ambiguous'} := sub ($dispatcher, @ambiguous) is hidden_from_backtrace { X::Multi::Ambiguous.new(:$dispatcher, :@ambiguous).throw }; %c_ex{'X::Multi::NoMatch'} := sub ($dispatcher) is hidden_from_backtrace { X::Multi::NoMatch.new(:$dispatcher).throw }; my Mu $parrot_c_ex := nqp::getattr(%c_ex, EnumMap, '$!storage'); nqp::bindcurhllsym('P6EX', $parrot_c_ex); 0; } # vim: ft=perl6 rakudo-2013.12/src/core/EXPORTHOW.pm0000664000175000017500000000177712224263172016274 0ustar moritzmoritz# Bind the HOWs into the EXPORTHOW package under the package declarator # names. my module EXPORTHOW { nqp::bindkey($?PACKAGE.WHO, 'package', Perl6::Metamodel::PackageHOW); nqp::bindkey($?PACKAGE.WHO, 'module', Perl6::Metamodel::ModuleHOW); nqp::bindkey($?PACKAGE.WHO, 'generic', Perl6::Metamodel::GenericHOW); nqp::bindkey($?PACKAGE.WHO, 'class', Perl6::Metamodel::ClassHOW); nqp::bindkey($?PACKAGE.WHO, 'class-attr', Attribute); nqp::bindkey($?PACKAGE.WHO, 'role', Perl6::Metamodel::ParametricRoleHOW); nqp::bindkey($?PACKAGE.WHO, 'role-attr', Attribute); nqp::bindkey($?PACKAGE.WHO, 'role-group', Perl6::Metamodel::ParametricRoleGroupHOW); nqp::bindkey($?PACKAGE.WHO, 'grammar', Perl6::Metamodel::GrammarHOW); nqp::bindkey($?PACKAGE.WHO, 'grammar-attr', Attribute); nqp::bindkey($?PACKAGE.WHO, 'native', Perl6::Metamodel::NativeHOW); nqp::bindkey($?PACKAGE.WHO, 'subset', Perl6::Metamodel::SubsetHOW); nqp::bindkey($?PACKAGE.WHO, 'enum', Perl6::Metamodel::EnumHOW); } rakudo-2013.12/src/core/Failure.pm0000664000175000017500000000264712232021472016253 0ustar moritzmoritz$PROCESS::FATAL = False; my class Failure { has $.exception; has $!handled; method new($ex) { my $new = self.CREATE; $new.BUILD($ex); } method BUILD($ex) { $!exception = $ex; self; } # TODO: should be Failure:D: multi just like method Bool, # but obscure problems prevent us from making Mu.defined # a multi. See http://irclog.perlgeek.de/perl6/2011-06-28#i_4016747 method defined() { $!handled =1 if nqp::isconcrete(self); Bool::False; } multi method Bool(Failure:D:) { $!handled = 1; Bool::False; } method Int(Failure:D:) { $!handled ?? 0 !! $!exception.throw; } method Num(Failure:D:) { $!handled ?? 0e0 !! $!exception.throw; } method Numeric(Failure:D:) { $!handled ?? 0e0 !! $!exception.throw; } multi method Str(Failure:D:) { $!handled ?? '' !! $!exception.throw; } multi method gist(Failure:D:) { $!handled ?? $.perl !! $!exception.throw; } Failure.^add_fallback( -> $, $ { True }, method ($name) { $!exception.throw; } ); method sink() { $!exception.throw unless $!handled } } my &fail := -> *@msg { my $value = @msg == 1 ?? @msg[0] !! @msg.join(''); die $value if $*FATAL; try die $value; my $fail := Failure.new($!); my Mu $return := nqp::getlexcaller('RETURN'); $return($fail) unless nqp::isnull($return); $fail } rakudo-2013.12/src/core/ForeignCode.pm0000664000175000017500000000126212224263172017046 0ustar moritzmoritz# Takes a foreign code object and tries to make it feel somewhat like a Perl # 6 one. Note that it doesn't have signature information we can know about. my class ForeignCode does Callable { # declared in BOOTSTRAP # class ForeignCode { # has Mu $!do; # Code object we delegate to method arity() { self.signature.arity } method count() { self.signature.count } method signature(ForeignCode:D:) { (sub (|) { }).signature } method name() { (nqp::can($!do, 'name') ?? $!do.name !! nqp::getcodename($!do)) || '' } multi method gist(ForeignCode:D:) { self.name } multi method Str(ForeignCode:D:) { self.name } } rakudo-2013.12/src/core/GatherIter.pm0000664000175000017500000000707012255230273016723 0ustar moritzmoritzclass GatherIter is Iterator { has Mu $!coro; # coroutine to execute for more pairs has $!reified; # Parcel of this iterator's results has $!infinite; # true if iterator is known infinite #?if jvm my $GATHER_PROMPT = []; my $SENTINEL := []; #?endif method new($block, Mu :$infinite) { #?if parrot my Mu $coro := nqp::clone(nqp::getattr(&coro, Code, '$!do')); nqp::ifnull($coro($block), Nil); #?endif #?if jvm my Mu $takings; my Mu $state; my sub yield() { nqp::continuationcontrol(0, $GATHER_PROMPT, -> Mu \c { $state := sub () is rw { nqp::continuationinvoke(c, -> | { Nil }); }; }); } $state := sub () is rw { nqp::handle( $block().eager(), 'TAKE', ($takings := nqp::getpayload(nqp::exception()); yield(); nqp::resume(nqp::exception()))); $takings := $SENTINEL; yield(); }; my $coro := sub () is rw { nqp::continuationreset($GATHER_PROMPT, $state); $takings }; #?endif my Mu $new := nqp::create(self); nqp::bindattr($new, GatherIter, '$!coro', $coro); nqp::bindattr($new, GatherIter, '$!infinite', $infinite); $new; } multi method DUMP(GatherIter: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, '$!reified' ); nqp::push($attrs, $!reified ); nqp::push($attrs, '$!coro' ); nqp::push($attrs, $!coro ); self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx, :$flags); } method reify($n = 1) { if !$!reified.defined { my Mu $rpa := nqp::list(); my Mu $parcel; my $end = Bool::False; my $count = nqp::istype($n, Whatever) ?? 1 !! $n; while !$end && $count > 0 { $parcel := $!coro(); #?if parrot $end = nqp::p6bool(nqp::isnull($parcel)); #?endif #?if jvm $end = nqp::p6bool(nqp::eqaddr($parcel, $SENTINEL)); #?endif nqp::push($rpa, $parcel) unless $end; $count = $count - 1; } nqp::push($rpa, nqp::p6bindattrinvres( nqp::p6bindattrinvres( nqp::create(self), GatherIter, '$!coro', $!coro), GatherIter, '$!infinite', $!infinite)) unless $end; $!reified := nqp::p6parcel($rpa, nqp::null()); } $!reified } method infinite() { $!infinite } #?if parrot my sub coro(\block) { Q:PIR { .local pmc block, handler, taken block = find_lex 'block' .yield () handler = root_new ['parrot';'ExceptionHandler'] handler.'handle_types'(.CONTROL_TAKE) set_addr handler, take_handler push_eh handler $P0 = block() $P0.'eager'() pop_eh gather_done: null taken .yield (taken) goto gather_done take_handler: .local pmc exception, resume .get_results (exception) taken = exception['payload'] resume = exception['resume'] .yield (taken) resume() goto gather_done # should never get here }; True } #?endif } sub GATHER(\block, Mu :$infinite) { GatherIter.new( block, :$infinite ).list; } rakudo-2013.12/src/core/Grammar.pm0000664000175000017500000000070312224263172016247 0ustar moritzmoritzmy class Grammar is Cursor { method parse($target, :$rule = 'TOP', Mu :$actions = Mu, *%opt) { my $*ACTIONS = $actions; nqp::getlexcaller('$/') = self."!cursor_init"($target, |%opt)."$rule"().MATCH; } method parsefile(Cool $filename as Str, *%opts) { my $fh := open($filename); my $match := self.parse($fh.slurp, |%opts); $fh.close; nqp::getlexcaller('$/') = $match; } } rakudo-2013.12/src/core/HashIter.pm0000664000175000017500000001355112224263172016375 0ustar moritzmoritzmy class HashIter is Iterator { has $!reified; # Parcel we return after reifying has Mu $!hashiter; # the VM level hash iterator has Mu $!keystore; # key store, if it's a typed hash has int $!mode; # pair = 0, kv = 1, k = 2, v = 3, invert = 4 method new($hash, :$keystore, :$pairs, :$kv, :$k, :$v, :$invert) { my $new := nqp::create(self); $new.BUILD($hash, $keystore, $pairs ?? 0 !! $kv ?? 1 !! $k ?? 2 !! $v ?? 3 !! $invert ?? 4 !! 0); $new; } method BUILD($hash, $keystore, Int $mode) { $!hashiter := nqp::iterator(nqp::getattr(nqp::decont($hash), EnumMap, '$!storage')); $!mode = $mode; $!keystore := nqp::getattr(nqp::decont($keystore), EnumMap, '$!storage') if $keystore.DEFINITE; self } method reify($n = 1000, :$sink) { unless nqp::isconcrete($!reified) { my int $count = nqp::istype($n, Whatever) ?? 1000 !! $n.Int; my int $i = 0; my int $mode = $!mode; my Mu $rpa := nqp::list(); my $it := $!hashiter; my Mu $pairish; if $mode == 0 { if nqp::defined($!keystore) { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, Pair.new( :key(nqp::atkey($!keystore, nqp::iterkey_s($pairish))), :value(nqp::hllize(nqp::iterval($pairish))))); $i = $i + 1; } } else { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, Pair.new( :key(nqp::p6box_s(nqp::iterkey_s($pairish))), :value(nqp::hllize(nqp::iterval($pairish))))); $i = $i + 1; } } } elsif $mode == 1 { if nqp::defined($!keystore) { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, nqp::atkey($!keystore, nqp::iterkey_s($pairish)).item); nqp::push($rpa, nqp::hllize(nqp::iterval($pairish)).item); $i = $i + 1; } } else { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, nqp::p6box_s(nqp::iterkey_s($pairish))); nqp::push($rpa, nqp::hllize(nqp::iterval($pairish)).item); $i = $i + 1; } } } elsif $mode == 2 { if nqp::defined($!keystore) { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, nqp::atkey($!keystore, nqp::iterkey_s($pairish)).item); $i = $i + 1; } } else { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, nqp::p6box_s(nqp::iterkey_s($pairish))); $i = $i + 1; } } } elsif $mode == 3 { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, nqp::hllize(nqp::iterval($pairish)).item); $i = $i + 1; } } elsif $mode == 4 { if nqp::defined($!keystore) { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, Pair.new( :value(nqp::atkey($!keystore, nqp::iterkey_s($pairish))), :key(nqp::hllize(nqp::iterval($pairish))))); $i = $i + 1; } } else { while $it && $i < $count { $pairish := nqp::shift($it); nqp::push($rpa, Pair.new( :value(nqp::p6box_s(nqp::iterkey_s($pairish))), :key(nqp::hllize(nqp::iterval($pairish))))); $i = $i + 1; } } } else { die "Unknown hash iteration mode"; } if $it { my $nextiter := nqp::create(self); nqp::bindattr($nextiter, HashIter, '$!hashiter', $it); nqp::bindattr($nextiter, HashIter, '$!keystore', $!keystore); nqp::bindattr_i($nextiter, HashIter, '$!mode', $mode); nqp::push($rpa, $nextiter); } $!reified := nqp::p6parcel($rpa, nqp::null()); # release references to objects we no longer need/own $!hashiter := Any; } $!reified; } method infinite() { False } multi method DUMP(HashIter:D: :$indent-step = 4, :%ctx?) { return DUMP(self, :$indent-step) unless %ctx; my Mu $attrs := nqp::list(); nqp::push($attrs, '$!reified' ); nqp::push($attrs, $!reified ); nqp::push($attrs, '$!hashiter' ); nqp::push($attrs, $!hashiter ); nqp::push($attrs, '$!keystore' ); nqp::push($attrs, $!keystore ); nqp::push($attrs, '$!mode' ); nqp::push($attrs, $!mode ); self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx); } } rakudo-2013.12/src/core/Hash.pm0000664000175000017500000003257712225320406015555 0ustar moritzmoritzmy class X::Hash::Store::OddNumber { ... } my class Hash { # declared in BOOTSTRAP # my class Hash is EnumMap { # has Mu $!descriptor; method new(*@args) { my %h := nqp::create(self); %h.STORE(@args) if @args; %h; } multi method at_key(Hash:D: $key is copy) is rw { my Mu $storage := nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) ?? nqp::getattr(self, EnumMap, '$!storage') !! nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); $key = $key.Str; if nqp::existskey($storage, nqp::unbox_s($key)) { nqp::atkey($storage, nqp::unbox_s($key)); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc($!descriptor)), Scalar, '$!whence', -> { nqp::bindkey($storage, nqp::unbox_s($key), v) } ); } } method bind_key($key, Mu \bindval) is rw { nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); nqp::bindkey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key.Str), bindval) } multi method perl(Hash:D \SELF:) { nqp::iscont(SELF) ?? '{' ~ self.pairs.map({.perl}).join(', ') ~ '}' !! '(' ~ self.pairs.map({.perl}).join(', ') ~ ').hash' } multi method DUMP(Hash:D: :$indent-step = 4, :%ctx?) { return DUMP(self, :$indent-step) unless %ctx; my Mu $attrs := nqp::list(); nqp::push($attrs, '$!descriptor'); nqp::push($attrs, $!descriptor ); nqp::push($attrs, '$!storage' ); nqp::push($attrs, nqp::getattr(nqp::decont(self), EnumMap, '$!storage')); self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx); } method STORE_AT_KEY(\key, Mu $x) is rw { my $v := nqp::p6scalarfromdesc($!descriptor); nqp::findmethod(EnumMap, 'STORE_AT_KEY')(self, key, $v = $x); } method STORE(\to_store) is hidden_from_backtrace { my $items = (to_store,).flat.eager; nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); while $items { my Mu $x := $items.shift; if Enum.ACCEPTS($x) { self.STORE_AT_KEY($x.key, $x.value) } elsif EnumMap.ACCEPTS($x) { for $x.list { self.STORE_AT_KEY(.key, .value) } } elsif $items { self.STORE_AT_KEY($x, $items.shift) } else { X::Hash::Store::OddNumber.new.throw } } self } # introspection method name() { my $d := $!descriptor; nqp::isnull($d) ?? Str !! $d.name() } method keyof () { Any } method of() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! $d.of; } method default() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! $d.default; } method dynamic() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! so $d.dynamic; } proto method delete(|) { * } multi method delete(Hash:U:) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key; } multi method delete($key as Str) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($key); } proto method delete_key(|) { * } multi method delete_key(Hash:U:) { Nil } multi method delete_key($key as Str) { my Mu $val = self.at_key($key); nqp::deletekey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key) ); $val; } method push(*@values) { my $previous; my $has_previous; for @values -> $e { if $has_previous { self!_push_construct($previous, $e); $has_previous = 0; } elsif $e.^isa(Enum) { self!_push_construct($e.key, $e.value); } else { $previous = $e; $has_previous = 1; } } if $has_previous { warn "Trailing item in Hash.push"; } self } proto method classify-list(|) { * } multi method classify-list( &test, *@list ) { fail 'Cannot .classify an infinite list' if @list.infinite; if @list { # multi-level classify if test(@list[0]) ~~ List { for @list -> $l { my @keys = test($l); my $last := @keys.pop; my $hash = self; $hash = $hash{$_} //= self.new for @keys; nqp::push( nqp::p6listitems(nqp::decont($hash{$last} //= [])), $l ); } } # just a simple classify else { nqp::push( nqp::p6listitems(nqp::decont(self{test $_} //= [])), $_ ) for @list; } } self; } multi method classify-list( %test, *@list ) { samewith( { %test{$^a} }, @list ); } multi method classify-list( @test, *@list ) { samewith( { @test[$^a] }, @list ); } proto method categorize-list(|) { * } multi method categorize-list( &test, *@list ) { fail 'Cannot .categorize an infinite list' if @list.infinite; if @list { # multi-level categorize if test(@list[0])[0] ~~ List { for @list -> $l { for test($l) -> $k { my @keys = @($k); my $last := @keys.pop; my $hash = self; $hash = $hash{$_} //= self.new for @keys; nqp::push( nqp::p6listitems( nqp::decont($hash{$last} //= [])), $l ); } } } # just a simple categorize else { for @list -> $l { nqp::push( nqp::p6listitems(nqp::decont(self{$_} //= [])), $l ) for test($l); } } } self; } multi method categorize-list( %test, *@list ) { samewith( { %test{$^a} }, @list ); } multi method categorize-list( @test, *@list ) { samewith( { @test[$^a] }, @list ); } # push a value onto a hash slot, constructing an array if necessary method !_push_construct(Mu $key, Mu $value) { if self.exists_key($key) { if self.{$key}.^isa(Array) { self.{$key}.push($value); } else { my Mu $tmp = self.{$key}; self.{$key} = [ $tmp, $value]; } } else { self.{$key} = $value; } } my role TypedHash[::TValue] does Associative[TValue] { method at_key(::?CLASS:D: $key is copy) is rw { $key = $key.Str; if self.exists_key($key) { nqp::findmethod(EnumMap, 'at_key')(self, $key); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc(nqp::getattr(self, Hash, '$!descriptor'))), Scalar, '$!whence', -> { nqp::findmethod(EnumMap, 'STORE_AT_KEY')(self, $key, v) } ); } } method STORE_AT_KEY(Str \key, TValue $x) is rw { my $v := nqp::p6scalarfromdesc(nqp::getattr(self, Hash, '$!descriptor')); nqp::findmethod(EnumMap, 'STORE_AT_KEY')(self, key, $v = $x); } method bind_key($key, TValue \bindval) is rw { nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); nqp::bindkey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key.Str), bindval) } multi method perl(::?CLASS:D \SELF:) { 'Hash[' ~ TValue.perl ~ '].new(' ~ self.pairs.map({.perl}).join(', ') ~ ')'; } } my role TypedHash[::TValue, ::TKey] does Associative[TValue] { has $!keys; method keyof () { TKey } method at_key(::?CLASS:D: TKey \key) is rw { my $key_which = key.WHICH; if self.exists_key(key) { nqp::findmethod(EnumMap, 'at_key')(self, $key_which); } else { nqp::p6bindattrinvres( (my \v := nqp::p6scalarfromdesc(nqp::getattr(self, Hash, '$!descriptor'))), Scalar, '$!whence', -> { nqp::defined(nqp::getattr(self, $?CLASS, '$!keys')) || nqp::bindattr(self, $?CLASS, '$!keys', nqp::hash()); nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); nqp::bindkey( nqp::getattr(self, $?CLASS, '$!keys'), nqp::unbox_s($key_which), key); nqp::bindkey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key_which), v); }); } } method STORE_AT_KEY(TKey \key, TValue $x) is rw { my $key_which = key.WHICH; nqp::defined(nqp::getattr(self, $?CLASS, '$!keys')) || nqp::bindattr(self, $?CLASS, '$!keys', nqp::hash()); nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); nqp::bindkey( nqp::getattr(self, $?CLASS, '$!keys'), nqp::unbox_s($key_which), key); my $v := nqp::p6scalarfromdesc(nqp::getattr(self, Hash, '$!descriptor')); nqp::bindkey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key_which), $v = $x); } method bind_key(TKey \key, TValue \bindval) is rw { my $key_which = key.WHICH; nqp::defined(nqp::getattr(self, $?CLASS, '$!keys')) || nqp::bindattr(self, $?CLASS, '$!keys', nqp::hash()); nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) || nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); nqp::bindkey( nqp::getattr(self, $?CLASS, '$!keys'), nqp::unbox_s($key_which), key); nqp::bindkey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key_which), bindval) } method exists (TKey \key) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_key(key); } method exists_key(TKey \key) { nqp::defined($!keys) ?? nqp::p6bool(nqp::existskey($!keys, nqp::unbox_s(key.WHICH))) !! False } method keys(EnumMap:) { return unless self.DEFINITE && nqp::defined($!keys); HashIter.new(self, :keystore($!keys), :k).list } method kv(EnumMap:) { return unless self.DEFINITE && nqp::defined($!keys); HashIter.new(self, :keystore($!keys), :kv).list } method values(EnumMap:) { return unless self.DEFINITE && nqp::defined($!keys); HashIter.new(self, :keystore($!keys), :v).list } method pairs(EnumMap:) { return unless self.DEFINITE && nqp::defined($!keys); HashIter.new(self, :keystore($!keys), :pairs).list } method invert(EnumMap:) { return unless self.DEFINITE && nqp::defined($!keys); HashIter.new(self, :keystore($!keys), :invert).list } multi method perl(::?CLASS:D \SELF:) { 'Hash[' ~ TValue.perl ~ ',' ~ TKey.perl ~ '].new(' ~ self.pairs.map({.perl}).join(', ') ~ ')'; } } method PARAMETERIZE_TYPE(Mu $t, |c) { if c.elems == 0 { # my $what := self but TypedHash[$t.WHAT]; # too early in bootstrap my $what := self.HOW.mixin(self.WHAT, TypedHash[$t.WHAT]); # needs to be done in COMPOSE phaser when that works $what.HOW.set_name(self,"{self.HOW.name(self)}[{$t.HOW.name($t)}]"); $what; } elsif c.elems == 1 { my $what := self.HOW.mixin(self.WHAT, TypedHash[$t.WHAT,c[0]]); # my $what := self but TypedHash[$t.WHAT, c[0]]; # too early in bootstrap # needs to be done in COMPOSE phaser when that works $what.HOW.set_name(self,"{self.HOW.name(self)}[{$t.HOW.name($t)},{c[0].HOW.name(c[0])}]"); $what; } else { die "Can only type-constraint Hash with [ValueType] or [ValueType,KeyType]"; } } } sub circumfix:<{ }>(*@elems) { my $ = Hash.new(@elems) } sub hash(*@a, *%h) { my % = @a, %h } rakudo-2013.12/src/core/hash_slice.pm0000664000175000017500000001066712255230273016775 0ustar moritzmoritz# all sub postcircumfix {} candidates here please proto sub postcircumfix:<{ }>(|) { * } # %h multi sub postcircumfix:<{ }>( \SELF, $key ) is rw { SELF.at_key($key); } multi sub postcircumfix:<{ }>(\SELF, $key, Mu :$BIND! is parcel) is rw { SELF.bind_key($key, $BIND); } multi sub postcircumfix:<{ }>( \SELF, $key, :$SINK!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$SINK, |%other ); } multi sub postcircumfix:<{ }>( \SELF, $key, :$delete!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$delete, |%other ); } multi sub postcircumfix:<{ }>( \SELF, $key, :$exists!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$exists, |%other ); } multi sub postcircumfix:<{ }>( \SELF, $key, :$kv!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$kv, |%other ); } multi sub postcircumfix:<{ }>( \SELF, $key, :$p!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$p, |%other ); } multi sub postcircumfix:<{ }>( \SELF, $key, :$k!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$k, |%other ); } multi sub postcircumfix:<{ }>( \SELF, $key, :$v!, *%other ) is rw { SLICE_ONE( SELF, $key, False, :$v, |%other ); } # %h multi sub postcircumfix:<{ }>( \SELF, Positional \key ) is rw { nqp::iscont(key) ?? SELF.at_key(key) !! key.map({ SELF{$_} }).eager.Parcel; } multi sub postcircumfix:<{ }>(\SELF, Positional \key, :$BIND!) is rw { X::Bind::Slice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<{ }>(\SELF,Positional \key,:$SINK!,*%other) is rw { SLICE_MORE( SELF, \key, False, :$SINK, |%other ); } multi sub postcircumfix:<{ }>(\SELF,Positional \key,:$delete!,*%other) is rw { SLICE_MORE( SELF, \key, False, :$delete, |%other ); } multi sub postcircumfix:<{ }>(\SELF,Positional \key,:$exists!,*%other) is rw { SLICE_MORE( SELF, \key, False, :$exists, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Positional \key, :$kv!, *%other) is rw { SLICE_MORE( SELF, \key, False, :$kv, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Positional \key, :$p!, *%other) is rw { SLICE_MORE( SELF, \key, False, :$p, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Positional \key, :$k!, *%other) is rw { SLICE_MORE( SELF, \key, False, :$k, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Positional \key, :$v!, *%other) is rw { SLICE_MORE( SELF, \key, False, :$v, |%other ); } # %h{*} multi sub postcircumfix:<{ }>( \SELF, Whatever ) is rw { SELF{SELF.keys}; } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$BIND!) is rw { X::Bind::Slice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$SINK!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$SINK, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$delete!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$delete, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$exists!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$exists, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$kv!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$kv, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$p!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$p, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$k!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$k, |%other ); } multi sub postcircumfix:<{ }>(\SELF, Whatever, :$p!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$p, |%other ); } # %h{} multi sub postcircumfix:<{ }>( \SELF ) is rw { SELF; } multi sub postcircumfix:<{ }>(\SELF, :$BIND!) is rw { X::Bind::ZenSlice.new(type => SELF.WHAT).throw; } multi sub postcircumfix:<{ }>(\SELF, :$SINK!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$SINK, |%other ); } multi sub postcircumfix:<{ }>(\SELF, :$delete!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$delete, |%other ); } multi sub postcircumfix:<{ }>(\SELF, :$exists!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$exists, |%other ); } multi sub postcircumfix:<{ }>(\SELF, :$kv!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$kv, |%other ); } multi sub postcircumfix:<{ }>(\SELF, :$p!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$p, |%other ); } multi sub postcircumfix:<{ }>(\SELF, :$k!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$k, |%other ); } multi sub postcircumfix:<{ }>(\SELF, :$p!, *%other) is rw { SLICE_MORE( SELF, SELF.keys, False, :$p, |%other ); } rakudo-2013.12/src/core/Instant.pm0000664000175000017500000000577212224263172016314 0ustar moritzmoritzmy class Duration {... } my class Instant is Cool does Real { has Rat $.x; # A linear count of seconds since 1970-01-01T00:00:00Z, plus # tai-utc::initial-offset. Thus, $.x matches TAI from 1970 # to the present. method new($x) { self.bless: x => $x.Rat } method from-posix($posix, Bool $prefer-leap-second = False) { # $posix is in general not expected to be an integer. # If $prefer-leap-second is true, 915148800 is interpreted to # mean 1998-12-31T23:59:60Z rather than 1999-01-01T00:00:00Z. my $p = floor $posix; my $offset = tai-utc::initial-offset; for tai-utc::leap-second-posix() { if $_ < $p { ++$offset; } else { return self.new: $posix + $offset + do $_ == $p && !$prefer-leap-second } } self.new: $posix + $offset; } method to-posix() { # The inverse of .from-posix, except that the second return # value is true if *and only if* this Instant is in a leap # second. my $n = floor $.x; my $offset = tai-utc::initial-offset; for tai-utc::leap-second-posix() { if $_ < $n - $offset { ++$offset; } else { return ($.x - $offset, $n - $offset == $_) } } ($.x - $offset, False) } multi method Str(Instant:D:) { 'Instant:' ~ $.x } multi method perl(Instant:D:) { "Instant.new(x => $.x.perl())"; } method Bridge(Instant:D:) { $.x.Bridge } method Num (Instant:D:) { $.x.Num } method Int (Instant:D:) { $.x.Int } # TODO: should be the new .gist, probably # method Str() { # 'Instant:' ~ default-formatter # ::DateTime.new(self), :subseconds # } } multi sub infix:«cmp»(Instant:D $a, Instant:D $b) { $a.x <=> $b.x } multi sub infix:«<=>»(Instant:D $a, Instant:D $b) { $a.x <=> $b.x } multi sub infix:«==»(Instant:D $a, Instant:D $b) { $a.x == $b.x } multi sub infix:«!=»(Instant:D $a, Instant:D $b) { $a.x != $b.x } multi sub infix:«<»(Instant:D $a, Instant:D $b) { $a.x < $b.x } multi sub infix:«>»(Instant:D $a, Instant:D $b) { $a.x > $b.x } multi sub infix:«<=»(Instant:D $a, Instant:D $b) { $a.x <= $b.x } multi sub infix:«>=»(Instant:D $a, Instant:D $b) { $a.x >= $b.x } multi sub infix:<+>(Instant:D $a, Real:D $b) { Instant.new: $a.x + $b; } multi sub infix:<+>(Real:D $a, Instant:D $b) { Instant.new: $a + $b.x; } multi sub infix:<+>(Instant:D $a, Duration:D $b) { Instant.new: $a.x + $b.x; } multi sub infix:<+>(Duration:D $a, Instant:D $b) { Instant.new: $a.x + $b.x; } multi sub infix:<->(Instant:D $a, Instant:D $b) { Duration.new: $a.x - $b.x; } multi sub infix:<->(Instant:D $a, Real:D $b) { Instant.new: $a.x - $b; } sub term:() { # FIXME: During a leap second, the returned value is one # second greater than it should be. Instant.from-posix: nqp::time_n } rakudo-2013.12/src/core/Int.pm0000664000175000017500000001737712224263172015432 0ustar moritzmoritzmy class Rat { ... } my class X::Numeric::DivideByZero { ... } my class Int does Real { # declared in BOOTSTRAP # class Int is Cool { # has bigint $!value is box_target; multi method WHICH(Int:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.^name), '|'), nqp::tostr_I(self) ), ObjAt ); } multi method perl(Int:D:) { self.Str; } multi method Bool(Int:D:) { nqp::p6bool(nqp::bool_I(self)); } method Int() { self } multi method Str(Int:D:) { nqp::p6box_s(nqp::tostr_I(self)); } method Num(Int:D:) { nqp::p6box_n(nqp::tonum_I(self)); } method Rat(Int:D: $?) { Rat.new(self, 1); } method FatRat(Int:D: $?) { FatRat.new(self, 1); } method abs(Int:D:) { nqp::abs_I(self, Int) } method Bridge(Int:D:) { nqp::p6box_n(nqp::tonum_I(self)); } method chr(Int:D:) { nqp::p6box_s(nqp::chr(nqp::unbox_i(self))); } method sqrt(Int:D:) { nqp::p6box_n(nqp::sqrt_n(nqp::tonum_I(self))) } method base(Int:D: Cool $base) { fail("base must be between 2 and 36, got $base") unless 2 <= $base <= 36; my int $b = nqp::unbox_i($base.Int); nqp::p6box_s(nqp::base_I(self, $b)); } method expmod(Int:D: Int:D \base, Int:D \mod) { nqp::expmod_I(self, nqp::decont(base), nqp::decont(mod), Int); } method is-prime(Int:D: Int:D $tries = 100) returns Bool:D { nqp::p6bool(nqp::isprime_I(self, nqp::unbox_i($tries))); } method floor(Int:D:) { self } method ceiling(Int:D:) { self } proto method round(|) {*} multi method round(Int:D:) { self } multi method round(Int:D: $scale as Real) { (self / $scale + 1/2).floor * $scale } method lsb(Int:D:) { return Nil if self == 0; my $lsb = 0; my $x = self.abs; while $x +& 0xff == 0 { $lsb += 8; $x +>= 8; } while $x +& 0x01 == 0 { $lsb++; $x +>= 1; } $lsb; } method msb(Int:D:) { return Nil if self == 0; return 0 if self == -1; my $msb = 0; my $x = self; $x = ($x + 1) * -2 if $x < 0; # handle negative conversions while $x > 0xff { $msb += 8; $x +>= 8; } if $x > 0x0f { $msb += 4; $x +>= 4; } if $x +& 0x8 { $msb += 3; } elsif $x +& 0x4 { $msb += 2; } elsif $x +& 0x2 { $msb += 1; } $msb; } } multi prefix:<++>(Int:D \a is rw) { # XXX a = nqp::add_I(nqp::decont(a), nqp::p6box_i(1), Int); } multi prefix:<-->(Int:D \a is rw) { # XXX a = nqp::sub_I(nqp::decont(a), nqp::p6box_i(1), Int); } multi postfix:<++>(Int:D \a is rw) { # XXX my Int:D $b = a; a = nqp::add_I(nqp::decont(a), nqp::p6box_i(1), Int); $b } multi postfix:<-->(Int:D \a is rw) { # XXX my Int:D $b = a; a = nqp::sub_I(nqp::decont(a), nqp::p6box_i(1), Int); $b } multi prefix:<->(Int \a) returns Int { nqp::neg_I(nqp::decont(a), Int); } multi prefix:<->(int $a) returns int { nqp::neg_i($a) } multi abs(Int:D \a) returns Int:D { nqp::abs_I(nqp::decont(a), Int); } multi abs(int $a) returns int { nqp::abs_i($a) } multi infix:<+>(Int:D \a, Int:D \b) returns Int:D { nqp::add_I(nqp::decont(a), nqp::decont(b), Int); } multi infix:<+>(int $a, int $b) returns int { nqp::add_i($a, $b) } multi infix:<->(Int:D \a, Int:D \b) returns Int:D { nqp::sub_I(nqp::decont(a), nqp::decont(b), Int); } multi infix:<->(int $a, int $b) returns int { nqp::sub_i($a, $b) } multi infix:<*>(Int:D \a, Int:D \b) returns Int { nqp::mul_I(nqp::decont(a), nqp::decont(b), Int); } multi infix:<*>(int $a, int $b) returns int { nqp::mul_i($a, $b) } multi infix:

(Int:D \a, Int:D \b) { fail X::Numeric::DivideByZero.new unless b; nqp::div_I(nqp::decont(a), nqp::decont(b), Int) } multi infix:
(int $a, int $b) { fail X::Numeric::DivideByZero.new unless $b; nqp::div_i($a, $b) } multi infix:<%>(Int:D \a, Int:D \b) returns Int { fail X::Numeric::DivideByZero.new(using => 'infix:<%>') unless b; nqp::mod_I(nqp::decont(a), nqp::decont(b), Int); } multi infix:<%>(int $a, int $b) returns int { fail X::Numeric::DivideByZero.new(using => 'infix:<%>') unless $b; nqp::mod_i($a, $b) } multi infix:<**>(Int:D \a, Int:D \b) { nqp::pow_I(nqp::decont(a), nqp::decont(b), Num, Int); } multi infix:(Int:D \a, Int:D \b) returns Int { nqp::lcm_I(nqp::decont(a), nqp::decont(b), Int); } multi infix:(int $a, int $b) returns int { nqp::lcm_i($a, $b) } multi infix:(Int:D \a, Int:D \b) returns Int { nqp::gcd_I(nqp::decont(a), nqp::decont(b), Int); } multi infix:(int $a, int $b) returns int { nqp::gcd_i($a, $b) } multi infix:<===>(Int:D \a, Int:D \b) { nqp::p6bool(nqp::iseq_I(nqp::decont(a), nqp::decont(b))) } multi infix:<===>(int $a, int $b) { # hey, the optimizer is smart enough to figure that one out for us, no? $a == $b } multi infix:<==>(Int:D \a, Int:D \b) { nqp::p6bool(nqp::iseq_I(nqp::decont(a), nqp::decont(b))) } multi infix:<==>(int $a, int $b) { nqp::p6bool(nqp::iseq_i($a, $b)) } multi infix:(int $a, int $b) { nqp::p6bool(nqp::isne_i($a, $b)) } multi infix:«<»(Int:D \a, Int:D \b) { nqp::p6bool(nqp::islt_I(nqp::decont(a), nqp::decont(b))) } multi infix:«<»(int $a, int $b) { nqp::p6bool(nqp::islt_i($a, $b)) } multi infix:«<=»(Int:D \a, Int:D \b) { nqp::p6bool(nqp::isle_I(nqp::decont(a), nqp::decont(b))) } multi infix:«<=»(int $a, int $b) { nqp::p6bool(nqp::isle_i($a, $b)) } multi infix:«>»(Int:D \a, Int:D \b) { nqp::p6bool(nqp::isgt_I(nqp::decont(a), nqp::decont(b))) } multi infix:«>»(int $a, int $b) { nqp::p6bool(nqp::isgt_i($a, $b)) } multi infix:«>=»(Int:D \a, Int:D \b) { nqp::p6bool(nqp::isge_I(nqp::decont(a), nqp::decont(b))) } multi infix:«>=»(int $a, int $b) { nqp::p6bool(nqp::isge_i($a, $b)) } multi infix:<+|>(Int:D \a, Int:D \b) { nqp::bitor_I(nqp::decont(a), nqp::decont(b), Int) } multi infix:<+|>(int $a, int $b) { nqp::bitor_i($a, $b) } multi infix:<+&>(Int:D \a, Int:D \b) { nqp::bitand_I(nqp::decont(a), nqp::decont(b), Int) } multi infix:<+&>(int $a, int $b) { nqp::bitand_i($a, $b) } multi infix:<+^>(Int:D \a, Int:D \b) { nqp::bitxor_I(nqp::decont(a), nqp::decont(b), Int) } multi infix:<+^>(int $a, int $b) { nqp::bitxor_i($a, $b); } multi infix:«+<»(Int:D \a, Int:D \b) returns Int:D { nqp::bitshiftl_I(nqp::decont(a), nqp::unbox_i(b), Int) } multi infix:«+<»(int $a, int $b) { nqp::bitshiftl_i($a, $b); } multi infix:«+>»(Int:D \a, Int:D \b) returns Int:D { nqp::bitshiftr_I(nqp::decont(a), nqp::unbox_i(b), Int) } multi infix:«+>»(int $a, int $b) { nqp::bitshiftr_i($a, $b) } multi prefix:<+^>(Int:D \a) { nqp::bitneg_I(nqp::decont(a), Int); } multi prefix:<+^>(int $a) { nqp::bitneg_i($a); } proto sub chr($) is pure {*} multi sub chr(Int:D \x) returns Str:D { x.chr } multi sub chr(Cool \x) returns Str:D { x.Int.chr } multi sub chr(int $x) returns str { nqp::chr($x); } proto sub is-prime($, $?) is pure {*} multi sub is-prime(Int:D \i, Int:D $tries = 100) { nqp::p6bool(nqp::isprime_I(nqp::decont(i), nqp::unbox_i($tries))); } multi sub is-prime(\i, $tries = 100) { nqp::p6bool(nqp::isprime_I(nqp::decont(i.Int), nqp::unbox_i($tries.Int))); } proto sub expmod($, $, $) is pure {*} multi sub expmod(Int:D \base, Int:D \exp, Int:D \mod) { nqp::expmod_I(nqp::decont(base), nqp::decont(exp), nqp::decont(mod), Int); } multi sub expmod(\base, \exp, \mod) { nqp::expmod_I(nqp::decont(base.Int), nqp::decont(exp.Int), nqp::decont(mod.Int), Int); } proto sub lsb($) {*} multi sub lsb(Int:D \i) { i.lsb } proto sub msb($) {*} multi sub msb(Int:D \i) { i.msb } rakudo-2013.12/src/core/IO/ArgFiles.pm0000664000175000017500000000226012224263172016664 0ustar moritzmoritzmy class IO::ArgFiles is IO::Handle { has $.args; has $.filename; has $!io; has $.ins; method eof() { ! $!args && $!io.opened && $!io.eof } method get() { unless $!io.defined && $!io.opened { $!filename = $!args ?? $!args.shift !! '-'; $!io = open($!filename, :r) || fail "Unable to open file '$!filename'"; } my $x = $!io.get; while !$x.defined { $!io.close; $!io = IO::Handle; fail "End of argfiles reached" unless $!args; $x = self.get; } $!ins++; $x; } method lines($limit = *) { my $l = $limit ~~ Whatever ?? $Inf !! $limit; gather while $l-- > 0 { take $.get // last; } } method slurp(IO::ArgFiles:D:) { my @chunks; if $!io && $!io.opened { @chunks.push: nqp::p6box_s($!io.readall); $!io.close; } while $!args { my $fn = $!args.shift; my $file = open($fn); @chunks.push: $file.slurp; } return $*IN.slurp unless @chunks; @chunks.join; } } rakudo-2013.12/src/core/IO.pm0000664000175000017500000005042412255230273015175 0ustar moritzmoritzmy role IO { } sub print(|) { my $args := nqp::p6argvmarray(); $*OUT.print(nqp::shift($args)) while $args; Bool::True } sub say(|) { my $args := nqp::p6argvmarray(); $*OUT.print(nqp::shift($args).gist) while $args; $*OUT.print("\n"); } sub note(|) { my $args := nqp::p6argvmarray(); $*ERR.print(nqp::shift($args).gist) while $args; $*ERR.print("\n"); } sub gist(|) { nqp::p6parcel(nqp::p6argvmarray(), Mu).gist } sub prompt($msg) { print $msg; $*OUT.flush(); $*IN.get; } my role IO::FileTestable does IO { method d() { self.e && nqp::p6bool(nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_ISDIR)) } method e() { nqp::p6bool(nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_EXISTS)) } method f() { self.e && nqp::p6bool(nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_ISREG)) } method s() { self.e && nqp::p6box_i( nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_FILESIZE) ); } method l() { nqp::p6bool(nqp::fileislink(IO::Spec.rel2abs(self.Str))) } method r() { nqp::p6bool(nqp::filereadable(IO::Spec.rel2abs(self.Str))) } method w() { nqp::p6bool(nqp::filewritable(IO::Spec.rel2abs(self.Str))) } method x() { nqp::p6bool(nqp::fileexecutable(IO::Spec.rel2abs(self.Str))) } method z() { self.e && self.s == 0; } method modified() { nqp::p6box_i(nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_MODIFYTIME)); } method accessed() { nqp::p6box_i(nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_ACCESSTIME)); } method changed() { nqp::p6box_i(nqp::stat(nqp::unbox_s(IO::Spec.rel2abs(self.Str)), nqp::const::STAT_CHANGETIME)); } } my class IO::Handle does IO::FileTestable { has $!PIO; has Int $.ins = 0; has $.chomp = Bool::True; has $.path; proto method open(|) { * } multi method open($path? is copy, :$r, :$w, :$a, :$p, :$bin, :$chomp = Bool::True, :enc(:$encoding) = 'utf8') { $path //= $!path; my $abspath = defined($*CWD) ?? IO::Spec.rel2abs($path) !! $path; my $mode = $p ?? ($w || $a ?? 'wp' !! 'rp') !! ($w ?? 'w' !! ($a ?? 'wa' !! 'r' )); # TODO: catch error, and fail() nqp::bindattr(self, IO::Handle, '$!PIO', $path eq '-' ?? ( $w || $a ?? nqp::getstdout() !! nqp::getstdin() ) !! nqp::open(nqp::unbox_s($abspath.Str), nqp::unbox_s($mode)) ); $!path = $path; $!chomp = $chomp; nqp::setencoding($!PIO, $bin ?? 'binary' !! NORMALIZE_ENCODING($encoding)); self; } method close() { # TODO:b catch errors nqp::closefh($!PIO) if nqp::defined($!PIO); $!PIO := Mu; Bool::True; } method eof() { nqp::p6bool(nqp::eoffh($!PIO)); } method get() { unless nqp::defined($!PIO) { self.open($!path, :chomp($.chomp)); } return Str if self.eof; my Str $x = nqp::p6box_s(nqp::readlinefh($!PIO)); # XXX don't fail() as long as it's fatal # fail('end of file') if self.eof && $x eq ''; $x.=chomp if $.chomp; return Str if self.eof && $x eq ''; $!ins++; $x; } method getc() { unless $!PIO { self.open($!path, :chomp($.chomp)); } my $c = nqp::p6box_s(nqp::getcfh($!PIO)); fail if $c eq ''; $c; } method lines($limit = $Inf) { my $count = 0; gather while ++$count <= $limit && (my $line = self.get).defined { take $line; } } method read(IO::Handle:D: Cool:D $bytes as Int) { my $buf := buf8.new(); #?if parrot # Relies on nqp::encode passing the binary encoding straight on down # to Parrot. my Mu $parrot_buffer := $!PIO.read_bytes(nqp::unbox_i($bytes)); nqp::encode($parrot_buffer.get_string('binary'), 'binary', $buf); #?endif #?if jvm nqp::readfh($!PIO, $buf, nqp::unbox_i($bytes)); #?endif $buf; } # second arguemnt should probably be an enum # valid values for $whence: # 0 -- seek from beginning of file # 1 -- seek relative to current position # 2 -- seek from the end of the file method seek(IO::Handle:D: Int:D $offset, Int:D $whence) { $!PIO.seek(nqp::unbox_i($whence), nqp::unbox_i($offset)); True; } method tell(IO::Handle:D:) returns Int { nqp::p6box_i( #?if parrot $!PIO.tell #?endif #?if jvm nqp::tellfh($!PIO) #?endif ); } method write(IO::Handle:D: Blob:D $buf) { #?if parrot # This relies on the Parrot 'binary' encoding and that nqp::decode # passes encoding straight down to Parrot. my str $encoding = $!PIO.encoding; $!PIO.encoding('binary'); $!PIO.print(nqp::decode(nqp::decont($buf), 'binary')); $!PIO.encoding($encoding) unless $encoding eq 'binary'; #?endif #?if jvm nqp::writefh($!PIO, nqp::decont($buf)); #?endif True; } method opened() { nqp::p6bool(nqp::istrue($!PIO)); } method t() { self.opened && nqp::p6bool($!PIO.isatty) } proto method print(|) { * } multi method print(IO::Handle:D: Str:D $value) { nqp::printfh($!PIO, nqp::unbox_s($value)); Bool::True } multi method print(IO::Handle:D: *@list) { nqp::printfh($!PIO, nqp::unbox_s(@list.shift.Str)) while @list.gimme(1); Bool::True } multi method say(IO::Handle:D: |) { my Mu $args := nqp::p6argvmarray(); nqp::shift($args); self.print: nqp::shift($args).gist while $args; self.print: "\n"; } method slurp(:$bin, :enc($encoding)) { self.open(:r, :$bin) unless self.opened; self.encoding($encoding) if $encoding.defined; if $bin { my $Buf = buf8.new(); loop { my $current = self.read(10_000); $Buf ~= $current; last if $current.bytes == 0; } self.close; $Buf; } else { my $contents = nqp::p6box_s(nqp::readallfh($!PIO)); self.close(); $contents } } proto method spurt(|) { * } multi method spurt(Cool $contents, :encoding(:$enc) = 'utf8', :$createonly, :$append) { fail("File '" ~ self.path ~ "' already exists, but :createonly was give to spurt") if $createonly && self.e; if self.opened { self.encoding($enc); } else { my $mode = $append ?? :a !! :w; self.open(:$enc, |$mode); } self.print($contents); self.close; } multi method spurt(Blob $contents, :$createonly, :$append) { fail("File '" ~ self.path ~ "' already exists, but :createonly was give to spurt") if $createonly && self.e; unless self.opened { my $mode = $append ?? :a !! :w; self.open(:bin, |$mode); } self.write($contents); self.close; } # not spec'd method copy($dest) { warn "IO::Handle.copy is deprecated. Please use IO::Path.copy instead."; try { nqp::copy(nqp::unbox_s(IO::Spec.rel2abs(~$!path)), nqp::unbox_s(IO::Spec.rel2abs(~$dest))); } $! ?? fail(X::IO::Copy.new(from => $!path, to => $dest, os-error => ~$!)) !! True } method chmod(Int $mode) { self.path.absolute.chmod($mode) } method IO { self } method path { IO::Path.new($!path) } multi method Str (IO::Handle:D:) { $!path } multi method gist (IO::Handle:D:) { self.opened ?? "IO::Handle<$!path>(opened, at line {$.ins} / octet {$.tell})" !! "IO::Handle<$!path>(closed)" } multi method perl (IO::Handle:D:) { "IO::Handle.new(path => {$!path.perl}, ins => {$!ins.perl}, chomp => {$!chomp.perl})" } method flush() { fail("File handle not open, so cannot flush") unless nqp::defined($!PIO); nqp::flushfh($!PIO); True; } method encoding($enc?) { $enc.defined ?? nqp::setencoding($!PIO, NORMALIZE_ENCODING($enc)) !! $!PIO.encoding } } my class IO::Path is Cool does IO::FileTestable { method SPEC { IO::Spec.MODULE }; has Str $.path; method dir() { die "IO::Path.dir is deprecated in favor of .directory"; } submethod BUILD(:$!path!, :$dir) { die "Named paramter :dir in IO::Path.new deprecated in favor of :directory" if defined $dir; } multi method new(:$basename!, :$directory = '.', :$volume = '') { self.new: path=>$.SPEC.join($volume, $directory, $basename); } multi method new(Str:D $path) { self.new(:$path) } method path(IO::Path:D:) { self; } method parts { $.SPEC.split($!path).hash } method basename { self.parts } method directory { self.parts } method volume { self.parts } multi method Str(IO::Path:D:) { $!path; } multi method gist(IO::Path:D:) { "{self.^name}<{ $!path }>"; } multi method perl(IO::Path:D:) { "IO::Path.new(path => " ~ $.Str.perl ~ ")"; } multi method Numeric(IO::Path:D:) { self.basename.Numeric; } method Bridge(IO::Path:D:) { self.basename.Bridge; } method Int(IO::Path:D:) { self.basename.Int; } method succ(IO::Path:D:) { self.new(:$.volume, :$.directory, basename=> $.basename.succ) } method pred(IO::Path:D:) { self.new(:$.volume, :$.directory, basename=> $.basename.pred) } method IO(IO::Path:D: *%opts) { IO::Handle.new(:$!path, |%opts); } method open(IO::Path:D: *%opts) { open($!path, |%opts); } method is-absolute { $.SPEC.is-absolute($!path); } method is-relative { ! $.SPEC.is-absolute($!path); } method absolute ($base = ~$*CWD) { return self.new($.SPEC.rel2abs($!path, $base)); } method relative ($relative_to_directory = ~$*CWD) { return self.new($.SPEC.abs2rel($!path, $relative_to_directory)); } method cleanup (:$parent) { return self.new($.SPEC.canonpath($!path, :$parent)); } method resolve { # NYI: requires readlink() X::NYI.new(feature=>'IO::Path.resolve').fail; } method parent { if self.is-absolute { return self.new($.SPEC.join($.volume, $.directory, '')); } elsif all($.basename, $.directory) eq $.SPEC.curdir { return self.new(:$.volume, directory=>$.SPEC.curdir, basename=>$.SPEC.updir); } elsif $.basename eq $.SPEC.updir && $.directory eq $.SPEC.curdir or !grep({$_ ne $.SPEC.updir}, $.SPEC.splitdir($.directory)) { return self.new( # If all updirs, then add one more :$.volume, directory => $.SPEC.catdir($.directory, $.SPEC.updir), :$.basename ); } else { return self.new( $.SPEC.join($.volume, $.directory, '') ); } } method child ($childname) { self.new: path => $.SPEC.catfile($!path, $childname); } method copy(IO::Path:D: $dest, :$createonly = False) { my $absdest = IO::Spec.rel2abs($dest); if $createonly and $absdest.e { fail(X::IO::Copy.new(from => $!path, to => $dest, os-error => "Destination file $dest exists and :createonly passed to copy.")); } try { nqp::copy(nqp::unbox_s(IO::Spec.rel2abs($!path)), nqp::unbox_s(~$absdest)); } $! ?? fail(X::IO::Copy.new(from => $!path, to => $dest, os-error => ~$!)) !! True } method chmod(IO::Path:D: Int $mode) { nqp::chmod(nqp::unbox_s(IO::Spec.rel2abs($!path)), nqp::unbox_i($mode.Int)); return True; CATCH { default { X::IO::Chmod.new( :$!path, :$mode, os-error => .Str, ).throw; } } } method contents(IO::Path:D: Mu :$test = none('.', '..')) { CATCH { default { X::IO::Dir.new( :$!path, os-error => .Str, ).throw; } } #?if parrot my Mu $RSA := pir::new__PS('OS').readdir(nqp::unbox_s(self.absolute.Str)); my int $elems = nqp::elems($RSA); gather loop (my int $i = 0; $i < $elems; $i = $i + 1) { my Str $file := nqp::p6box_s(pir::trans_encoding__Ssi( nqp::atpos_s($RSA, $i), pir::find_encoding__Is('utf8'))); if $file ~~ $test { take self.child($file); } } #?endif #?if jvm my Mu $dirh := nqp::opendir(self.absolute.Str); my $next = 1; gather { take $_.path if $_ ~~ $test for ".", ".."; loop { my Str $elem := nqp::nextfiledir($dirh); if nqp::isnull_s($elem) { nqp::closedir($dirh); last; } else { $elem := $elem.substr($*CWD.chars + 1) if self.is-relative; if $elem.substr(0, 2) eq any("./", ".\\") { $elem := $elem.substr(2); } take $elem.path if $elem ~~ $test; } } } #?endif } } my class IO::Path::Unix is IO::Path { method SPEC { IO::Spec::Unix }; } my class IO::Path::Win32 is IO::Path { method SPEC { IO::Spec::Win32 }; } my class IO::Path::Cygwin is IO::Path { method SPEC { IO::Spec::Cygwin }; } my class IO::Path::QNX is IO::Path { method SPEC { IO::Spec::QNX }; } sub dir(Cool $path = '.', Mu :$test = none('.', '..')) { $path.path.contents(:$test) } sub unlink($path as Str) { my $abspath = IO::Spec.rel2abs($path); nqp::unlink($abspath); return True; CATCH { default { X::IO::Unlink.new( :$path, os-error => .Str, ).throw; } } } sub rmdir($path as Str) { my $abspath = IO::Spec.rel2abs($path); nqp::rmdir($abspath); return True; CATCH { default { X::IO::Rmdir.new( :$path, os-error => .Str, ).throw; } } } proto sub open(|) { * } multi sub open($path, :$r, :$w, :$a, :$p, :$bin, :$chomp = Bool::True, :enc(:$encoding) = 'utf8') { IO::Handle.new.open($path, :$r, :$w, :$a, :$p, :$bin, :$chomp, :$encoding); } proto sub lines(|) { * } multi sub lines($fh = $*ARGFILES, $limit = $Inf) { $fh.lines($limit) } proto sub get(|) { * } multi sub get($fh = $*ARGFILES) { $fh.get() } proto sub getc(|) { * } multi sub getc($fh = $*ARGFILES) { $fh.getc() } proto sub close(|) { * } multi sub close($fh) { $fh.close() } proto sub slurp(|) { * } multi sub slurp($filename, :$bin = False, :$enc = 'utf8') { $filename.IO.slurp(:$bin, :$enc); } multi sub slurp(IO::Handle $io = $*ARGFILES, :$bin, :$enc) { $io.slurp(:$bin, :$enc); } proto sub spurt(|) { * } multi sub spurt(IO::Handle $fh, Cool $contents, :encoding(:$enc) = 'utf8', :$createonly, :$append) { $fh.spurt($contents, :$enc, :$createonly, :$append); } multi sub spurt(IO::Handle $fh, Blob $contents, :$createonly, :$append) { $fh.spurt($contents, :$createonly, :$append); } multi sub spurt(Cool $filename, Cool $contents, :encoding(:$enc) = 'utf8', :$createonly, :$append) { $filename.IO.spurt($contents, :$enc, :$createonly, :$append); } multi sub spurt(Cool $filename, Blob $contents, :$createonly, :$append) { $filename.IO.spurt($contents, :$createonly, :$append); } { proto sub cwd(|) { * } multi sub cwd() { return nqp::p6box_s( #?if parrot pir::trans_encoding__Ssi( nqp::cwd(), pir::find_encoding__Is('utf8')) #?endif #?if !parrot nqp::cwd(), #?endif ); CATCH { default { X::IO::Cwd.new( os-error => .Str, ).throw; } } } PROCESS::<&cwd> := &cwd; } proto sub cwd(|) { * } multi sub cwd() { $*CWD } { proto sub chdir(|) { * } multi sub chdir($path as Str) { nqp::chdir(nqp::unbox_s($path)); $*CWD = IO::Path.new(cwd()); return True; CATCH { default { X::IO::Chdir.new( :$path, os-error => .Str, ).throw; } } } PROCESS::<&chdir> := &chdir; } proto sub chdir(|) { * } multi sub chdir(IO::Path:D $path) { chdir $path.Str } multi sub chdir($path as Str) { my $newpath = IO::Path.new($path); if $newpath.is-relative { my $tmp = $*CWD; for IO::Spec.splitdir($newpath) -> $segment { given $segment { when '..' { $tmp .= parent; } when '.' { } default { $tmp .= child($segment); } } } $newpath = $tmp; } if $newpath.d { $*CWD = $newpath; } else { X::IO::Chdir.new( path => $newpath, os-error => 'Directory does not exist' ).throw; } } proto sub mkdir(|) { * } multi sub mkdir($path as Str, $mode = 0o777) { my $abspath = IO::Spec.rel2abs($path); nqp::mkdir($abspath, $mode); return True; CATCH { default { X::IO::Mkdir.new( :$path, :$mode, os-error => .Str, ).throw; } } } $PROCESS::IN = open('-'); $PROCESS::OUT = open('-', :w); $PROCESS::ERR = IO::Handle.new; nqp::bindattr(nqp::decont($PROCESS::ERR), IO::Handle, '$!PIO', nqp::getstderr()); sub rename(Cool $from as Str, Cool $to as Str) { my $absfrom = IO::Spec.rel2abs($from); my $absto = IO::Spec.rel2abs($to); nqp::rename(nqp::unbox_s($absfrom), nqp::unbox_s($absto)); return True; CATCH { default { if .Str ~~ /'rename failed: '(.*)/ { X::IO::Rename.new( :$from, :$to, os-error => $0.Str, ).throw; } else { die "Unexpected error: $_"; } } } } sub copy(Cool $from as Str, Cool $to as Str) { my $absfrom = IO::Spec.rel2abs($from); my $absto = IO::Spec.rel2abs($to); nqp::copy(nqp::unbox_s($absfrom), nqp::unbox_s($absto)); return True; CATCH { default { X::IO::Copy.new( :$from, :$to, os-error => .Str, ).throw; } } } sub symlink(Cool $target as Str, Cool $name as Str) { my $abstarget = IO::Spec.rel2abs($target); nqp::symlink(nqp::unbox_s($abstarget), nqp::unbox_s($name)); return True; CATCH { default { X::IO::Symlink.new( :$target, :$name, os-error => .Str, ).throw; } } } sub link(Cool $target as Str, Cool $name as Str) { my $abstarget = IO::Spec.rel2abs($target); nqp::link(nqp::unbox_s($abstarget), nqp::unbox_s($name)); return True; CATCH { default { X::IO::Link.new( :$target, :$name, os-error => .Str, ).throw; } } } sub chmod($mode, $filename) { $filename.path.absolute.chmod($mode); $filename } rakudo-2013.12/src/core/IO/Socket/INET.pm0000664000175000017500000001253112224263172017161 0ustar moritzmoritzmy class IO::Socket::INET does IO::Socket { my module PIO { constant PF_LOCAL = 0; constant PF_UNIX = 1; constant PF_INET = 2; constant PF_INET6 = 3; constant PF_MAX = 4; constant SOCK_PACKET = 0; constant SOCK_STREAM = 1; constant SOCK_DGRAM = 2; constant SOCK_RAW = 3; constant SOCK_RDM = 4; constant SOCK_SEQPACKET = 5; constant SOCK_MAX = 6; constant PROTO_TCP = 6; constant PROTO_UDP = 17; } has Str $.encoding = 'utf8'; has Str $.host; has Int $.port = 80; has Str $.localhost; has Int $.localport; has Bool $.listen; has $.family = PIO::PF_INET; has $.proto = PIO::PROTO_TCP; has $.type = PIO::SOCK_STREAM; has Str $.input-line-separator is rw = "\n"; has Int $.ins = 0; my sub v4-split($uri) { return $uri.split(':', 2); } my sub v6-split($uri) { my ($host, $port) = ($uri ~~ /^'[' (.+) ']' \: (\d+)$/)[0,1]; return $host ?? ($host, $port) !! $uri; } method new (*%args is copy) { fail "Nothing given for new socket to connect or bind to" unless %args || %args; if %args { my ($host, $port) = %args && %args == PIO::PF_INET6() ?? v6-split(%args) !! v4-split(%args); if $port { %args //= $port; %args = $host; } } if %args { my ($peer, $port) = %args && %args == PIO::PF_INET6() ?? v6-split(%args) !! v4-split(%args); if $port { %args //= $port; %args = $peer; } } %args.=Bool if %args.exists_key('listen'); #TODO: Learn what protocols map to which socket types and then determine which is needed. self.bless(|%args)!initialize() } method !initialize() { #?if parrot my $PIO := Q:PIR { %r = root_new ['parrot';'Socket'] }; $PIO.socket($.family, $.type, $.proto); #?endif #?if !parrot my $PIO := nqp::socket($.listen ?? 10 !! 0); #?endif #Quoting perl5's SIO::INET: #If Listen is defined then a listen socket is created, else if the socket type, #which is derived from the protocol, is SOCK_STREAM then connect() is called. if $.listen || $.localhost || $.localport { #?if parrot my $addr := $PIO.sockaddr($.localhost || "0.0.0.0", $.localport || 0); $PIO.bind($addr); #?endif #?if !parrot nqp::bindsock($PIO, nqp::unbox_s($.localhost || "0.0.0.0"), nqp::unbox_i($.localport || 0)); #?endif } if $.listen { #?if parrot $PIO.listen($.listen); #?endif } elsif $.type == PIO::SOCK_STREAM { #?if parrot my $addr := $PIO.sockaddr($.host, $.port); $PIO.connect($addr); #?endif #?if !parrot my $addr := nqp::connect($PIO, nqp::unbox_s($.host), nqp::unbox_i($.port)); #?endif } nqp::bindattr(self, $?CLASS, '$!PIO', $PIO); self; } method get() { #?if parrot my str $encoding = nqp::unbox_s(NORMALIZE_ENCODING($!encoding)); my str $sep = pir::trans_encoding__SSI( nqp::unbox_s($!input-line-separator), pir::find_encoding__IS($encoding)); my int $sep-len = nqp::chars($sep); my Mu $PIO := nqp::getattr(self, $?CLASS, '$!PIO'); $PIO.encoding($encoding); my str $line = $PIO.readline($sep); #?endif #?if !parrot my str $sep = nqp::unbox_s($!input-line-separator); my int $sep-len = nqp::chars($sep); my Mu $io := nqp::getattr(self, $?CLASS, '$!PIO'); nqp::setencoding($io, nqp::unbox_s($!encoding)); nqp::setinputlinesep($io, $sep); my Str $line = nqp::p6box_s(nqp::readlinefh($io)); #?endif my int $len = nqp::chars($line); if $len == 0 { Str } else { ++$!ins; $len >= $sep-len && nqp::substr($line, $len - $sep-len) eq $sep ?? nqp::p6box_s(nqp::substr($line, 0, $len - $sep-len)) !! nqp::p6box_s($line); } } method lines() { gather while (my $line = self.get()).defined { take $line; } } method accept() { ## A solution as proposed by moritz my $new_sock := $?CLASS.bless(:$!family, :$!proto, :$!type, :$!input-line-separator); nqp::getattr($new_sock, $?CLASS, '$!buffer') = #?if parrot ''; #?endif #?if !parrot buf8.new; #?endif nqp::bindattr($new_sock, $?CLASS, '$!PIO', #?if parrot nqp::getattr(self, $?CLASS, '$!PIO').accept() #?endif #?if !parrot nqp::accept(nqp::getattr(self, $?CLASS, '$!PIO')) #?endif ); return $new_sock; } method remote_address() { #?if parrot return nqp::p6box_s(nqp::getattr(self, $?CLASS, '$!PIO').remote_address()); #?endif } method local_address() { #?if parrot return nqp::p6box_s(nqp::getattr(self, $?CLASS, '$!PIO').local_address()); #?endif } } rakudo-2013.12/src/core/IO/Socket.pm0000664000175000017500000000723412224263172016426 0ustar moritzmoritzmy role IO::Socket does IO { has $!PIO; has $!buffer = #?if parrot ''; #?endif #?if !parrot buf8.new; #?endif # if bin is true, will return Buf, Str otherwise method recv (Cool $chars = $Inf, :$bin? = False) { fail('Socket not available') unless $!PIO; #?if parrot if $!buffer.chars < $chars { my str $r = $!PIO.recv; unless $bin { my Mu $bb := pir::new__Ps('ByteBuffer'); pir::set__vPs($bb, $r); $r = $bb.get_string(NORMALIZE_ENCODING('utf8')); } $!buffer ~= nqp::p6box_s($r); } my $rec; if $!buffer.chars > $chars { $rec = $!buffer.substr(0, $chars); $!buffer = $!buffer.substr($chars); } else { $rec = $!buffer; $!buffer = ''; } if $bin { nqp::encode(nqp::unbox_s($rec), 'binary', buf8.new); } else { $rec } #?endif #?if !parrot if $!buffer.elems < $chars { my $r := nqp::readfh($!PIO, nqp::decont(buf8.new), 512); $!buffer ~= $r; } if $bin { my $rec; if $!buffer.elems > $chars { $rec = $!buffer.subbuf(0, $chars); $!buffer = $!buffer.subbuf($chars); } else { $rec = $!buffer; $!buffer = buf8.new; } $rec; } else { my $rec = nqp::decode(nqp::decont($!buffer), 'utf8'); if $rec.chars > $chars { $rec = $rec.substr(0, $chars); my $used = $rec.encode('utf8').elems; $!buffer = $!buffer.subbuf($used) } else { $!buffer = buf8.new; } $rec; } #?endif } method read(IO::Socket:D: Cool $bufsize as Int) { fail('Socket not available') unless $!PIO; #?if parrot my str $res; my str $read; repeat { my Mu $parrot_buf := pir::new__PS('ByteBuffer'); pir::set__vPS($parrot_buf, $!PIO.read(nqp::unbox_i($bufsize - nqp::chars($res)))); $read = $parrot_buf.get_string('binary'); $res = nqp::concat($res, $read); } while nqp::chars($res) < $bufsize && nqp::chars($read); nqp::encode(nqp::unbox_s($res), 'binary', buf8.new); #?endif #?if !parrot my $res = buf8.new(); my $buf; repeat { $buf := buf8.new(); nqp::readfh($!PIO, $buf, nqp::unbox_i($bufsize - $res.elems)); $res ~= $buf; } while $res.elems < $bufsize && $buf.elems; $res; #?endif } method poll(Int $bitmask, $seconds) { #?if parrot $!PIO.poll( nqp::unbox_i($bitmask), nqp::unbox_i($seconds.floor), nqp::unbox_i((($seconds - $seconds.floor) * 1000).Int) ); #?endif #?if !parrot die 'Socket.poll is NYI on this backend' #?endif } method send (Cool $string as Str) { fail("Not connected") unless $!PIO; #?if parrot $!PIO.send(nqp::unbox_s($string)).Bool; #?endif #?if !parrot nqp::printfh($!PIO, nqp::unbox_s($string)); True #?endif } method write(Blob:D $buf) { fail('Socket not available') unless $!PIO; #?if parrot $!PIO.send(nqp::decode(nqp::decont($buf), 'binary')).Bool; #?endif #?if !parrot nqp::writefh($!PIO, nqp::decont($buf)); True #?endif } method close () { fail("Not connected!") unless $!PIO; #?if parrot $!PIO.close().Bool #?endif #?if !parrot nqp::closefh($!PIO); True #?endif } } rakudo-2013.12/src/core/IO/Spec/Cygwin.pm0000664000175000017500000000326212224263172017325 0ustar moritzmoritzmy class IO::Spec::Cygwin is IO::Spec::Unix { #| Any C<\> (backslashes) are converted to C (forward slashes), #| and then IO::Spec::Unix.canonpath() is called on the result. method canonpath (Cool:D $path is copy) { $path.=subst(:g, '\\', '/'); # Handle network path names beginning with double slash my $node = ''; if $path ~~ s/^ ('//' <-[/]>+) [ '/' | $ ] /\// { #/ $node = ~$0; } $node ~ IO::Spec::Unix.canonpath($path); } #| Calls the Unix version, and additionally prevents #| accidentally creating a //network/path. method catdir ( *@paths ) { my $result = IO::Spec::Unix.catdir(@paths); # Don't create something that looks like a //network/path $result.subst(/ <[\\\/]> ** 2..*/, '/'); } #| Tests if the file name begins with C or a slash. method is-absolute ($file) { so $file ~~ / ^ [<[A..Z a..z]> ':']? <[\\/]>/; # C:/test } method tmpdir { self.canonpath: first( { .defined && .IO.d && .IO.w }, %*ENV, "/tmp", %*ENV, %*ENV, 'C:/temp') || self.curdir; } # Paths might have a volume, so we use Win32 splitpath and catpath instead method splitpath (|c) { IO::Spec::Win32.splitpath(|c) } method catpath (|c) { IO::Spec::Win32.catpath(|c).subst(:global, '\\', '/') } method split ($path) { IO::Spec::Win32.split($path).map: { (.key => .value.subst(:global, '\\', '/')) } } method join (|c) { IO::Spec::Win32.join(|c).subst(:global, '\\', '/') } } rakudo-2013.12/src/core/IO/Spec.pm0000664000175000017500000000567512224263172016077 0ustar moritzmoritzmy class IO::Spec { my %module = ( 'MSWin32' => 'Win32', 'os2' => 'Win32', 'dos' => 'Win32', 'symbian' => 'Win32', 'NetWare' => 'Win32', 'Win32' => 'Win32', 'cygwin' => 'Cygwin', 'Cygwin' => 'Cygwin', 'qnx' => 'QNX', 'QNX' => 'QNX', 'nto' => 'QNX', # »=>» 'Mac', # 'VMS' => 'VMS' ); # this is really just a way of getting $*OS when it's not in scope yet my $submodule; #?if parrot $submodule = %module{ nqp::atkey(nqp::atpos(pir::getinterp__P, pir::const::IGLOBALS_CONFIG_HASH), 'osname') }; #?endif #?if jvm $submodule = %module{ nqp::p6box_s(nqp::atkey(nqp::jvmgetproperties(), 'os.name')) }; #?endif my $SPEC := IO::Spec.WHO{ $submodule // 'Unix' }; method FSTYPE ($OS = $*OS) { %module{$OS} // 'Unix' } #| Dispatches methods to the appropriate class for the current $*OS #| Well, it should, if handles worked here. Still useful, though. method MODULE # handles # { $SPEC } #| Returns a copy of the module for the given OS string #| e.g. IO::Spec.os('Win32') returns IO::Spec::Win32 method os (Str $OS = $*OS) { IO::Spec.WHO{%module{$OS} // 'Unix'}; } method canonpath( |c ) { $SPEC.canonpath( |c ) } method curdir { $SPEC.curdir() } method updir { $SPEC.updir() } method rootdir { $SPEC.rootdir() } method devnull { $SPEC.devnull() } method tmpdir { $SPEC.tmpdir() } method is-absolute( |c ) { $SPEC.is-absolute( |c ) } method no-parent-or-current-test { $SPEC.no-parent-or-current-test } method path { $SPEC.path() } method split ( |c ) { $SPEC.split( |c ) } method join ( |c ) { $SPEC.join( |c ) } method splitpath( |c ) { $SPEC.splitpath( |c ) } method catpath( |c ) { $SPEC.catpath( |c ) } method catfile( |c ) { $SPEC.catfile( |c ) } method splitdir( |c ) { $SPEC.splitdir( |c ) } method catdir( |c ) { $SPEC.catdir( |c ) } method abs2rel( |c ) { $SPEC.abs2rel( |c ) } method rel2abs( |c ) { $SPEC.rel2abs( |c ) } } nqp::gethllsym('perl6', 'ModuleLoader').register_absolute_path_func( sub ($path) { return IO::Spec.rel2abs($path); } ); rakudo-2013.12/src/core/IO/Spec/QNX.pm0000664000175000017500000000122512224263172016530 0ustar moritzmoritzmy class IO::Spec::QNX is IO::Spec::Unix { method canonpath ($path is copy, :$parent) { # Handle POSIX-style node names beginning with double slash (qnx, nto) # (POSIX says: "a pathname that begins with two successive slashes # may be interpreted in an implementation-defined manner, although # more than two leading slashes shall be treated as a single slash.") my $node = ''; if $path ~~ s {^ ( '//' <-[ / ]>+ ) '/'? $} = '' or $path ~~ s {^ ( '//' <-[ / ]>+ ) '/' } = '/' { $node = ~ $0; } $path = IO::Spec::Unix.canonpath($path, :$parent); $node ~ $path; } }rakudo-2013.12/src/core/IO/Spec/Unix.pm0000664000175000017500000001223112231261374017004 0ustar moritzmoritzmy class IO::Spec { ... } my class IO::Spec::Unix { method canonpath( $path is copy, :$parent --> Str) { return '' if $path eq ''; $path ~~ s:g { '//' '/'* } = '/'; # xx////xx -> xx/xx $path ~~ s:g { '/.'+ ['/' | $] } = '/'; # xx/././xx -> xx/xx $path ~~ s { ^ './' } = ''; # ./xx -> xx if $parent { while $path ~~ s:g { [^ | ] <-[/]>+ '/..' ['/' | $ ] } = '' { }; $path = '.' if $path eq ''; } $path ~~ s { ^ '/..'+ ['/' | $] } = '/'; # /../..(/xx) -> /(xx) unless $path eq "/" { $path ~~ s { '/' $ } = ''; # xx/ -> xx :) } $path } method curdir { '.' } method updir { '..' } method rootdir { '/' } method devnull { '/dev/null' } method tmpdir { self.canonpath: first( { .defined && .IO.d && .IO.w }, %*ENV, '/tmp') || self.curdir; } method no-parent-or-current-test { none('.', '..') } method is-absolute( $file ) { so $file ~~ m/^\// } method path { return () unless %*ENV{'PATH'}; my @path = %*ENV{'PATH'}.split( ':' ); for @path { $_ = '.' if $_ eq '' } return @path } method splitpath( $path, :$nofile = False ) { my ( $directory, $file ) = ( '', '' ); if $nofile { $directory = $path; } else { $path ~~ m/^ ( [ .* \/ [ '.'**1..2 $ ]? ]? ) (<-[\/]>*) /; $directory = ~$0; $file = ~$1; } return ( '', $directory, $file ); } method split (Cool:D $path is copy ) { $path ~~ s/ '/'+ $ //; $path ~~ m/^ ( [ .* \/ ]? ) (<-[\/]>*) /; my ($directory, $basename) = ~$0, ~$1; $directory ~~ s/ '/'+ $ //; #/ $basename = '/' if $directory eq '/' && $basename eq ''; $directory = '.' if $directory eq '' && $basename ne ''; # shell dirname '' produces '.', but we don't because it's probably user error return (:volume(''), :$directory, :$basename ); } method join ($volume, $directory is copy, $file) { $directory = '' if all($directory, $file) eq '/' or $directory eq '.' && $file.chars; self.catpath($volume, $directory, $file); } method catpath( $volume, $directory is copy, $file ) { if $directory ne '' && $file ne '' && $directory.substr( *-1 ) ne '/' && $file.substr( 0, 1 ) ne '/' { $directory ~= "/$file" } else { $directory ~= $file } return $directory } method catdir( *@parts ) { self.canonpath( (@parts, '').join('/') ) } method splitdir( $path ) { $path.split( /\// ) } method catfile( |c ) { self.catdir(|c) } method abs2rel( $path is copy, $base is copy = Str ) { $base = $*CWD unless $base.defined && $base.chars; if self.is-absolute($path) || self.is-absolute($base) { $path = self.rel2abs( $path ); $base = self.rel2abs( $base ); } else { # save a couple of cwd()s if both paths are relative $path = self.catdir( self.rootdir, $path ); $base = self.catdir( self.rootdir, $base ); } my ($path_volume, $path_directories) = self.splitpath( $path, :nofile ); my ($base_volume, $base_directories) = self.splitpath( $base, :nofile ); # Can't relativize across volumes return $path unless $path_volume eq $base_volume; # For UNC paths, the user might give a volume like //foo/bar that # strictly speaking has no directory portion. Treat it as if it # had the root directory for that volume. if !$base_directories.chars && self.is-absolute( $base ) { $base_directories = self.rootdir; } # Now, remove all leading components that are the same my @pathchunks = self.splitdir( $path_directories ); my @basechunks = self.splitdir( $base_directories ); if $base_directories eq self.rootdir { @pathchunks.shift; return self.canonpath( self.catpath('', self.catdir( @pathchunks ), '') ); } while @pathchunks && @basechunks && @pathchunks[0] eq @basechunks[0] { @pathchunks.shift; @basechunks.shift; } return self.curdir unless @pathchunks || @basechunks; # $base now contains the directories the resulting relative path # must ascend out of before it can descend to $path_directory. my $result_dirs = self.catdir( self.updir() xx @basechunks.elems, @pathchunks ); return self.canonpath( self.catpath('', $result_dirs, '') ); } method rel2abs( $path, $base is copy = $*CWD) { return self.canonpath($path) if self.is-absolute($path); if !self.is-absolute( $base ) { $base = self.rel2abs( $base, $*CWD ) unless $base eq $*CWD; } self.catdir( $base, $path ); } } rakudo-2013.12/src/core/IO/Spec/Win32.pm0000664000175000017500000001533512224263172016773 0ustar moritzmoritzmy 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, %*ENV, %*ENV, 'SYS:/temp', 'C:\system\temp', 'C:/temp', '/tmp', '/') || self.curdir; } method path { my @path = split(';', %*ENV); @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/ <$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 { [^ | ] <-[\\]>+ '\\..' ['\\' | $ ] } = '' { }; } $path ~~ s/^ '\\'+ //; # \xx --> xx NOTE: this is *not* root $path ~~ s/ '\\'+ $//; # xx\ --> xx if $volume ~~ / '\\' $ / { # \.. --> \ $path ~~ s/ ^ '..' '\\..'* [ '\\' | $ ] //; } if $path eq '' { # \\HOST\SHARE\ --> \\HOST\SHARE $volume ~~ s/ '\\' $ //; $volume || '.'; } else { $volume ~ $path; } } } rakudo-2013.12/src/core/Iterable.pm0000664000175000017500000000073612224263172016416 0ustar moritzmoritzmy class Iterable { # declared in BOOTSTRAP # class Iterable is Any { method elems() { self.list.elems } method infinite() { Nil } method item($self:) { $self } method fmt($format = '%s', $separator = ' ') { self.list.fmt($format, $separator) } method Int() { self.elems } method Num() { self.elems.Num } multi method Numeric(Iterable:D:) { self.elems } multi method Str(Iterable:D:) { self.list.Str } } rakudo-2013.12/src/core/Iterator.pm0000664000175000017500000000017612224263172016456 0ustar moritzmoritzmy class Iterator { # declared in BOOTSTRAP # class Iterator is Iterable { method iterator() { nqp::decont(self) } } rakudo-2013.12/src/core/Junction.pm0000664000175000017500000001216212224263172016454 0ustar moritzmoritzmy class Junction { # declared in BOOTSTRAP # class Junction is Mu { # has Mu $!storage; # elements of Junction # has Mu $!type; # type of Junction method new(*@values, :$type) { self.bless(:storage(@values.eager), :$type); } multi method Bool(Junction:D:) { ($!storage.map({return True if $_}).gimme(*); return False) if $!type eq 'any'; ($!storage.map({return False unless $_}).gimme(*); return True) if $!type eq 'all'; ($!storage.map({return False if $_}).gimme(*); return True) if $!type eq 'none'; # 'one' junction my $count = 0; $!storage.map({ $count++ if $_; return False if $count > 1 }).gimme(*); $count == 1; } multi method Str(Junction:D:) { self.perl } multi method ACCEPTS(Junction:D: Mu \topic) { ($!storage.map({return True if $_.ACCEPTS(topic)}).gimme(*); return False) if $!type eq 'any'; ($!storage.map({return False unless $_.ACCEPTS(topic)}).gimme(*); return True) if $!type eq 'all'; ($!storage.map({return False if $_.ACCEPTS(topic)}).gimme(*); return True) if $!type eq 'none'; # 'one' junction my $count = 0; $!storage.map({ $count++ if $_.ACCEPTS(topic); return False if $count > 1 }).gimme(*); $count == 1; } submethod BUILD(:$!storage, :$!type) { } multi method gist(Junction:D:) { $!type ~ '(' ~ $!storage.map({$_.gist}).join(', ') ~ ')' } multi method perl(Junction:D:) { $!type ~ '(' ~ $!storage.map({$_.perl}).join(', ') ~ ')' } method postcircumfix:<( )>($c) { self.AUTOTHREAD( -> $obj, |c { $obj(|c) }, self, |$c); } method sink(Junction:D:) { .?sink for $!storage.list; Nil; } method AUTOTHREAD(&call, |args) { my Mu $pos_rpa := nqp::getattr(nqp::decont(args), Capture, '$!list'); sub thread_junction(int $i) { my Junction $arg := nqp::atpos($pos_rpa, $i); my Str $type := nqp::getattr(nqp::decont($arg), Junction, '$!type'); my @states := nqp::getattr(nqp::decont($arg), Junction, '$!storage'); my Mu $res := nqp::list(); for @states -> $s { # Next line is Officially Naughty, since captures are meant to be # immutable. But hey, it's our capture to be naughty with... nqp::bindpos($pos_rpa, $i, $s); nqp::push($res, call(|args)); Nil; } return Junction.new(nqp::p6parcel($res, Nil), :type($type)); } # Look for a junctional arg in the positionals. # we have to autothread the first all or none junction before # doing any one or any junctions. my int $first_one_any = -1; loop (my int $i = 0; $i < nqp::elems($pos_rpa); $i = $i + 1) { # Junctional positional argument? my Mu $arg := nqp::atpos($pos_rpa, $i); if nqp::istype($arg, Junction) { my Str $type := nqp::getattr(nqp::decont($arg), Junction, '$!type'); if ($type eq "one" || $type eq "any") { if $first_one_any == -1 { # save it for later, first make sure we don't have all or none junctions later. $first_one_any = $i; } } else { return thread_junction($i); } } } if $first_one_any >= 0 { return thread_junction($first_one_any); } # Otherwise, look for one in the nameds. for args.hash.kv -> $k, $v { if nqp::istype($v, Junction) { my Mu $nam_hash := nqp::getattr(nqp::decont(args), Capture, '$!hash'); my @states := nqp::getattr(nqp::decont($v), Junction, '$!storage'); my $type := nqp::getattr(nqp::decont($v), Junction, '$!type'); my Mu $res := nqp::list(); for @states -> $s { nqp::bindkey($nam_hash, $k, $s); nqp::push($res, call(|args)); Nil; } return Junction.new(nqp::p6parcel($res, Nil), :type($type)); } } # If we get here, wasn't actually anything to autothread. call(|args); } } sub any(*@values) { Junction.new(@values, :type); } sub all(*@values) { Junction.new(@values, :type); } sub one(*@values) { Junction.new(@values, :type); } sub none(*@values) { Junction.new(@values, :type); } sub infix:<|>(**@values) { Junction.new(@values, :type); } sub infix:<&>(**@values) { Junction.new(@values, :type); } sub infix:<^>(**@values) { Junction.new(@values, :type); } sub AUTOTHREAD(|c) { Junction.AUTOTHREAD(|c) } sub AUTOTHREAD_METHOD($name, |c) { Junction.AUTOTHREAD( -> $obj, |c { $obj."$name"(|c) }, |c); } nqp::p6setautothreader(&AUTOTHREAD); Mu.HOW.setup_junction_fallback(Junction, &AUTOTHREAD_METHOD); rakudo-2013.12/src/core/ListIter.pm0000664000175000017500000000734612253363744016442 0ustar moritzmoritzmy class List { ... } my class ListIter { # declared in BOOTSTRAP # class ListIter is Iterator { # has Mu $!reified; # return value for already-reified iterator # has Mu $!nextiter; # next iterator in sequence, if any # has Mu $!rest; # VM's array of elements remaining to be reified # has Mu $!list; # List object associated with this iterator method reify($n = 1, :$sink) { unless nqp::isconcrete($!reified) { my $eager = nqp::p6bool(nqp::istype($n, Whatever)); my $flattens = nqp::p6bool(nqp::isconcrete($!list)) && $!list.flattens; my int $max = 100_000; my int $count; my $rpa := nqp::list(); if $eager { $count = $max; } else { $count = nqp::unbox_i(nqp::istype($n, Int) ?? $n !! $n.Int); nqp::setelems($rpa, $count); nqp::setelems($rpa, 0); } my Mu $x; my int $index; my $want_types := $flattens ?? nqp::list(Iterable, Parcel) !! nqp::list(Iterable); nqp::p6shiftpush($rpa, $!rest, nqp::elems($!rest)) if nqp::istype($!list, LoL); while $!rest && (nqp::elems($rpa) < $count) { $index = nqp::p6arrfindtypes($!rest, $want_types, 0, $max); nqp::p6shiftpush($rpa, $!rest, $index); if $!rest && (nqp::elems($rpa) < $count) { $x := nqp::shift($!rest); if nqp::isconcrete($x) { (nqp::unshift($!rest, $x); last) if $eager && $x.infinite; $x := $x.iterator.reify( $eager ?? Whatever !! nqp::p6box_i($count - nqp::elems($rpa)), :$sink) if nqp::istype($x, Iterable); nqp::splice($!rest, nqp::getattr($x, Parcel, '$!storage'), 0, 0); } elsif nqp::not_i(nqp::istype($x, Nil)) { nqp::push($rpa, $x); } } } my $reified := nqp::p6parcel($rpa, Any); nqp::bindattr(self, ListIter, '$!nextiter', nqp::p6listiter($!rest, $!list)) if $!rest; $reified := $!list.REIFY($reified, $!nextiter) if nqp::isconcrete($!list); nqp::push( nqp::getattr($reified, Parcel, '$!storage'), $!nextiter) if $!rest; nqp::bindattr(self, ListIter, '$!reified', $reified); # free up $!list and $!rest nqp::bindattr(self, ListIter, '$!list', Mu); nqp::bindattr(self, ListIter, '$!rest', Mu); } $!reified; } method infinite() { $!rest ?? nqp::istype(nqp::atpos($!rest, 0), Iterable) && nqp::atpos($!rest,0).infinite || Nil !! Bool::False } method iterator() { self } method nextiter() { $!nextiter } multi method DUMP(ListIter: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, '$!list' ); nqp::push($attrs, $!list ); nqp::push($attrs, '$!reified' ); nqp::push($attrs, $!reified ); nqp::push($attrs, '$!nextiter'); nqp::push($attrs, $!nextiter ); nqp::push($attrs, '$!rest' ); nqp::push($attrs, $!rest ); self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx, :$flags); } } rakudo-2013.12/src/core/List.pm0000664000175000017500000004513012255230273015577 0ustar moritzmoritz# for our tantrums my class X::TypeCheck { ... } 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); } method Bool() { self.gimme(1).Bool } method Int() { self.elems } method end() { self.elems - 1 } multi method Numeric(List:D:) { self.elems } multi method Str(List:D:) { self.join(' ') } 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 } my &itemify = { .elems == 1 ?? $_ !! [.list] }; proto method tree(|) {*} multi method tree(List:U:) { self } multi method tree(List:D:) { MapIter.new(self, &itemify, Mu).list; } multi method tree(List:D: Cool $count as Int) { $count <= 0 ?? self !! $count == 1 ?? self.tree !! MapIter.new( self, {.elems == 1 ?? $_ !! [.tree($count - 1)]}, Mu ).list; } multi method tree(List:D: &c) { MapIter.new(self, &c, Mu).list; } # uncommenting causes "Circularity detected in multi sub types" # multi method tree(List:D: *@ [$first, *@rest] where {.elems >= 2 }) { # MapIter.new(:list(self), :block(*.list(|@rest))).list.tree($first) # } 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); } multi method at_pos(List:D: $pos is copy) is rw { $pos = $pos.Int; self.exists_pos($pos) ?? nqp::atpos($!items, nqp::unbox_i($pos)) !! Nil; } multi method at_pos(List:D: int $pos) is rw { self.exists_pos($pos) ?? nqp::atpos($!items, $pos) !! Nil; } method eager() { self.gimme(*); self } method elems() { return 0 unless self.DEFINITE; # 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(*); $!nextiter.defined ?? $Inf !! $n } method exists (\pos) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_pos(pos); } method exists_pos(\pos) { return False if !self.DEFINITE || pos < 0; self.gimme(pos + 1); nqp::p6bool( !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)); my $eager = nqp::p6bool(nqp::istype($n, Whatever) || $n == $Inf); while $!nextiter.defined && ($eager ?? !$!nextiter.infinite !! ($count < $n)) { $!nextiter.reify($eager ?? Whatever !! $n - $count, :$sink); $count = nqp::elems($!items); } # return the number of elements we have now $count } method infinite() { self.DEFINITE && $!nextiter.defined && $!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 ) } method pick($n is copy = 1) { fail "Cannot .pick from infinite list" if self.infinite; #MMD? ## 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'; } multi method push(List:D: *@values) { fail 'Cannot .push an infinite list' if @values.infinite; self.gimme(*); fail 'Cannot .push to an infinite list' if $!nextiter.defined; nqp::p6listitems(self); # don't bother with type checks if ( self.of =:= Mu ) { nqp::push( $!items, @values.shift ) while @values.gimme(1); } # we must check types else { my $of = self.of; while @values.gimme(1) { my $value := @values.shift; if $value ~~ $of { nqp::push( $!items, $value ); } # huh? else { X::TypeCheck.new( operation => '.push', expected => $of, got => $value, ).throw; } } } self; } multi method unshift(List:D: *@values) { fail 'Cannot .unshift an infinite list' if @values.infinite; nqp::p6listitems(self); # don't bother with type checks if ( self.of =:= Mu ) { nqp::unshift($!items, @values.pop) while @values; } # we must check types else { my $of = self.of; while @values { my $value := @values.pop; if $value ~~ $of { nqp::unshift($!items, $value); } # huh? else { X::TypeCheck.new( operation => '.unshift', expected => $of, got => $value, ).throw; } } } self } method roll($n is copy = 1) { my $elems = self.gimme(*); fail 'Cannot .roll from an infinite list' if $!nextiter.defined; 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 Mu $res := nqp::clone($!items); $n %= nqp::p6box_i(nqp::elems($!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:) { fail 'Cannot .sort an infinite list' if self.infinite; #MMD? # We defer to Parrot's ResizablePMCArray.sort method here. # Instead of sorting elements directly, we sort a Parcel of # indices from 0..^$list.elems, then use that Parcel as # a slice into self. # Range is currently optimized for fast Parcel construction. my $index := Range.new(0, self.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[$a] cmp $list[$b] || $a <=> $b }); } else { my $list = self.eager; nqp::p6sort($index_rpa, -> $a, $b { $by($list[$a],$list[$b]) || $a <=> $b }); } self[$index]; } multi method ACCEPTS(List:D: $topic) { my $sseq = self; my $tseq = $topic.list; my $spos = 0; my $tpos = 0; while $spos < +$sseq { # if the next element is Whatever if $sseq[$spos] ~~ Whatever { # skip over all of the Whatevers $spos++ while $spos <= +$sseq && $sseq[$spos] ~~ Whatever; # if nothing left, we're done return True if !($spos < +$sseq); # find a target matching our new target $tpos++ while ($tpos < +$tseq) && $tseq[$tpos] !== $sseq[$spos]; # return false if we ran out return False if !($tpos < +$tseq); } elsif $tpos >= +$tseq || $tseq[$tpos] !=== $sseq[$spos] { return False; } # skip matching elements $spos++; $tpos++; } # If nothing left to match, we're successful. $tpos >= +$tseq; } proto method uniq(|) {*} multi method uniq() { my $seen := nqp::hash(); my str $target; map { $target = nqp::unbox_s($_.WHICH); if nqp::existskey($seen, $target) { Nil; } else { nqp::bindkey($seen, $target, 1); $_; } }, @.list; } multi method uniq( :&as!, :&with! ) { my @seen; # should be Mu, but doesn't work in settings :-( my Mu $target; map { $target = &as($_); if first( { with($target,$_) }, @seen ) =:= Nil { @seen.push($target); $_; } else { Nil; } }, @.list; } multi method uniq( :&as! ) { my $seen := nqp::hash(); my str $target; map { $target = &as($_).WHICH; if nqp::existskey($seen, $target) { Nil; } else { nqp::bindkey($seen, $target, 1); $_; } }, @.list; } multi method uniq( :&with! ) { nextwith() if &with === &[===]; # use optimized version my @seen; # should be Mu, but doesn't work in settings :-( my Mu $target; map { $target := $_; if first( { with($target,$_) }, @seen ) =:= Nil { @seen.push($target); $_; } else { Nil; } }, @.list; } my @secret; proto method squish(|) {*} multi method squish( :&as!, :&with = &[===] ) { my $last = @secret; my str $which; map { $which = &as($_).Str; if with($which,$last) { Nil; } else { $last = $which; $_; } }, @.list; } multi method squish( :&with = &[===] ) { my $last = @secret; map { if with($_,$last) { Nil; } else { $last = $_; $_; } }, @.list; } multi method gist(List:D:) { join ' ', map { $_.gist }, @(self) } 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); } method keys(List:) { return unless self.DEFINITE; (0..self.end).list; } method values(List:) { return unless self.DEFINITE; my Mu $rpa := nqp::clone(nqp::p6listitems(self)); nqp::push($rpa, $!nextiter) if $!nextiter.defined; nqp::p6list($rpa, List, self.flattens); } method pairs(List:) { return unless self.DEFINITE; self.keys.map: {; $_ => self.at_pos($_) }; } method kv(List:) { self.keys.map: { ($_, self.at_pos($_)) }; } method reduce(List: &with) { fail('can only reduce with arity 2') unless &with.arity <= 2 <= &with.count; return unless self.DEFINITE; my Mu $val; for self.keys { if $_ == 0 { $val = self.at_pos(0); next; } $val = with($val, self.at_pos($_)); } $val; } method sink() { self.gimme(*, :sink) if self.defined; 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) } my sub combinations($n, $k) { my @result; my @stack; @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 } } } } proto method combinations($) {*} multi method combinations( Int $of ) { [self[@$_]] for combinations self.elems, $of } multi method combinations( Range $of = 0 .. * ) { gather for @$of { last if $_ > self.elems; take self.combinations($_); } } 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); } } method permutations() { gather take self[@$_] for permutations self.elems; } } 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 infix:(|) { * } multi infix:() { fail "No zero-arg meaning for infix:" } multi infix:(Mu \x) {x } multi infix:(Mu \x, $n is copy, :$thunked) { $n = nqp::p6bool(nqp::istype($n, Whatever)) ?? $Inf !! $n.Int; GatherIter.new({ take ($thunked ?? x.() !! x) while $n-- > 0; }, :infinite($n == $Inf)).list } 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, *@elems) { a.unshift: @elems } proto sub push(|) {*} 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) } rakudo-2013.12/src/core/LoL.pm0000664000175000017500000000422712224263172015354 0ustar moritzmoritzclass LoL { # declared in BOOTSTRAP # class LoL is List { # has Mu $!descriptor; method new(|) { my Mu $args := nqp::p6argvmarray(); nqp::shift($args); nqp::p6list($args, self.WHAT, Mu); } method at_pos($pos is copy) { $pos = $pos.Int; self.exists_pos($pos) ?? nqp::findmethod(List, 'at_pos')(self, $pos) !! nqp::p6bindattrinvres(my $v, Scalar, '$!whence', -> { nqp::findmethod(List, 'STORE_AT_POS')(self, $pos, $v) } ) } multi method perl(LoL:D \SELF:) { self.WHAT.perl ~ '.new(' ~ self.map({.perl}).join(', ') ~ ')' ~ ('.item' if nqp::iscont(SELF)); } method REIFY(Parcel \parcel, Mu \nextiter) { my Mu $rpa := nqp::getattr(parcel, Parcel, '$!storage'); my Mu $iter := nqp::iterator($rpa); my int $i = 0; while $iter { nqp::bindpos($rpa, $i, my $v = nqp::shift($iter)); $i = $i + 1; } nqp::findmethod(List, 'REIFY')(self, parcel, nextiter) } method STORE_AT_POS(\pos, Mu $v is copy) { nqp::findmethod(List, 'STORE_AT_POS')(self, pos, $v); } } sub infix:(**@lol) { my @l; @l[0] = (@lol[0].flat,).list; my int $i = 0; my int $n = @lol.elems - 1; my Mu $v := nqp::list(); gather { while $i >= 0 { if @l[$i] { nqp::bindpos($v, $i, @l[$i].shift); if $i >= $n { take nqp::p6parcel(nqp::clone($v), nqp::null()) } else { $i = $i + 1; @l[$i] = (@lol[$i].flat,).list; } } else { $i = $i - 1 } } } }; sub infix:(**@lol) { my @l = @lol.map({ (.flat,).list.item }); gather { my $loop = 1; while $loop { my $p := @l.map({ $loop = 0 unless $_; .shift }).eager.Parcel; take $p if $loop; } } } my &zip := &infix:; sub roundrobin(**@lol) { my @l = @lol.map({ (.flat,).list.item }); gather { my $p; while $p := @l.grep(*.Bool).map(*.shift).eager.Parcel { take $p; } } } rakudo-2013.12/src/core/Macro.pm0000664000175000017500000000003612224263172015721 0ustar moritzmoritzmy class Macro is Routine { } rakudo-2013.12/src/core/Main.pm0000664000175000017500000001304612224263172015551 0ustar moritzmoritz# TODO: # * Align number parsing to STD # * Rakudo's .Numeric # * complex numbers # * Rakudo's grammar # * val() # * Strengthen val() # * Make val() available globally # * $?USAGE # * Create $?USAGE at compile time # * Make $?USAGE available globally # * Command-line parsing # * Allow both = and space before argument of double-dash args # * Comma-separated list values # * Allow exact Perl 6 forms, quoted away from shell # * Fix remaining XXXX my sub MAIN_HELPER($retval = 0) is hidden_from_backtrace { # Do we have a MAIN at all? my $m = callframe(1).my<&MAIN>; return $retval unless $m; # Temporary stand-in for magic val() routine my sub hack-val ($v) { # Convert to native type if appropriate my $val; if $v ~~ /^ 'Bool::'?'False' $/ { $val := Bool::False } elsif $v ~~ /^ 'Bool::'?'True' $/ { $val := Bool::True } elsif $v.Numeric.defined { $val := +$v } else { return $v } # Mix in original stringifications my role orig-string[$orig] { method Str () { $orig.Str } multi method gist (Mu:D:) { $orig.gist } }; return $val but orig-string[$v]; } # Convert raw command line args into positional and named args for MAIN my sub process-cmd-args (@args is copy) { my (@positional-arguments, %named-arguments); while (@args) { my $passed-value = @args.shift; if $passed-value ~~ /^ ( '--' | '-' | ':' ) ('/'?) (<-[0..9\.]> .*) $/ { my ($switch, $negate, $arg) = (~$0, ?((~$1).chars), ~$2); if $arg.index('=').defined { my ($name, $value) = $arg.split('=', 2); $value = hack-val($value); $value = $value but False if $negate; %named-arguments.push: $name => $value; } else { %named-arguments.push: $arg => !$negate; } } else { @args.unshift($passed-value) unless $passed-value eq '--'; @positional-arguments.push: @args.map: &hack-val; last; } } $PROCESS::ARGFILES = IO::ArgFiles.new(:args(@args)); return @positional-arguments, %named-arguments; } # Generate $?USAGE string (default usage info for MAIN) my sub gen-usage () { my @help-msgs; my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME; for $m.candidates -> $sub { my (@required-named, @optional-named, @positional, $docs); for $sub.signature.params -> $param { my $argument; if $param.named { my @names = $param.named_names.reverse; $argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|'); $argument ~= "=<{$param.type.^name}>" unless $param.type === Bool; if $param.optional { @optional-named.push("[$argument]"); } else { @required-named.push($argument); } } else { my $constraints = $param.constraint_list.map(*.gist).join(' '); my $simple-const = $constraints && $constraints !~~ /^_block/; $argument = $param.name ?? '<' ~ $param.name.substr(1) ~ '>' !! $simple-const ?? $constraints !! '<' ~ $param.type.^name ~ '>' ; $argument = "[$argument ...]" if $param.slurpy; $argument = "[$argument]" if $param.optional; @positional.push($argument); } } if $sub.WHY { $docs = '-- ' ~ $sub.WHY.content } my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional, $docs // ''); @help-msgs.push($msg); } my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n"); return $usage; } sub has-unexpected-named-arguments($signature, %named-arguments) { my @named-params = $signature.params.grep: *.named; return False if @named-params.grep: *.slurpy; my %accepts-argument = @named-params.map({ .named_names }) Z=> 1 xx *; for %named-arguments.keys -> $name { return True if !%accepts-argument{$name} } return False; } # Process command line arguments my ($p, $n) = process-cmd-args(@*ARGS).lol; # Generate default $?USAGE message my $?USAGE = gen-usage(); # Get a list of candidates that match according to the dispatcher my @matching_candidates = $m.cando(Capture.new(list => $p, hash => $n)); # Sort out all that would fail due to binding @matching_candidates .=grep: {!has-unexpected-named-arguments($_.signature, $n)}; # If there are still some candidates left, try to dispatch to MAIN if +@matching_candidates { return $m(|@($p), |%($n)); } # We could not find the correct MAIN to dispatch to! # Let's try to run a user defined USAGE sub my $h = callframe(1).my<&USAGE>; return $h() if $h; # We could not find a user defined USAGE sub! # Let's display the default USAGE message if ($n) { $*OUT.say($?USAGE); exit 1; } else { $*ERR.say($?USAGE); exit 2; } } rakudo-2013.12/src/core/MapIter.pm0000664000175000017500000002246312242026101016216 0ustar moritzmoritzmy class MapIter is Iterator { has $!reified; # Parcel we return after reifying has Mu $!listiter; # the list we're consuming has Mu $!flattens; # flag to flatten input list has $!block; # the block we're applying has $!first; # Is this the first iterator in the sequence? has Mu $!items; # reified items we haven't consumed yet method new($list, $block, Mu $flattens = Bool::True) { my $new := nqp::create(self); $new.BUILD(nqp::p6listiter(nqp::list(nqp::decont($list)), $new), $block, $flattens, True); $new; } method BUILD(Mu \listiter, \block, Mu \flattens, $first = False) { nqp::bindattr(listiter, ListIter, '$!list', self) if nqp::isconcrete(listiter); $!listiter := listiter; $!block = block; $!first = $first; $!flattens = flattens; self } method flattens() { $!flattens } method reify($n = 1, :$sink) { unless nqp::isconcrete($!reified) { my $argc = $!block.count; $argc = 1 if $argc < 1 || $argc ~~ Inf; my $block := nqp::decont($!block); my Mu $rpa := nqp::list(); if $!first { $!items := nqp::list(); nqp::p6setfirstflag($block) if (nqp::can($block, 'phasers') && $block.phasers('FIRST')); } my $count = $n; if nqp::istype($count, Whatever) { $!listiter.reify(*) if $!listiter && nqp::elems($!items) < $argc; $count = (nqp::elems($!items) / $argc).floor; $count = 1 if $count < 1; $count = 100000 if $count > 100000; } my int $NEXT = nqp::can($block, 'fire_phasers') && +$block.phasers('NEXT'); my int $is_sink = $sink ?? 1 !! 0; #?if parrot Q:PIR { .local int argc, count, NEXT, is_sink .local pmc handler, self, MapIter, items, args, result, block, rpa $P0 = find_lex '$argc' argc = repr_unbox_int $P0 $P0 = find_lex '$count' count = repr_unbox_int $P0 self = find_lex 'self' rpa = find_lex '$rpa' MapIter = find_lex 'MapIter' items = getattribute self, MapIter, '$!items' args = new 'QRPA' block = find_lex '$block' handler = root_new ['parrot';'ExceptionHandler'] NEXT = find_lex '$NEXT' is_sink = find_lex '$is_sink' set_addr handler, catch handler.'handle_types'(.CONTROL_LOOP_LAST, .CONTROL_LOOP_NEXT, .CONTROL_LOOP_REDO) push_eh handler iter_loop: $I0 = elements rpa unless $I0 < count goto iter_done $I0 = elements items if $I0 >= argc goto have_items $I0 = argc - $I0 $P0 = getattribute self, MapIter, '$!listiter' unless $P0 goto have_items $P0.'reify'($I0) have_items: args = 0 perl6_shiftpush args, items, argc unless args goto iter_done redo: result = block(args :flat) if is_sink goto sink_result push rpa, result goto next sink_result: $I0 = repr_defined result unless $I0 goto next $I0 = can result, 'sink' unless $I0 goto next $I0 = defined result unless $I0 goto next result.'sink'() goto next catch: .local pmc exception, type .get_results (exception) null $P0 perl6_invoke_catchhandler $P0, exception result = getattribute exception, 'payload' push rpa, result type = getattribute exception, 'type' if type == .CONTROL_LOOP_REDO goto redo if type == .CONTROL_LOOP_LAST goto last next: unless NEXT goto iter_loop block.'fire_phasers'('NEXT') goto iter_loop last: $P0 = find_lex 'Any' setattribute self, MapIter, '$!items', $P0 setattribute self, MapIter, '$!listiter', $P0 iter_done: pop_eh }; #?endif #?if !parrot my int $state = 1; my int $itmp; my Mu $items := $!items; my Mu $args := nqp::list(); my Mu $arg; # Pre-size (set to count we want, then back to zero, which leaves # the backing array at $count). nqp::setelems($rpa, $count); nqp::setelems($rpa, 0); if $argc == 1 && !$NEXT { # Fast path case: only 1 argument for each block, no NEXT phaser. nqp::while(($state && nqp::islt_i(nqp::elems($rpa), $count)), nqp::handle( nqp::stmts( nqp::if(nqp::iseq_i($state, 1), nqp::stmts( nqp::unless(nqp::elems($items), nqp::stmts( nqp::if($!listiter, $!listiter.reify(1)) )), nqp::if($items, nqp::stmts(($arg := nqp::shift($items)), $state = 2), $state = 0) )), nqp::if(nqp::iseq_i($state, 2), nqp::stmts( ($sink ?? $block($arg) !! nqp::push($rpa, $block($arg))), $state = 1 )) ), 'LAST', nqp::stmts( ($!items := Any), ($!listiter := Any), ($state = 0) ), 'REDO', $state = 2, 'NEXT', $state = 1 )); } else { nqp::while(($state && nqp::islt_i(nqp::elems($rpa), $count)), nqp::handle( nqp::stmts( nqp::if(nqp::iseq_i($state, 1), nqp::stmts( ($itmp = nqp::elems($items)), nqp::unless($itmp >= $argc, nqp::stmts( ($itmp = $argc - $itmp), nqp::if($!listiter, $!listiter.reify($itmp)) )), nqp::setelems($args, 0), nqp::p6shiftpush($args, $items, $argc), nqp::if($args, $state = 2, $state = 0) )), nqp::if(nqp::iseq_i($state, 2), nqp::stmts( ($sink ?? nqp::p6invokeflat($block, $args) !! nqp::push($rpa, nqp::p6invokeflat($block, $args))), $state = 3 )), nqp::if(nqp::iseq_i($state, 3), nqp::stmts( nqp::if($NEXT, $block.fire_phasers('NEXT')), ($state = 1) )) ), 'LAST', nqp::stmts( ($!items := Any), ($!listiter := Any), ($state = 0) ), 'REDO', $state = 2, 'NEXT', $state = 3 )); } #?endif if $!items || $!listiter { my $nextiter := nqp::create(self).BUILD($!listiter, $!block, $!flattens); nqp::bindattr($nextiter, MapIter, '$!items', $!items); nqp::push($rpa, $nextiter); } elsif nqp::can($block, 'fire_phasers') { $block.fire_phasers('LAST'); } $!reified := nqp::p6parcel($rpa, nqp::null()); # release references to objects we no longer need/own $!items := Any; $!listiter := Any; $!block := Any; } $!reified; } method REIFY(Parcel \parcel, Mu \nextiter) { nqp::splice($!items, nqp::getattr(parcel, Parcel, '$!storage'), nqp::elems($!items), 0); $!listiter := nextiter; parcel } multi method DUMP(MapIter:D: :$indent-step = 4, :%ctx?) { return DUMP(self, :$indent-step) unless %ctx; my Mu $attrs := nqp::list(); nqp::push($attrs, '$!flattens'); nqp::push($attrs, $!flattens ); nqp::push($attrs, '$!first' ); nqp::push($attrs, $!first ); nqp::push($attrs, '$!reified' ); nqp::push($attrs, $!reified ); nqp::push($attrs, '$!items' ); nqp::push($attrs, $!items ); nqp::push($attrs, '$!listiter'); nqp::push($attrs, $!listiter ); nqp::push($attrs, '$!block' ); nqp::push($attrs, $!block ); self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx); } } rakudo-2013.12/src/core/Match.pm0000664000175000017500000000431012224263172015713 0ustar moritzmoritzmy class Match is Capture is Cool { has $.orig; has int $.from; has int $.to; has $.CURSOR; has $.ast; multi method Str(Match:D:) { $!to > $!from ?? $!orig.substr($!from, $!to-$!from) !! '' } multi method Numeric(Match:D:) { self.Str.Numeric } multi method Bool(Match:D:) { $!to >= $!from } multi method ACCEPTS(Match:D: Any $) { self } method prematch(Match:D:) { $!orig.substr(0, $!from); } method postmatch(Match:D:) { $!orig.substr($!to) } method caps(Match:D:) { my @caps; for self.pairs -> $p { if $p.value ~~ Parcel { @caps.push: $p.key => $_ for $p.value.list } else { @caps.push: $p; } } @caps.sort: -> $p { $p.value.from } } method chunks(Match:D:) { my $prev = $!from; gather { for self.caps { if .value.from > $prev { take '~' => $!orig.substr($prev, .value.from - $prev) } take $_; $prev = .value.to; } take '~' => $!orig.substr($prev, $!to - $prev) if $prev < $!to; } } multi method perl(Match:D:) { my %attrs; for { %attrs{$_} = self."$_"().perl; } 'Match.new(' ~ %attrs.fmt('%s => %s', ', ') ~ ')' } multi method gist (Match:D: $d = 0) { return "#" unless self; my $s = ' ' x ($d + 1); my $r = ("=> " if $d) ~ "\x[FF62]{self}\x[FF63]\n"; for @.caps { $r ~= $s ~ (.key // '?') ~ ' ' ~ .value.gist($d + 1) } $r; } method make(Match:D: Mu $ast) { $!ast = $ast; nqp::bindattr( nqp::decont(self.CURSOR), Cursor, '$!ast', $ast ); } } sub make(Mu $ast) { nqp::bindattr( nqp::decont(nqp::getlexcaller('$/')), Match, '$!ast', $ast ); nqp::bindattr( nqp::decont(nqp::getlexcaller('$/').CURSOR), Cursor, '$!ast', $ast ); } rakudo-2013.12/src/core/metaops.pm0000664000175000017500000001676012224263172016343 0ustar moritzmoritz sub METAOP_ASSIGN(\op) { -> Mu \a, Mu \b { a = op.( a // op.(), b) } } sub METAOP_TEST_ASSIGN:(\lhs, $rhs) is rw { lhs // (lhs = $rhs()) } sub METAOP_TEST_ASSIGN:<||>(\lhs, $rhs) is rw { lhs || (lhs = $rhs()) } sub METAOP_TEST_ASSIGN:<&&>(\lhs, $rhs) is rw { lhs && (lhs = $rhs()) } sub METAOP_NEGATE(\op) { -> Mu \a, Mu \b { !op.(a ,b) } } sub METAOP_REVERSE(\op) { -> Mu \a, Mu \b { op.(b, a) } } sub METAOP_CROSS(\op, &reduce) { -> **@lol { my $rop = @lol.elems == 2 ?? op !! &reduce(op); my @l; my @v; @l[0] = (@lol[0].flat,).list; my int $i = 0; my int $n = @lol.elems - 1; gather { while $i >= 0 { if @l[$i].gimme(1) { @v[$i] = @l[$i].shift; if $i >= $n { my @x = @v; take $rop(|@x); } else { $i = $i + 1; @l[$i] = (@lol[$i].flat,).list; } } else { $i = $i - 1; } } } } } sub METAOP_ZIP(\op, &reduce) { -> **@lol { my $rop = @lol.elems == 2 ?? op !! &reduce(op); my @l = @lol.map({ (.flat,).list.item }); gather { my $loop = 1; while $loop { my @z = @l.map({ $loop = 0 unless $_; .shift }); take-rw $rop(|@z) if $loop; } } } } sub METAOP_REDUCE_LEFT(\op, :$triangle) { my $x := $triangle ?? (sub (*@values) { return () unless @values.gimme(1); GATHER({ my $result := @values.shift; take $result; take ($result := op.($result, @values.shift)) while @values.gimme(1); }, :infinite(@values.infinite)) }) !! (sub (*@values) { return op.() unless @values.gimme(1); my $result := @values.shift; return op.($result) unless @values.gimme(1); my int $i; while my int $c = @values.gimme(1000) { $i = 0; $result := op.($result, @values.shift) while ($i = $i + 1) <= $c; } $result; }) } sub METAOP_REDUCE_RIGHT(\op, :$triangle) { my $x := sub (*@values) { my $list = @values.reverse; if $triangle { return () unless $list.gimme(1); gather { my $result := $list.shift; take $result; take ($result := op.($list.shift, $result)) while $list.gimme(1); } } else { return op.() unless $list.gimme(1); my $result := $list.shift; return op.($result) unless $list.gimme(1); my int $i; while my int $c = $list.gimme(1000) { $i = 0; $result := op.($list.shift, $result) while ($i = $i + 1) <= $c; } $result; } } } sub METAOP_REDUCE_LIST(\op, :$triangle) { $triangle ?? sub (*@values) { return () unless @values.gimme(1); GATHER({ my @list; while @values { @list.push(@values.shift); take op.(|@list); } }, :infinite(@values.infinite)) } !! sub (*@values) { op.(|@values) } } sub METAOP_REDUCE_CHAIN(\op, :$triangle) { $triangle ?? sub (*@values) { my $state = True; my Mu $current = @values.shift; gather { take $state; while $state && @values.gimme(1) { $state = op.($current, @values[0]); take $state; $current = @values.shift; } take False for @values; } } !! sub (*@values) { my $state = True; my Mu $current = @values.shift; while @values.gimme(1) { $state = op.($current, @values[0]); $current = @values.shift; return $state unless $state; } $state; } } sub METAOP_REDUCE_XOR(\op, :$triangle) { X::NYI.new(feature => 'xor reduce').throw; } sub METAOP_HYPER(\op, *%opt) { -> Mu \a, Mu \b { hyper(op, a, b, |%opt) } } sub METAOP_HYPER_POSTFIX(\obj, \op) { hyper(op, obj) } sub METAOP_HYPER_PREFIX(\op, \obj) { hyper(op, obj) } sub METAOP_HYPER_CALL(\list, |args) { hyper(-> $c { $c(|args) }, list) } proto sub hyper(|) { * } multi sub hyper(\op, \a, \b, :$dwim-left, :$dwim-right) { my @alist := a.DEFINITE ?? a.flat !! [a]; my @blist := b.DEFINITE ?? b.flat !! [b]; my $elems = 0; if $dwim-left && $dwim-right { $elems = max(@alist.elems, @blist.elems) } elsif $dwim-left { $elems = @blist.elems } elsif $dwim-right { $elems = @alist.elems } else { X::HyperOp::NonDWIM.new( operator => op, left-elems => @alist.elems, right-elems => @blist.elems, ).throw if @alist.elems != @blist.elems } @alist := (@alist xx *).munch($elems) if @alist.elems < $elems; @blist := (@blist xx *).munch($elems) if @blist.elems < $elems; (@alist Z @blist).map( -> \x, \y { Iterable.ACCEPTS(x) ?? x.new(hyper(op, x, y, :$dwim-left, :$dwim-right)).item !! (Iterable.ACCEPTS(y) ?? y.new(hyper(op, x, y, :$dwim-left, :$dwim-right)).item !! op.(x, y)) } ).eager } multi sub hyper(\op, \obj) { my Mu $rpa := nqp::list(); my Mu $items := nqp::p6listitems(obj.flat.eager); my Mu $o; # We process the elements in two passes, end to start, to # prevent users from relying on a sequential ordering of hyper. # Also, starting at the end pre-allocates $rpa for us. my int $i = nqp::elems($items) - 1; nqp::while( nqp::isge_i($i, 0), nqp::stmts( ($o := nqp::atpos($items, $i)), nqp::bindpos($rpa, $i, nqp::if(nqp::istype($o, Iterable), $o.new(hyper(op, $o)).item, op.($o))), $i = nqp::sub_i($i, 2) ) ); $i = nqp::elems($items) - 2; nqp::while( nqp::isge_i($i, 0), nqp::stmts( ($o := nqp::atpos($items, $i)), nqp::bindpos($rpa, $i, nqp::if(nqp::istype($o, Iterable), $o.new(hyper(op, $o)).item, op.($o))), $i = nqp::sub_i($i, 2) ) ); nqp::p6parcel($rpa, Nil); } multi sub hyper(\op, Associative \h) { my @keys = h.keys; hash @keys Z hyper(op, h{@keys}) } multi sub hyper(\op, Associative \a, Associative \b, :$dwim-left, :$dwim-right) { my %k; for a.keys { %k{$_} = 1 if !$dwim-left || b.exists_key($_) } for b.keys { %k{$_} = 1 if !$dwim-right } my @keys = %k.keys; hash @keys Z hyper(op, a{@keys}, b{@keys}, :$dwim-left, :$dwim-right) } multi sub hyper(\op, Associative \a, \b, :$dwim-left, :$dwim-right) { my @keys = a.keys; hash @keys Z hyper(op, a{@keys}, b, :$dwim-left, :$dwim-right); } multi sub hyper(\op, \a, Associative \b, :$dwim-left, :$dwim-right) { my @keys = b.keys; hash @keys Z hyper(op, a, b{@keys}, :$dwim-left, :$dwim-right); } rakudo-2013.12/src/core/Method.pm0000664000175000017500000000020212224263172016073 0ustar moritzmoritzmy class Method { # declared in BOOTSTRAP # class Method is Routine { ... } multi method gist(Method:D:) { self.name } } rakudo-2013.12/src/core/MixHash.pm0000664000175000017500000000235612255230273016230 0ustar moritzmoritzmy class MixHash does Mixy { method at_key($k) { Proxy.new( FETCH => { my $key := $k.WHICH; %!elems.exists_key($key) ?? %!elems{$key}.value !! 0; }, STORE => -> $, $value { if $value != 0 { (%!elems{$k.WHICH} //= ($k => 0)).value = $value; } else { self.delete_key($k); } $value; } ); } method delete($k) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($k); } method delete_key($k) { my $key := $k.WHICH; if %!elems.exists_key($key) { my $value = %!elems{$key}.value; %!elems.delete_key($key); $value; } else { 0; } } method Mix (:$view) { if $view { my $mix := nqp::create(Mix); $mix.BUILD( :elems(%!elems) ); $mix; } else { Mix.new-fp(%!elems.values); } } method MixHash { self } method Bag { Bag.new-fp(%!elems.values) } method BagHash { BagHash.new-fp(%!elems.values) } } rakudo-2013.12/src/core/Mix.pm0000664000175000017500000000207112255230273015416 0ustar moritzmoritzmy class Mix does Mixy { has Real $!total; method total { $!total //= [+] %!elems.values.map( { .value } ); } method at_key($k --> Real) { my $key := $k.WHICH; %!elems.exists_key($key) ?? %!elems{$key}.value !! 0; } method delete ($a --> Real) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($a); } method delete_key($a --> Real) is hidden_from_backtrace { X::Immutable.new( method => 'delete_key', typename => self.^name ).throw; } method grab($count = 1 --> Real) is hidden_from_backtrace { X::Immutable.new( method => 'grab', typename => self.^name ).throw; } method grabpairs($count = 1 --> Real) is hidden_from_backtrace { X::Immutable.new( method => 'grabpairs', typename => self.^name ).throw; } method Mix { self } method MixHash { MixHash.new-fp(%!elems.values) } method Bag { Bag.new-fp(%!elems.values) } method BagHash { BagHash.new-fp(%!elems.values) } } rakudo-2013.12/src/core/Mixy.pm0000664000175000017500000000303512255230273015610 0ustar moritzmoritzmy role Mixy does Baggy { method default(--> Real) { 0 } method total(--> Real) { [+] self.values } method new-fp(*@pairs --> Mixy) { my %e; for @pairs { when Pair { (%e{$_.key.WHICH} //= ($_.key => 0)).value += $_.value; } default { (%e{$_.WHICH} //= ($_ => 0)).value++; } } for %e -> $p { %e.delete_key($p.key) if $p.value.value == 0; } self.bless(:elems(%e)); } multi method gist(Mixy:D $ : --> Str) { my $name := self.^name; ( $name eq 'Mix' ?? 'mix' !! "$name.new" ) ~ '(' # ~ %!elems.values.map( { ~ self.pairs.map( { .value == 1 ?? .key.gist !! "{.key.gist}({.value})" } ).join(', ') ~ ')'; } method grab ($count = 1) { fail ".grab is not supported on a {.self.^name}"; } method pick ($count = 1) { fail ".pick is not supported on a {.self.^name}"; } method roll ($count = 1) { my $total = [+] self.values.grep: * > 0; my $rolls = $count ~~ Num ?? $total min $count !! $count; # my @pairs := %!elems.values; my @pairs := self.pairs; map { my $rand = $total.rand; my $seen = 0; my $roll; for @pairs -> $pair { next if ( $seen += $pair.value ) <= $rand; $roll = $pair.key; last; } $roll; }, 1 .. $rolls; } } rakudo-2013.12/src/core/Mu.pm0000664000175000017500000007223612253363744015264 0ustar moritzmoritzmy class X::Constructor::Positional { ... } my class X::Method::NotFound { ... } my class X::Method::InvalidQualifier { ... } my class Mu { # declared in BOOTSTRAP proto method ACCEPTS(|) { * } multi method ACCEPTS(Mu:U: Mu \topic) { nqp::p6bool(nqp::istype(topic, self)) } method WHERE() { nqp::p6box_i(nqp::where(self)) } proto method WHICH(|) {*} multi method WHICH(Mu:U:) { nqp::box_s(nqp::unbox_s(self.HOW.name(self)), ObjAt); } multi method WHICH(Mu:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.HOW.name(self)), '|'), nqp::where(self) ), ObjAt ) } method take { take self; } method WHY() { self.HOW.docs // Any } proto method Bool(|) {*} multi method Bool() { self.defined } method so() { self.Bool } method not() { self ?? False !! True } method defined() { nqp::p6bool(nqp::isconcrete(self)) } proto method new(|) { * } multi method new(*%attrinit) { self.bless(|%attrinit); } multi method new($, *@) { X::Constructor::Positional.new(:type( self )).throw(); } method CREATE() { nqp::create(self) } method bless(*@autovivs, *%attrinit) { if @autovivs && nqp::istype(@autovivs[0], Whatever) { DEPRECATED( "a call to bless without initial * parameter" ); @autovivs.shift; } nqp::create(self).BUILDALL(@autovivs, %attrinit); } method BUILDALL(@autovivs, %attrinit) { # Get the build plan. Note that we do this "low level" to # avoid the NQP type getting mapped to a Rakudo one, which # would get expensive. Need to do it a bit differently on # Parrot; it's not so 6model-y as other backends. my $build_plan := nqp::findmethod(self.HOW, 'BUILDALLPLAN')(self.HOW, self); my int $count = nqp::elems($build_plan); my int $i = 0; #?if parrot while nqp::islt_i($i, $count) { my $task := nqp::atpos($build_plan, $i); my int $code = nqp::atpos_i($task, 0); $i = nqp::add_i($i, 1); if nqp::iseq_i($code, 0) { # Custom BUILD call. nqp::atpos($task, 1)(self, |%attrinit); } elsif nqp::iseq_i($code, 1) { # See if we have a value to initialize this attr # with. my $key_name := nqp::p6box_s(nqp::atpos_s($task, 2)); if %attrinit.exists_key($key_name) { # XXX Should not really need the decontainerize, but seems # that slurpy hashes sometimes lead to double containers # somehow... nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } } elsif nqp::iseq_i($code, 2) { my $key_name := nqp::p6box_s(nqp::atpos_s($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3), nqp::list()) } } elsif nqp::iseq_i($code, 3) { my $key_name := nqp::p6box_s(nqp::atpos_s($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3), nqp::hash()) } } elsif nqp::iseq_i($code, 4) { unless nqp::attrinited(self, nqp::atpos($task, 1), nqp::atpos_s($task, 2)) { my $attr := nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 2)); $attr = nqp::atpos($task, 3)(self, $attr); } } elsif nqp::iseq_i($code, 5) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_i(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 6) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_n(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 7) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_s(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } else { die "Invalid BUILDALLPLAN"; } } #?endif #?if !parrot while nqp::islt_i($i, $count) { my $task := nqp::atpos($build_plan, $i); my int $code = nqp::atpos($task, 0); $i = nqp::add_i($i, 1); if nqp::iseq_i($code, 0) { # Custom BUILD call. nqp::atpos($task, 1)(self, |%attrinit); } elsif nqp::iseq_i($code, 1) { # See if we have a value to initialize this attr # with. my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { # XXX Should not really need the decontainerize, but seems # that slurpy hashes sometimes lead to double containers # somehow... nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } } elsif nqp::iseq_i($code, 2) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::list()) } } elsif nqp::iseq_i($code, 3) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::hash()) } } elsif nqp::iseq_i($code, 4) { unless nqp::attrinited(self, nqp::atpos($task, 1), nqp::atpos($task, 2)) { my $attr := nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 2)); $attr = nqp::atpos($task, 3)(self, $attr); } } elsif nqp::iseq_i($code, 5) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_i(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 6) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_n(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 7) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_s(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } else { die "Invalid BUILDALLPLAN"; } } #?endif self } method BUILD_LEAST_DERIVED(%attrinit) { # Get the build plan for just this class. Need to do it a bit # differently on Parrot; it's not so 6model-y as other backends. my $build_plan := nqp::findmethod(self.HOW, 'BUILDPLAN')(self.HOW, self); my int $count = nqp::elems($build_plan); my int $i = 0; #?if parrot while nqp::islt_i($i, $count) { my $task := nqp::atpos($build_plan, $i); my int $code = nqp::atpos_i($task, 0); $i = nqp::add_i($i, 1); if nqp::iseq_i($code, 0) { # Custom BUILD call. nqp::atpos($task, 1)(self, |%attrinit); } elsif nqp::iseq_i($code, 1) { # See if we have a value to initialize this attr # with. my $key_name := nqp::p6box_s(nqp::atpos_s($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3)) = nqp::decont(%attrinit{$key_name}); } } elsif nqp::iseq_i($code, 2) { my $key_name := nqp::p6box_s(nqp::atpos_s($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3), nqp::list()) } } elsif nqp::iseq_i($code, 3) { my $key_name := nqp::p6box_s(nqp::atpos_s($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 3), nqp::hash()) } } elsif nqp::iseq_i($code, 4) { unless nqp::attrinited(self, nqp::atpos($task, 1), nqp::atpos_s($task, 2)) { my $attr := nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos_s($task, 2)); $attr = nqp::atpos($task, 3)(self, $attr); } } elsif nqp::iseq_i($code, 5) || nqp::iseq_i($code, 6) || nqp::iseq_i($code, 7) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 5) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_i(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 6) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_n(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 7) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_s(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } else { die "Invalid BUILDALLPLAN"; } } #?endif #?if !parrot while nqp::islt_i($i, $count) { my $task := nqp::atpos($build_plan, $i); my int $code = nqp::atpos($task, 0); $i = nqp::add_i($i, 1); if nqp::iseq_i($code, 0) { # Custom BUILD call. nqp::atpos($task, 1)(self, |%attrinit); } elsif nqp::iseq_i($code, 1) { # See if we have a value to initialize this attr # with. my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } } elsif nqp::iseq_i($code, 2) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::list()) } } elsif nqp::iseq_i($code, 3) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3)) = nqp::decont(%attrinit{$key_name}); } else { nqp::bindattr(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::hash()) } } elsif nqp::iseq_i($code, 4) { unless nqp::attrinited(self, nqp::atpos($task, 1), nqp::atpos($task, 2)) { my $attr := nqp::getattr(self, nqp::atpos($task, 1), nqp::atpos($task, 2)); $attr = nqp::atpos($task, 3)(self, $attr); } } elsif nqp::iseq_i($code, 5) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_i(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 6) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_n(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } elsif nqp::iseq_i($code, 7) { my $key_name := nqp::p6box_s(nqp::atpos($task, 2)); if %attrinit.exists_key($key_name) { nqp::bindattr_s(self, nqp::atpos($task, 1), nqp::atpos($task, 3), nqp::decont(%attrinit{$key_name})); } } else { die "Invalid BUILDALLPLAN"; } } #?endif self } proto method Numeric(|) { * } multi method Numeric(Mu:U \v:) { warn "use of uninitialized value of type {self.HOW.name(self)} in numeric context"; 0 } proto method Real(|) { * } multi method Real(Mu:U \v:) { warn "use of uninitialized value of type {self.HOW.name(self)} in numeric context"; 0 } proto method Str(|) { * } multi method Str(Mu:U \v:) { warn "use of uninitialized value of type {self.HOW.name(self)} in string context"; '' } multi method Str(Mu:D:) { self.HOW.name(self) ~ '<' ~ nqp::tostr_I(self.WHERE) ~ '>' } proto method Stringy(|) { * } multi method Stringy() { self.Str } method item(Mu \item:) is rw { item } proto method say(|) { * } multi method say() { say(self) } method print() { print(self) } proto method gist(|) { * } multi method gist(Mu:U:) { '(' ~ self.HOW.name(self) ~ ')' } multi method gist(Mu:D:) { self.perl } proto method perl(|) { * } multi method perl(Mu:U:) { self.HOW.name(self) } multi method perl(Mu:D:) { my @attrs; for self.^attributes().grep: { .has_accessor } -> $attr { my $name := $attr.Str.substr(2); @attrs.push: $name ~ ' => ' ~ self."$name"().perl } self.HOW.name(self) ~ '.new(' ~ @attrs.join(', ') ~ ')'; } proto method DUMP(|) { * } multi method DUMP(Mu:U:) { self.perl } multi method DUMP(Mu:D: :$indent-step = 4, :%ctx?) { return DUMP(self, :$indent-step) unless %ctx; my Mu $attrs := nqp::list(); for self.HOW.attributes(self) -> $attr { my str $name = $attr.name; my str $acc_name = nqp::substr($name, 2, nqp::chars($name) - 2); my str $build_name = $attr.has_accessor ?? $acc_name !! $name; my Mu $value; if $attr.has_accessor { $value := self."$acc_name"(); } elsif nqp::can($attr, 'get_value') { $value := $attr.get_value(self); } elsif nqp::can($attr, 'package') { my Mu $decont := nqp::decont(self); my Mu $package := $attr.package; $value := do given nqp::p6box_i(nqp::objprimspec($attr.type)) { when 0 { nqp::getattr( $decont, $package, $name) } when 1 { nqp::p6box_i(nqp::getattr_i($decont, $package, $name)) } when 2 { nqp::p6box_n(nqp::getattr_n($decont, $package, $name)) } when 3 { nqp::p6box_s(nqp::getattr_s($decont, $package, $name)) } }; } else { next; } nqp::push($attrs, $build_name); nqp::push($attrs, $value); } self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx); } method DUMP-PIECES(@pieces: $before, $after = ')', :$indent = @pieces > 1, :$indent-step) { $indent ?? $before ~ "\n" ~ @pieces.join(",\n").indent($indent-step) ~ "\n" ~ $after !! $before ~ @pieces.join(', ') ~ $after; } method DUMP-OBJECT-ATTRS(|args (*@args, :$indent-step, :%ctx, :$flags?)) { my Mu $attrs := nqp::clone(nqp::captureposarg(nqp::usecapture(), 1)); my str $where = nqp::base_I(nqp::where(self), 16); my str $before = ($flags if defined $flags) ~ self.HOW.name(self) ~ '<' ~ %ctx{$where} ~ '>('; my @pieces; while $attrs { my str $name = nqp::shift($attrs); my Mu $value := nqp::shift($attrs); @pieces.push: ':' ~ $name ~ '(' ~ DUMP($value, :$indent-step, :%ctx) ~ ')'; } @pieces.DUMP-PIECES($before, :$indent-step); } proto method isa(|) { * } multi method isa(Mu \SELF: Mu $type) { nqp::p6bool(SELF.HOW.isa(SELF, $type.WHAT)) } multi method isa(Mu \SELF: Str:D $name) { my @mro = SELF.HOW.mro(SELF); my int $mro_count = +@mro; my int $i = 0; while $i < $mro_count { my $obj = @mro[$i]; if $obj.HOW.name($obj) eq $name { return Bool::True; } $i = $i + 1; } Bool::False } method does(Mu \SELF: Mu $type) { nqp::p6bool(nqp::istype(SELF, $type.WHAT)) } method can(Mu \SELF: $name) { SELF.HOW.can(SELF, $name) } method clone(*%twiddles) { my $cloned := nqp::clone(nqp::decont(self)); for self.^attributes() -> $attr { my $name := $attr.name; my $package := $attr.package; unless nqp::objprimspec($attr.type) { my $attr_val := nqp::getattr($cloned, $package, $name); nqp::bindattr($cloned, $package, $name, nqp::clone($attr_val.VAR)) if nqp::iscont($attr_val); } my $acc_name := $name.substr(2); if $attr.has-accessor && %twiddles.exists_key($acc_name) { nqp::getattr($cloned, $package, $name) = %twiddles{$acc_name}; } } $cloned } method Capture() { my %attrs; for self.^attributes -> $attr { if $attr.has-accessor { my $name = $attr.name.substr(2); unless %attrs.exists_key($name) { %attrs{$name} = self."$name"(); } } } %attrs.Capture } # XXX TODO: Handle positional case. method dispatch:(Mu \SELF: $var, |c) is rw is hidden_from_backtrace { $var(SELF, |c) } method dispatch:<::>(Mu \SELF: $name, Mu $type, |c) is rw { unless nqp::istype(SELF, $type) { X::Method::InvalidQualifier.new( method => $name, invocant => SELF, qualifier-type => $type, ).throw; } self.HOW.find_method_qualified(self, $type, $name)(SELF, |c) } method dispatch:(Mu \SELF: $name, Mu $type, |c) is rw is hidden_from_backtrace { my $meth := $type.HOW.find_private_method($type, $name); $meth ?? $meth(SELF, |c) !! X::Method::NotFound.new( method => '!' ~ $name, typename => $type.HOW.name($type), :private, ).throw; } method dispatch:<.^>(Mu \SELF: $name, |c) is rw is hidden_from_backtrace { self.HOW."$name"(SELF, |c) } method dispatch:<.=>(\mutate: $name, |c) is rw { $/ := nqp::getlexcaller('$/'); mutate = mutate."$name"(|c) } method dispatch:<.?>(Mu \SELF: $name, |c) is rw is hidden_from_backtrace { nqp::can(SELF, $name) ?? SELF."$name"(|c) !! Nil } method dispatch:<.+>(Mu \SELF: $name, |c) { my @result := SELF.dispatch:<.*>($name, |c); if @result.elems == 0 { X::Method::NotFound.new( method => $name, typename => SELF.HOW.name(SELF), ).throw; } @result } method dispatch:<.*>(Mu \SELF: $name, |c) { my @mro = SELF.HOW.mro(SELF); my int $mro_count = +@mro; my @results; my int $i = 0; while $i < $mro_count { my $obj = @mro[$i]; my $meth = ($obj.HOW.method_table($obj)){$name}; if !$meth && $i == 0 { $meth = ($obj.HOW.submethod_table($obj)){$name}; } if $meth { @results.push($meth(SELF, |c)); } $i = $i + 1; } &infix:<,>(|@results) } method dispatch:(Mu \SELF: $name, |c) { hyper( -> \obj { obj."$name"(|c) }, SELF ) } method WALK(:$name!, :$canonical, :$ascendant, :$descendant, :$preorder, :$breadth, :$super, :$omit, :$include) { # First, build list of classes in the order we'll need them. my @classes; if $super { @classes = self.^parents(:local); } elsif $breadth { my @search_list = self.WHAT; while @search_list { push @classes, @search_list; my @new_search_list; for @search_list -> $current { for $current.^parents(:local) -> $next { unless @new_search_list.grep({ $^c.WHAT =:= $next.WHAT }) { push @new_search_list, $next; } } } @search_list = @new_search_list; } } elsif $ascendant | $preorder { sub build_ascendent(Mu $class) { unless @classes.grep({ $^c.WHAT =:= $class.WHAT }) { push @classes, $class; for $class.^parents(:local) { build_ascendent($^parent); } } } build_ascendent(self.WHAT); } elsif $descendant { sub build_descendent(Mu $class) { unless @classes.grep({ $^c.WHAT =:= $class.WHAT }) { for $class.^parents(:local) { build_descendent($^parent); } push @classes, $class; } } build_descendent(self.WHAT); } else { # Canonical, the default (just whatever the meta-class says) with us # on the start. @classes = self.^mro(); } # Now we have classes, build method list. my @methods; for @classes -> $class { if (!defined($include) || $include.ACCEPTS($class)) && (!defined($omit) || !$omit.ACCEPTS($class)) { try { for $class.^methods(:local) -> $method { my $check_name = $method.?name; if $check_name.defined && $check_name eq $name { @methods.push($method); } } 0; } } } return @methods; } } proto sub defined(Mu) is pure { * } multi sub defined(Mu \x) { x.defined } proto sub infix:<~~>(|) { * } multi sub infix:<~~>(Mu \topic, Mu \matcher) { matcher.ACCEPTS(topic).Bool; } proto sub infix:<=:=>(Mu $a?, Mu $b?) { * } multi sub infix:<=:=>($a?) { Bool::True } multi sub infix:<=:=>(Mu \a, Mu \b) { nqp::p6bool(nqp::eqaddr(a, b)); } proto sub infix:(Any $?, Any $?) { * } multi sub infix:($a?) { Bool::True } multi sub infix:(Any $a, Any $b) { $a.WHICH eq $b.WHICH } multi sub infix:(@a, @b) { unless @a.WHAT === @b.WHAT && @a.elems == @b.elems { return Bool::False } for ^@a -> $i { unless @a[$i] eqv @b[$i] { return Bool::False; } } Bool::True } sub DUMP(|args (*@args, :$indent-step = 4, :%ctx?)) { my Mu $capture := nqp::usecapture(); my Mu $topic := nqp::captureposarg($capture, 0); return "\x25b6" ~ DUMP(nqp::decont($topic), :$indent-step, :%ctx) if nqp::iscont($topic); return '(null)' if nqp::isnull($topic); # On Parrot, not everything is a 6model object, so use the typeof op to # get a real type name. On other platforms, .HOW.name(...) can be relied # on to work. #?if parrot my str $type = pir::typeof__SP($topic); #?endif #?if !parrot my str $type = $topic.HOW.name($topic); #?endif my str $where = nqp::base_I(nqp::where($topic), 16); if %ctx{$where} -> $obj_num { nqp::istype($topic, Bool) ?? $topic.DUMP(:$indent-step, :%ctx) !! nqp::isconcrete($topic) ?? '=' ~ $type ~ '<' ~ $obj_num ~ '>' !! nqp::can($topic, 'DUMP') ?? $topic.DUMP(:$indent-step, :%ctx) !! $type; } else { my int $obj_num = %ctx.elems + 1; %ctx{$where} = $obj_num; if nqp::islist($topic) { #?if parrot $type = 'RPA' if $type eq 'ResizablePMCArray'; #?endif my str $id = $type ~ '<' ~ $obj_num ~ '>'; my @pieces; $topic := nqp::clone($topic); while $topic { my Mu $x := nqp::shift($topic); @pieces.push: DUMP($x, :$indent-step, :%ctx); } @pieces.DUMP-PIECES($id ~ '(', :$indent-step); } elsif nqp::ishash($topic) { my str $id = $type ~ '<' ~ $obj_num ~ '>'; my @pieces; { for $topic { @pieces.push: $_.key ~ ' => ' ~ DUMP($_.value, :$indent-step, :%ctx); } CATCH { default { @pieces.push: '...' } } } @pieces.DUMP-PIECES($id ~ '(', :$indent-step); } elsif nqp::can($topic, 'DUMP') { $topic.DUMP(:$indent-step, :%ctx); } else { given nqp::p6box_i(nqp::captureposprimspec($capture, 0)) { when 0 { $type ~ '<' ~ $obj_num ~ '>(...)' } when 1 { nqp::captureposarg_i($capture, 0).DUMP(:$indent-step, :%ctx) } when 2 { nqp::captureposarg_n($capture, 0).DUMP(:$indent-step, :%ctx) } when 3 { nqp::captureposarg_s($capture, 0).DUMP(:$indent-step, :%ctx) } } } } } Metamodel::ClassHOW.exclude_parent(Mu); rakudo-2013.12/src/core/natives.pm0000664000175000017500000000234312224263172016334 0ustar moritzmoritzmy native int is repr('P6int') is Int { } my native int1 is repr('P6int') is Int is nativesize(1) { } my native int2 is repr('P6int') is Int is nativesize(2) { } my native int4 is repr('P6int') is Int is nativesize(4) { } my native int8 is repr('P6int') is Int is nativesize(8) { } my native int16 is repr('P6int') is Int is nativesize(16) { } my native int32 is repr('P6int') is Int is nativesize(32) { } my native int64 is repr('P6int') is Int is nativesize(64) { } my native uint is repr('P6int') is Int is unsigned { } my native uint1 is repr('P6int') is Int is nativesize(1) is unsigned { } my native uint2 is repr('P6int') is Int is nativesize(2) is unsigned { } my native uint4 is repr('P6int') is Int is nativesize(4) is unsigned { } my native uint8 is repr('P6int') is Int is nativesize(8) is unsigned { } my native uint16 is repr('P6int') is Int is nativesize(16) is unsigned { } my native uint32 is repr('P6int') is Int is nativesize(32) is unsigned { } my native uint64 is repr('P6int') is Int is nativesize(64) is unsigned { } my native num is repr('P6num') is Num { } my native num32 is repr('P6num') is Num is nativesize(32) { } my native num64 is repr('P6num') is Num is nativesize(64) { } my native str is repr('P6str') is Str { } rakudo-2013.12/src/core/Nil.pm0000664000175000017500000000034112224263172015401 0ustar moritzmoritzmy class Nil is Cool { # declared in BOOTSTRAP # class Nil is Iterator { method new() { Nil } method iterator() { self } method reify($n?) { () } method gist() { 'Nil' } multi method Str() { '' } } rakudo-2013.12/src/core/Numeric.pm0000664000175000017500000002164312224263172016271 0ustar moritzmoritz# for our tantrums my class X::Numeric::DivideByZero { ... } my role Numeric { multi method Numeric(Numeric:D:) { self } multi method ACCEPTS(Numeric:D: $a) { self.isNaN ?? $a.isNaN !! $a == self; } proto method log(|) {*} multi method log(Numeric:D: Cool $base) { self.log / $base.Numeric.log } multi method log(Numeric:D: Numeric $base) { self.log / $base.log } method log10() { self.log / 10e0.log } proto method exp(|) {*} multi method exp(Numeric:D: $base) { $base ** self; } method roots(Cool $n) { self.Complex.roots($n.Int) } multi method Bool(Numeric:D:) { self != 0 } multi method gist(Numeric:D:) { self.Str } multi method DUMP(Numeric:D:) { self.perl } method succ() { self + 1 } method pred() { self - 1 } } multi sub infix:(Numeric:D $a, Numeric:D $b) { $a.WHAT === $b.WHAT && ($a cmp $b) == 0 } ## arithmetic operators proto prefix:<+>($?) is pure { * } multi prefix:<+>(\a) { a.Numeric } proto prefix:<->($?) is pure { * } multi prefix:<->(\a) { -a.Numeric } proto sub abs($) is pure { * } multi sub abs(\a) { abs a.Numeric } proto sub sign($) is pure {*} multi sub sign(Numeric \x) { x.sign } multi sub sign(Cool \x) { x.Numeric.sign } proto sub log($, $?) is pure {*} multi sub log(Numeric $x) { $x.log } multi sub log(Numeric $x, Numeric $base) { $x.log($base) } multi sub log(Cool $x) { $x.Numeric.log } multi sub log(Cool $x, Cool $base) { $x.Numeric.log($base.Numeric) } proto sub log10($, $?) is pure {*} multi sub log10(Numeric $x) { $x.log(10e0) } multi sub log10(Cool $x) { $x.Numeric.log(10e0) } proto sub exp($, $?) is pure {*} multi sub exp(Numeric $x) { $x.exp } multi sub exp(Numeric $x, Numeric $base) { $x.exp($base) } proto sub sin($) is pure {*} multi sub sin(Numeric \x) { x.sin } multi sub sin(Cool \x) { x.Numeric.sin } proto sub asin($) is pure {*} multi sub asin(Numeric \x) { x.asin } multi sub asin(Cool \x) { x.Numeric.asin } proto sub cos($) is pure {*} multi sub cos(Numeric \x) { x.cos } multi sub cos(Cool \x) { x.Numeric.cos } proto sub acos($) is pure {*} multi sub acos(Numeric \x) { x.acos } multi sub acos(Cool \x) { x.Numeric.acos } proto sub tan($) is pure {*} multi sub tan(Numeric \x) { x.tan } multi sub tan(Cool \x) { x.Numeric.tan } proto sub atan($) is pure {*} multi sub atan(Numeric \x) { x.atan } multi sub atan(Cool \x) { x.Numeric.atan } proto sub sec($) is pure {*} multi sub sec(Numeric \x) { x.sec } multi sub sec(Cool \x) { x.Numeric.sec } proto sub asec($) is pure {*} multi sub asec(Numeric \x) { x.asec } multi sub asec(Cool \x) { x.Numeric.asec } proto sub cosec($) is pure {*} multi sub cosec(Numeric \x) { x.cosec } multi sub cosec(Cool \x) { x.Numeric.cosec } proto sub acosec(|) is pure {*} multi sub acosec(Numeric \x) { x.acosec } multi sub acosec(Cool \x) { x.Numeric.acosec } proto sub cotan($) is pure {*} multi sub cotan(Numeric \x) { x.cotan } multi sub cotan(Cool \x) { x.Numeric.cotan } proto sub acotan($) is pure {*} multi sub acotan(Numeric \x) { x.acotan } multi sub acotan(Cool \x) { x.Numeric.acotan } proto sub sinh($) is pure {*} multi sub sinh(Numeric \x) { x.sinh } multi sub sinh(Cool \x) { x.Numeric.sinh } proto sub asinh($) is pure {*} multi sub asinh(Numeric \x) { x.asinh } multi sub asinh(Cool \x) { x.Numeric.asinh } proto sub cosh($) is pure {*} multi sub cosh(Numeric \x) { x.cosh } multi sub cosh(Cool \x) { x.Numeric.cosh } proto sub acosh($) is pure {*} multi sub acosh(Numeric \x) { x.acosh } multi sub acosh(Cool \x) { x.Numeric.acosh } proto sub tanh($) is pure {*} multi sub tanh(Numeric \x) { x.tanh } multi sub tanh(Cool \x) { x.Numeric.tanh } proto sub atanh($) is pure {*} multi sub atanh(Numeric \x) { x.atanh } multi sub atanh(Cool \x) { x.Numeric.atanh } proto sub sech($) is pure {*} multi sub sech(Numeric \x) { x.sech } multi sub sech(Cool \x) { x.Numeric.sech } proto sub asech($) is pure {*} multi sub asech(Numeric \x) { x.asech } multi sub asech(Cool \x) { x.Numeric.asech } proto sub cosech($) is pure {*} multi sub cosech(Numeric \x) { x.cosech } multi sub cosech(Cool \x) { x.Numeric.cosech } proto sub acosech($) is pure {*} multi sub acosech(Numeric \x) { x.acosech } multi sub acosech(Cool \x) { x.Numeric.acosech } proto sub cotanh($) is pure {*} multi sub cotanh(Numeric \x) { x.cotanh } multi sub cotanh(Cool \x) { x.Numeric.cotanh } proto sub acotanh($) is pure {*} multi sub acotanh(Numeric \x) { x.acotanh } multi sub acotanh(Cool \x) { x.Numeric.acotanh } proto sub sqrt($) is pure {*} multi sub sqrt(Numeric \x) { x.sqrt } multi sub sqrt(Cool \x) { x.Numeric.sqrt } proto sub roots($, $) is pure { * } multi sub roots($x, Cool $n) { $x.Numeric.Complex.roots($n.Int) } multi sub roots($x, Numeric $n) { $x.Numeric.Complex.roots($n.Int) } proto sub floor($) is pure { * } multi sub floor($a) { $a.Numeric.floor } multi sub floor(Numeric $a) { $a.floor } proto sub ceiling($) is pure { * } multi sub ceiling($a) { $a.Numeric.ceiling } multi sub ceiling(Numeric $a) { $a.ceiling } proto sub round($, $?) is pure { * } multi sub round($a) { $a.Numeric.round } multi sub round(Numeric $a) { $a.round } multi sub round(Numeric $a, $scale) { $a.round($scale) } proto infix:<+>($a?, $b?) is pure { * } multi infix:<+>($x = 0) { $x.Numeric } multi infix:<+>(\a, \b) { a.Numeric + b.Numeric } proto infix:<->($a?, $b?) is pure { * } multi infix:<->($x = 0) { $x.Numeric } multi infix:<->(\a, \b) { a.Numeric - b.Numeric } proto infix:<*>($a?, $b?) is pure { * } multi infix:<*>($x = 1) { $x.Numeric } multi infix:<*>(\a, \b) { a.Numeric * b.Numeric } proto infix:($a?, $b?) { * } multi infix:() { fail "No zero-arg meaning for infix:" } multi infix:($x) { $x.Numeric } multi infix:(\a, \b) { a.Numeric / b.Numeric } proto infix:
($a?, $b?) is pure { * } # rest of infix:
is in Int.pm proto infix:<%>($a?, $b?) is pure { * } multi infix:<%>() { fail "No zero-arg meaning for infix:<%>" } multi infix:<%>($x) { $x } multi infix:<%>(\a, \b) { a.Real % b.Real } proto infix:<%%>($a?, $b?) is pure { * } multi infix:<%%>() { fail "No zero-arg meaning for infix:<%%>" } multi infix:<%%>($x) { Bool::True } multi infix:<%%>(\a, \b) { fail X::Numeric::DivideByZero.new(using => 'infix:<%%>') unless b; a.Real % b.Real == 0; } proto infix:($a?, $b?) is pure { * } multi infix:(Int $x = 1) { $x } multi infix:(\a, \b) { a.Int lcm b.Int } proto infix:($a?, $b?) is pure { * } multi infix:() { fail 'No zero-arg meaning for infix:' } multi infix:(Int $x) { $x } multi infix:(\a, \b) { a.Int gcd b.Int } proto infix:<**>($a?, $b?) is pure { * } multi infix:<**>($x = 1) { $x.Numeric } multi infix:<**>(\a, \b) { a.Numeric ** b.Numeric } ## relational operators proto infix:«<=>»($, $?) is pure { * } multi infix:«<=>»(\a, \b) { a.Real <=> b.Real } proto infix:<==>($a?, $b?) is pure { * } multi infix:<==>($x?) { Bool::True } multi infix:<==>(\a, \b) { a.Numeric == b.Numeric } proto infix:(Mu $a?, Mu $b?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(Mu \a, Mu \b) { not a == b } proto infix:«<»($a?, $b?) is pure { * } multi infix:«<»($x?) { Bool::True } multi infix:«<»(\a, \b) { a.Real < b.Real } proto infix:«<=»($a?, $b?) is pure { * } multi infix:«<=»($x?) { Bool::True } multi infix:«<=»(\a, \b) { a.Real <= b.Real } proto infix:«>»($a?, $b?) is pure { * } multi infix:«>»($x?) { Bool::True } multi infix:«>»(\a, \b) { a.Real > b.Real } proto infix:«>=»($a?, $b?) is pure { * } multi infix:«>=»($x?) { Bool::True } multi infix:«>=»(\a, \b) { a.Real >= b.Real } ## bitwise operators proto infix:<+&>($?, $?) is pure { * } multi infix:<+&>() { +^0 } multi infix:<+&>($x) { $x } multi infix:<+&>($x, $y) { $x.Numeric.Int +& $y.Numeric.Int } proto infix:<+|>($?, $?) is pure { * } multi infix:<+|>() { 0 } multi infix:<+|>($x) { $x } multi infix:<+|>($x, $y) { $x.Numeric.Int +| $y.Numeric.Int } proto infix:<+^>($?, $?) is pure { * } multi infix:<+^>() { 0 } multi infix:<+^>($x) { $x } multi infix:<+^>($x, $y) { $x.Numeric.Int +^ $y.Numeric.Int } proto infix:«+<»($?, $?) is pure { * } multi infix:«+<»() { fail "No zero-arg meaning for infix:«+<»"; } multi infix:«+<»($x) { $x } multi infix:«+<»($x,$y) { $x.Numeric.Int +< $y.Numeric.Int } proto infix:«+>»($?, $?) is pure { * } multi infix:«+>»() { fail "No zero-arg meaning for infix:«+>»"; } multi infix:«+>»($x) { $x } multi infix:«+>»($x,$y) { $x.Numeric.Int +> $y.Numeric.Int } proto prefix:<+^>($?, $?) is pure { * } multi prefix:<+^>($x) { +^ $x.Numeric.Int } rakudo-2013.12/src/core/Num.pm0000664000175000017500000002732212224263172015426 0ustar moritzmoritzmy class X::Numeric::DivideByZero { ... }; my class Num does Real { # declared in BOOTSTRAP # class Num is Cool { # has num $!value is box_target; multi method WHICH(Num:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.^name), '|'), nqp::unbox_n(self) ), ObjAt ); } method Num() { self } method Bridge(Num:D:) { self } method Int(Num:D:) { nqp::isnanorinf(nqp::unbox_n(self)) ?? fail("Cannot coerce Inf or NaN to an Int") !! nqp::fromnum_I(nqp::unbox_n(self), Int); } multi method new() { nqp::box_n(0e0, self) } multi method new($n) { nqp::box_n($n.Num, self) } multi method perl(Num:D:) { my $res = self.Str; if nqp::isnanorinf(nqp::unbox_n(self)) || $res.index('e').defined || $res.index('E').defined { $res; } else { $res ~ 'e0'; } } method Rat(Num:D: Real $epsilon = 1.0e-6, :$fat) { if nqp::isnanorinf(nqp::unbox_n(self)) { return self; } my sub modf($num) { my $q = $num.Int; $num - $q, $q; } (self == $Inf || self == -$Inf) && fail("Cannot coerce Inf to a Rat"); my Num $num = self; my Int $signum = $num < 0 ?? -1 !! 1; $num = -$num if $signum == -1; # Find convergents of the continued fraction. my Num $r = $num - $num.Int; my Int $q = $num.Int; my ($a, $b) = 1, $q; my ($c, $d) = 0, 1; while $r != 0 && abs($num - ($b/$d)) > $epsilon { ($r, $q) = modf(1/$r); ($a, $b) = ($b, $q*$b + $a); ($c, $d) = ($d, $q*$d + $c); } # Note that this result has less error than any Rational with a # smaller denominator but it is not (necessarily) the Rational # with the smallest denominator that has less than $epsilon error. # However, to find that Rational would take more processing. $fat ?? FatRat.new($signum * $b, $d) !! ($signum * $b) / $d; } method FatRat(Num:D: Real $epsilon = 1.0e-6) { self.Rat($epsilon, :fat); } multi method atan2(Num:D: Num:D $x = 1e0) { nqp::p6box_n(nqp::atan2_n(nqp::unbox_n(self), nqp::unbox_n($x))); } multi method Str(Num:D:) { nqp::p6box_s(nqp::unbox_n(self)); } method succ(Num:D:) { self + 1e0 } method pred(Num:D:) { self - 1e0 } method isNaN(Num:D: ) { self != self; } method abs(Num:D: ) { nqp::p6box_n(nqp::abs_n(nqp::unbox_n(self))); } multi method exp(Num:D: ) { nqp::p6box_n(nqp::exp_n(nqp::unbox_n(self))); } proto method log(|) {*} multi method log(Num:D: ) { nqp::p6box_n(nqp::log_n(nqp::unbox_n(self))); } multi method log(Num:D: Num \base) { self.log() / base.log(); } proto method sqrt(|) {*} multi method sqrt(Num:D: ) { nqp::p6box_n(nqp::sqrt_n(nqp::unbox_n(self))); } method rand(Num:D: ) { nqp::p6box_n(nqp::rand_n(nqp::unbox_n(self))); } method ceiling(Num:D: ) { nqp::isnanorinf(nqp::unbox_n(self)) ?? self !! nqp::fromnum_I(nqp::ceil_n(nqp::unbox_n(self)), Int); } method floor(Num:D: ) { nqp::isnanorinf(nqp::unbox_n(self)) ?? self !! nqp::fromnum_I(nqp::floor_n(nqp::unbox_n(self)), Int); } proto method sin(|) {*} multi method sin(Num:D: ) { nqp::p6box_n(nqp::sin_n(nqp::unbox_n(self))); } proto method asin(|) {*} multi method asin(Num:D: ) { nqp::p6box_n(nqp::asin_n(nqp::unbox_n(self))); } proto method cos(|) {*} multi method cos(Num:D: ) { nqp::p6box_n(nqp::cos_n(nqp::unbox_n(self))); } proto method acos(|) {*} multi method acos(Num:D: ) { nqp::p6box_n(nqp::acos_n(nqp::unbox_n(self))); } proto method tan(|) {*} multi method tan(Num:D: ) { nqp::p6box_n(nqp::tan_n(nqp::unbox_n(self))); } proto method atan(|) {*} multi method atan(Num:D: ) { nqp::p6box_n(nqp::atan_n(nqp::unbox_n(self))); } proto method sec(|) {*} multi method sec(Num:D: ) { nqp::p6box_n(nqp::sec_n(nqp::unbox_n(self))); } proto method asec(|) {*} multi method asec(Num:D: ) { nqp::p6box_n(nqp::asec_n(nqp::unbox_n(self))); } method cosec(Num:D:) { nqp::p6box_n(nqp::div_n(1e0, nqp::sin_n(nqp::unbox_n(self)))); } method acosec(Num:D:) { nqp::p6box_n(nqp::asin_n(nqp::div_n(1e0, nqp::unbox_n(self)))); } method cotan(Num:D:) { nqp::p6box_n(nqp::div_n(1e0, nqp::tan_n(nqp::unbox_n(self)))); } method acotan(Num:D:) { nqp::p6box_n(nqp::atan_n(nqp::div_n(1e0, nqp::unbox_n(self)))); } proto method sinh(|) {*} multi method sinh(Num:D: ) { nqp::p6box_n(nqp::sinh_n(nqp::unbox_n(self))); } proto method asinh(|) {*} multi method asinh(Num:D: ) { (self + (self * self + 1e0).sqrt).log; } proto method cosh(|) {*} multi method cosh(Num:D: ) { nqp::p6box_n(nqp::cosh_n(nqp::unbox_n(self))); } proto method acosh(|) {*} multi method acosh(Num:D: ) { (self + (self * self - 1e0).sqrt).log; } proto method tanh(|) {*} multi method tanh(Num:D: ) { nqp::p6box_n(nqp::tanh_n(nqp::unbox_n(self))); } proto method atanh(|) {*} multi method atanh(Num:D: ) { ((1e0 + self) / (1e0 - self)).log / 2e0; } proto method sech(|) {*} multi method sech(Num:D: ) { nqp::p6box_n(nqp::sech_n(nqp::unbox_n(self))); } proto method asech(|) {*} multi method asech(Num:D: ) { (1e0 / self).acosh; } proto method cosech(|) {*} multi method cosech(Num:D: ) { nqp::p6box_n(nqp::div_n(1e0, nqp::sinh_n(nqp::unbox_n(self)))); } proto method acosech(|) {*} multi method acosech(Num:D: ) { (1e0 / self).asinh; } proto method cotanh(|) {*} multi method cotanh(Num:D: ) { nqp::p6box_n(nqp::div_n(1e0, nqp::tanh_n(nqp::unbox_n(self)))); } proto method acotanh(|) {*} multi method acotanh(Num:D: ) { (1e0 / self).atanh; } } my constant pi = 3.14159_26535_89793_238e0; my constant e = 2.71828_18284_59045_235e0; multi prefix:<++>(Num:D \a is rw) { # XXX a = nqp::p6box_n(nqp::add_n(nqp::unbox_n(a), 1e0)) } multi prefix:<++>(Num:U \a is rw) { # XXX a = 1e0; } multi prefix:<-->(Num:D \a is rw) { # XXX a = nqp::p6box_n(nqp::sub_n(nqp::unbox_n(a), 1e0)) } multi prefix:<-->(Num:U \a is rw) { # XXX a = -1e0; } multi postfix:<++>(Num:D \a is rw) { # XXX my $b = a; a = nqp::p6box_n(nqp::add_n(nqp::unbox_n(a), 1e0)); $b } multi postfix:<++>(Num:U \a is rw) { # XXX a = 1e0; 0 } multi postfix:<-->(Num:D \a is rw) { # XXX my $b = a; a = nqp::p6box_n(nqp::sub_n(nqp::unbox_n(a), 1e0)); $b } multi postfix:<-->(Num:U \a is rw) { # XXX a = -1e0; 0e0 } multi prefix:<->(Num:D \a) { nqp::p6box_n(nqp::neg_n(nqp::unbox_n(a))) } multi prefix:<->(num $a) { nqp::neg_n($a); } multi sub abs(Num:D \a) { nqp::p6box_n(nqp::abs_n(nqp::unbox_n(a))) } multi sub abs(num $a) { nqp::abs_n($a) } multi infix:<+>(Num:D \a, Num:D \b) { nqp::p6box_n(nqp::add_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<+>(num $a, num $b) { nqp::add_n($a, $b) } multi infix:<->(Num:D \a, Num:D \b) { nqp::p6box_n(nqp::sub_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<->(num $a, num $b) { nqp::sub_n($a, $b) } multi infix:<*>(Num:D \a, Num:D \b) { nqp::p6box_n(nqp::mul_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<*>(num $a, num $b) { nqp::mul_n($a, $b) } multi infix:(Num:D \a, Num:D \b) { fail X::Numeric::DivideByZero.new unless b; nqp::p6box_n(nqp::div_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:(num $a, num $b) { fail X::Numeric::DivideByZero.new unless $b; nqp::div_n($a, $b) } multi infix:<%>(Num:D \a, Num:D \b) { fail X::Numeric::DivideByZero.new(:using<%>) unless b; nqp::p6box_n(nqp::mod_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<%>(num $a, num $b) { fail X::Numeric::DivideByZero.new(:using<%>) unless $b; nqp::mod_n($a, $b) } multi infix:<**>(Num:D \a, Num:D \b) { nqp::p6box_n(nqp::pow_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<**>(num $a, num $b) { nqp::pow_n($a, $b) } multi infix:(Num:D \a, Num:D \b) { Order.(nqp::p6box_i(nqp::cmp_n(nqp::unbox_n(a), nqp::unbox_n(b)))) } multi infix:(num $a, num $b) { Order.(nqp::p6box_i(nqp::cmp_n($a, $b))) } multi infix:«<=>»(Num:D \a, Num:D \b) { Order.(nqp::p6box_i(nqp::cmp_n(nqp::unbox_n(a), nqp::unbox_n(b)))) } multi infix:«<=>»(num $a, num $b) { Order.(nqp::p6box_i(nqp::cmp_n($a, $b))) } multi infix:<===>(Num:D \a, Num:D \b) { nqp::p6bool(nqp::iseq_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<===>(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::iseq_n($a, $b)) } multi infix:<==>(Num:D \a, Num:D \b) returns Bool:D { nqp::p6bool(nqp::iseq_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:<==>(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::iseq_n($a, $b)) } multi infix:(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::isne_n($a, $b)) } multi infix:«<»(Num:D \a, Num:D \b) returns Bool:D { nqp::p6bool(nqp::islt_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:«<»(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::islt_n($a, $b)) } multi infix:«<=»(Num:D \a, Num:D \b) returns Bool:D { nqp::p6bool(nqp::isle_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:«<=»(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::isle_n($a, $b)) } multi infix:«>»(Num:D \a, Num:D \b) returns Bool:D { nqp::p6bool(nqp::isgt_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:«>»(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::isgt_n($a, $b)) } multi infix:«>=»(Num:D \a, Num:D \b) returns Bool:D { nqp::p6bool(nqp::isge_n(nqp::unbox_n(a), nqp::unbox_n(b))) } multi infix:«>=»(num $a, num $b) returns Bool:D { nqp::p6bool(nqp::isge_n($a, $b)) } sub rand() returns Num:D { nqp::p6box_n(nqp::rand_n(1e0)); } # TODO: default seed of 'time' sub srand(Int $seed) returns Int:D { nqp::p6box_i(nqp::srand($seed)) } multi sub atan2(Num:D $a, Num:D $b = 1e0) { nqp::p6box_n(nqp::atan2_n(nqp::unbox_n($a), nqp::unbox_n($b))); } multi sub cosec(Num:D \x) { nqp::p6box_n(nqp::div_n(1e0, nqp::sin_n(nqp::unbox_n(x)))); } multi sub acosec(Num:D \x) { nqp::p6box_n(nqp::asin_n(nqp::div_n(1e0, nqp::unbox_n(x)))); } multi sub log(num $x) { nqp::log_n($x); } multi sub sin(num $x) { nqp::sin_n($x); } multi sub asin(num $x) { nqp::asin_n($x); } multi sub cos(num $x) { nqp::cos_n($x); } multi sub acos(num $x) { nqp::acos_n($x); } multi sub tan(num $x) { nqp::tan_n($x); } multi sub atan(num $x) { nqp::atan_n($x); } multi sub sec(num $x) { nqp::sec_n($x); } multi sub asec(num $x) { nqp::asec_n($x); } multi sub cotan(num $x) { nqp::div_n(1e0, nqp::tan_n($x)); } multi sub acotan(num $x) { nqp::div_n(1e0, nqp::atan_n($x)); } multi sub sinh(num $x) { nqp::sinh_n($x); } multi sub asinh(num $x) { log($x + ($x * $x + 1e0)); } multi sub cosh(num $x) { nqp::cosh_n($x); } multi sub acosh(num $x) { log($x + ($x * $x - 1e0)) } multi sub tanh(num $x) { nqp::tanh_n($x); } multi sub atanh(num $x) { log((1e0 + $x) / (1e0 - $x)) / 2e0; } multi sub sech(num $x) { nqp::sech_n($x); } multi sub asech(num $x) { acosh(1e0 / $x); } multi sub cosech(num $x) { 1e0 / sinh($x) } multi sub acosech(num $x) { asinh(1e0 / $x); } multi sub cotanh(num $x) { 1e0 / tanh($x); } multi sub acotanh(num $x) { atanh(1e0 / $x) } rakudo-2013.12/src/core/ObjAt.pm0000664000175000017500000000073312224263172015663 0ustar moritzmoritzmy class ObjAt { # declared in BOOTSTRAP # class ObjAt is Any { # has str $!value; multi method WHICH(ObjAt:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.^name), '|'), $!value ), ObjAt ); } multi method Str(ObjAt:D:) { nqp::p6box_s(nqp::unbox_s(self)); } multi method gist(ObjAt:D:) { nqp::p6box_s(nqp::unbox_s(self)); } } rakudo-2013.12/src/core/operators.pm0000664000175000017500000002612112242026101016666 0ustar moritzmoritz## miscellaneous operators can go here. ## generic numeric operators are in Numeric.pm ## generic string operators are in Stringy.pm ## Int/Rat/Num operators are in {Int|Rat|Num}.pm sub infix:<=>(Mu \a, Mu \b) is rw { nqp::p6store(a, b) } proto infix:(Mu, Mu, *%) { * } multi infix:(Mu:D \obj, Mu:U \rolish) is rw { # XXX Mutability check. my $role := rolish.HOW.archetypes.composable() ?? rolish !! rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !! X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw; obj.HOW.mixin(obj, $role).BUILD_LEAST_DERIVED({}); } multi infix:(Mu:D \obj, Mu:U \rolish, :$value! is parcel) is rw { # XXX Mutability check. my $role := rolish.HOW.archetypes.composable() ?? rolish !! rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !! X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw; my @attrs = $role.^attributes().grep: { .has_accessor }; X::Role::Initialization.new(:$role).throw unless @attrs == 1; obj.HOW.mixin(obj, $role).BUILD_LEAST_DERIVED({ @attrs[0].Str.substr(2) => $value }); } multi infix:(Mu:U \obj, Mu:U \role) is rw { X::Does::TypeObject.new().throw } multi infix:(Mu:D \obj, @roles) is rw { # XXX Mutability check. obj.HOW.mixin(obj, |@roles).BUILD_LEAST_DERIVED({}); } multi infix:(Mu:U \obj, @roles) is rw { X::Does::TypeObject.new().throw } proto infix:(Mu, Mu, *%) { * } multi infix:(Mu:D \obj, Mu:U \rolish) { my $role := rolish.HOW.archetypes.composable() ?? rolish !! rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !! X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw; obj.HOW.mixin(obj.clone(), $role).BUILD_LEAST_DERIVED({}); } multi infix:(Mu:D \obj, Mu:U \rolish, :$value! is parcel) { my $role := rolish.HOW.archetypes.composable() ?? rolish !! rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !! X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw; my @attrs = $role.^attributes().grep: { .has_accessor }; X::Role::Initialization.new(:$role).throw unless @attrs == 1; my $mixin-value := $value; unless nqp::istype($value, @attrs[0].type) { if @attrs[0].type.HOW.HOW.name(@attrs[0].type.HOW) eq 'Perl6::Metamodel::EnumHOW' { $mixin-value := @attrs[0].type.($value); } } obj.HOW.mixin(obj.clone(), $role).BUILD_LEAST_DERIVED({ @attrs[0].Str.substr(2) => $mixin-value }); } multi infix:(Mu:U \obj, Mu:U \rolish) { my $role := rolish.HOW.archetypes.composable() ?? rolish !! rolish.HOW.archetypes.composalizable() ?? rolish.HOW.composalize(rolish) !! X::Mixin::NotComposable.new(:target(obj), :rolish(rolish)).throw; obj.HOW.mixin(obj, $role); } multi infix:(Mu \obj, Mu:D $val) is rw { my $role := Metamodel::ParametricRoleHOW.new_type(); my $meth := method () { $val }; $meth.set_name($val.^name); $role.HOW.add_method($role, $meth.name, $meth); $role.HOW.set_body_block($role, -> |c { nqp::list($role, nqp::hash('$?CLASS', c<$?CLASS>)) }); $role.HOW.compose($role); obj.HOW.mixin(obj.clone(), $role); } multi infix:(Mu:D \obj, @roles) { obj.HOW.mixin(obj.clone(), |@roles).BUILD_LEAST_DERIVED({}); } multi infix:(Mu:U \obj, @roles) { obj.HOW.mixin(obj, |@roles) } sub SEQUENCE($left, Mu $right, :$exclude_end) { my @right := nqp::istype($right, Junction) || !$right.DEFINITE ?? [$right] !! $right.flat; my $endpoint = @right.shift; my $infinite = $endpoint ~~ Whatever || $endpoint === $Inf; $endpoint = Bool::False if $infinite; my $tail := ().list; my sub succpred($cmp) { ($cmp < 0) ?? { $^x.succ } !! ( $cmp > 0 ?? { $^x.pred } !! { $^x } ) } my sub unisuccpred($cmp) { ($cmp < 0) ?? { $^x.ord.succ.chr } !! ( $cmp > 0 ?? { $^x.ord.pred.chr } !! { $^x } ) } (GATHER({ my @left := $left.flat; my $value; my $code; my $stop; while @left { $value = @left.shift; if $value ~~ Code { $code = $value; last } if $value ~~ $endpoint { $stop = 1; last } $tail.push($value); take $value; } unless $stop { my ($a, $b, $c); unless $code.defined { $tail.munch($tail.elems - 3) if $tail.elems > 3; $a = $tail[0]; $b = $tail[1]; $c = $tail[2]; } if $code.defined { } elsif $tail.grep({ $_ ~~ Numeric}).elems != $tail.elems { # non-numeric if $tail.elems == 1 { if $a ~~ Stringy && $endpoint ~~ Stringy && $a.codes == 1 && $endpoint.codes == 1 { $code = $infinite ?? { $^x.ord.succ.chr } !! unisuccpred($a.ord cmp $endpoint.ord); } else { $code = $infinite ?? { $^x.succ } !! succpred($a cmp $endpoint); } } else { $code = succpred($tail[*-2] cmp $tail[*-1]); } } elsif $tail.elems == 3 { my $ab = $b - $a; if $ab == $c - $b { if $ab != 0 || $a ~~ Numeric && $b ~~ Numeric && $c ~~ Numeric { $code = { $^x + $ab } } else { $code = succpred($b cmp $c) } } elsif $a != 0 && $b != 0 && $c != 0 { $ab = $b / $a; if $ab == $c / $b { $ab = $ab.Int if $ab ~~ Rat && $ab.denominator == 1; $code = { $^x * $ab } } } } elsif $tail.elems == 2 { my $ab = $b - $a; if $ab != 0 || $a ~~ Numeric && $b ~~ Numeric { $code = { $^x + $ab } } else { $code = succpred($a cmp $b) } } elsif $tail.elems == 1 { $code = $a cmp $endpoint > 0 ?? { $^x.pred } !! { $^x.succ } } elsif $tail.elems == 0 { $code = {()} } if $code.defined { my $count = $code.count; while 1 { $tail.munch($tail.elems - $count); $value := $code(|$tail); last if $value ~~ $endpoint; $tail.push($value); take $value; } } else { $value = (sub { fail X::Sequence::Deduction.new })(); } } take $value unless $exclude_end; }, :$infinite), @right).list; } # XXX Wants to be a macro when we have them. sub WHAT(\x) { x.WHAT } sub VAR (\x) { x.VAR } proto sub infix:<...>(|) { * } multi sub infix:<...>($a, Mu $b) { SEQUENCE($a, $b) } multi sub infix:<...>(**@lol) { my @ret; my int $i = 0; my int $m = +@lol - 1; while $m > $i { @ret := (@ret, SEQUENCE( @lol[$i], # from-range, specifies steps @lol[$i + 1].list[0], # to, we only need the endpoint (= first item) :exclude_end( ($i = nqp::add_i($i, 1)) < $m ) # exlude the end unless we are at the end ) ).flat; } @ret } proto sub infix:<...^>(|) { * } multi sub infix:<...^>($a, Mu $b) { SEQUENCE($a, $b, :exclude_end(1)) } sub undefine(Mu \x) { x = Nil } sub prefix:(\cont) is rw { my $temp_restore := nqp::getlexcaller('!TEMP-RESTORE'); my int $i = nqp::elems($temp_restore); while $i > 0 { $i = $i - 2; return-rw cont if nqp::atpos($temp_restore, $i) =:= cont; } if nqp::iscont(cont) { nqp::push($temp_restore, cont); nqp::push($temp_restore, nqp::decont(cont)); } elsif nqp::istype(cont, Array) { nqp::push($temp_restore, cont); nqp::push($temp_restore, my @a = cont); } elsif nqp::istype(cont, Hash) { nqp::push($temp_restore, cont); nqp::push($temp_restore, my %h = cont); } else { X::Localizer::NoContainer.new(localizer => 'temp').throw; } cont } sub prefix:(\cont) is rw { my $let_restore := nqp::getlexcaller('!LET-RESTORE'); my int $i = nqp::elems($let_restore); while $i > 0 { $i = $i - 2; return-rw cont if nqp::atpos($let_restore, $i) =:= cont; } if nqp::iscont(cont) { nqp::push($let_restore, cont); nqp::push($let_restore, nqp::decont(cont)); } elsif nqp::istype(cont, Array) { nqp::push($let_restore, cont); nqp::push($let_restore, my @a = cont); } elsif nqp::istype(cont, Hash) { nqp::push($let_restore, cont); nqp::push($let_restore, my %h = cont); } else { X::Localizer::NoContainer.new(localizer => 'let').throw; } cont } # not sure where this should go # this implements the ::() indirect lookup sub INDIRECT_NAME_LOOKUP($root, *@chunks) is rw { # note that each part of @chunks itself can # contain double colons. That's why joining and # re-splitting is necessary my Str $name = @chunks.join('::'); my @parts = $name.split('::'); my $first = @parts.shift; if @parts && '$@%&'.index($first.substr(0, 1)).defined { # move sigil from first to last chunk, because # $Foo::Bar::baz is actually stored as Foo::Bar::$baz my $last_idx = @parts.end; @parts[$last_idx] = $first.substr(0, 1) ~ @parts[$last_idx]; $first = $first.substr(1); if $first eq '' { $first = @parts.shift; $name = @chunks.join('::'); } } my Mu $thing := $root.exists_key($first) ?? $root{$first} !! GLOBAL::.exists_key($first) ?? GLOBAL::{$first} !! X::NoSuchSymbol.new(symbol => $name).fail; for @parts { X::NoSuchSymbol.new(symbol => $name).fail unless $thing.WHO.exists_key($_); $thing := $thing.WHO{$_}; } $thing; } sub REQUIRE_IMPORT($package-name, *@syms) { my $package = CALLER::OUR::($package-name); my $who = $package.WHO; unless $who.exists_key('EXPORT') { die "Trying to import symbols @syms.join(', ') from '$package-name', but it does not export anything"; } $who := $who.WHO.WHO; my @missing; for @syms { unless $who.exists_key($_) { @missing.push: $_; next; } OUTER::CALLER::{$_} := $who{$_}; } if @missing { X::Import::MissingSymbols.new(:from($package-name), :@missing).throw; } $package } sub infix:(*@a) { my Mu $current := @a.shift; for @a { return $current unless $current.defined; $current := .count ?? $_(|$current) !! $_(); } $current; } rakudo-2013.12/src/core/Order.pm0000664000175000017500000000147712242026101015732 0ustar moritzmoritz## Order enumeration, for cmp and <=> my enum Order (:Less(-1), :Same(0), :More(1)); only Increase () { DEPRECATED("Less"); Less } only Decrease (){ DEPRECATED("More"); More } proto infix:($, $) { * } multi infix:(\a, \b) { return Order::Less if a === -$Inf || b === $Inf; return Order::More if a === $Inf || b === -$Inf; a.Stringy cmp b.Stringy } multi infix:(Real \a, Real \b) { a.Bridge cmp b.Bridge } multi infix:(Int:D \a, Int:D \b) { Order.(nqp::p6box_i(nqp::cmp_I(nqp::decont(a), nqp::decont(b)))) } multi infix:(int $a, int $b) { Order.(nqp::p6box_i(nqp::cmp_i($a, $b))) } multi infix:«<=>»(Int:D \a, Int:D \b) { Order.(nqp::p6box_i(nqp::cmp_I(nqp::decont(a), nqp::decont(b)))) } multi infix:«<=>»(int $a, int $b) { Order.(nqp::p6box_i(nqp::cmp_i($a, $b))) } rakudo-2013.12/src/core/OS.pm0000664000175000017500000000111312242026101015163 0ustar moritzmoritzsub gethostname( --> Str){ return nqp::p6box_s(nqp::gethostname()); } my class Proc::Status { has $.exit; has $.pid; has $.signal; #~ method exit() { $!exit } #~ method pid() { $!pid } #~ method signal() { $!signal } proto method status(|) { * } multi method status($new_status) { $!exit = $new_status +> 8; $!signal = $new_status +& 0xFF; } multi method status() { ($!exit +< 8) +| $!signal } method Numeric { $!exit } method Bool { $!exit == 0 } } rakudo-2013.12/src/core/Pair.pm0000664000175000017500000000063612224263172015561 0ustar moritzmoritzmy class Pair is Enum { method key() is rw { nqp::getattr(self, Enum, '$!key') } method value() is rw { nqp::getattr(self, Enum, '$!value') } multi method ACCEPTS(Pair:D: %h) { $.value.ACCEPTS(%h{$.key}); } multi method ACCEPTS(Pair:D: Mu $other) { $other."$.key"().Bool === $.value.Bool } } sub infix:«=>»($key, Mu $value) { Pair.new(:key($key), :value($value)) } rakudo-2013.12/src/core/Parameter.pm0000664000175000017500000001371012224263172016603 0ustar moritzmoritzmy class Parameter { # declared in BOOTSTRAP # class Parameter is Any { # has str $!variable_name # has Mu $!named_names # has Mu $!type_captures # has int $!flags # has Mu $!nominal_type # has Mu $!post_constraints # has Mu $!coerce_type # has str $!coerce_method # has Mu $!sub_signature # has Mu $!default_value # has Mu $!container_descriptor; # has Mu $!attr_package; my constant $SIG_ELEM_BIND_CAPTURE = 1; my constant $SIG_ELEM_BIND_PRIVATE_ATTR = 2; my constant $SIG_ELEM_BIND_PUBLIC_ATTR = 4; my constant $SIG_ELEM_SLURPY_POS = 8; my constant $SIG_ELEM_SLURPY_NAMED = 16; my constant $SIG_ELEM_SLURPY_BLOCK = 32; my constant $SIG_ELEM_INVOCANT = 64; my constant $SIG_ELEM_MULTI_INVOCANT = 128; my constant $SIG_ELEM_IS_RW = 256; my constant $SIG_ELEM_IS_COPY = 512; my constant $SIG_ELEM_IS_PARCEL = 1024; my constant $SIG_ELEM_IS_OPTIONAL = 2048; my constant $SIG_ELEM_ARRAY_SIGIL = 4096; my constant $SIG_ELEM_HASH_SIGIL = 8192; my constant $SIG_ELEM_IS_CAPTURE = 32768; my constant $SIG_ELEM_UNDEFINED_ONLY = 65536; my constant $SIG_ELEM_DEFINED_ONLY = 131072; method name() { $!variable_name } method constraint_list() { nqp::isnull($!post_constraints) ?? () !! nqp::hllize($!post_constraints) } method constraints() { all(nqp::isnull($!post_constraints) ?? () !! nqp::hllize($!post_constraints)) } method type() { $!nominal_type } method named() { !nqp::p6bool(nqp::isnull($!named_names)) || nqp::p6bool($!flags +& $SIG_ELEM_SLURPY_NAMED) } method named_names() { if !nqp::isnull($!named_names) { my Int $count = nqp::p6box_i(nqp::elems($!named_names)); my Int $i = 0; my @res; while $i < $count { @res.push: nqp::p6box_s(nqp::atpos($!named_names, nqp::unbox_i($i))); $i++; } @res; } else { ().list } } method positional() { nqp::p6bool( ($!flags +& ($SIG_ELEM_SLURPY_POS +| $SIG_ELEM_SLURPY_NAMED +| $SIG_ELEM_IS_CAPTURE)) == 0 && nqp::isnull($!named_names) ) } method slurpy() { nqp::p6bool( $!flags +& ($SIG_ELEM_SLURPY_POS +| $SIG_ELEM_SLURPY_NAMED +| $SIG_ELEM_SLURPY_BLOCK) ) } method optional() { ?($!flags +& $SIG_ELEM_IS_OPTIONAL) } method parcel() { ?($!flags +& $SIG_ELEM_IS_PARCEL) } method capture() { ?($!flags +& $SIG_ELEM_IS_CAPTURE) } method rw() { ?($!flags +& $SIG_ELEM_IS_RW) } method copy() { ?($!flags +& $SIG_ELEM_IS_COPY) } method readonly() { !($.rw || $.copy || $.parcel) } method invocant() { ?($!flags +& $SIG_ELEM_INVOCANT) } method default() { nqp::isnull($!default_value) ?? Any !! $!default_value ~~ Code ?? $!default_value !! { $!default_value } } method type_captures() { if !nqp::isnull($!type_captures) { my Int $count = nqp::p6box_i(nqp::elems($!type_captures)); my Int $i = 0; my @res; while $i < $count { @res.push: nqp::p6box_s(nqp::atpos($!type_captures, nqp::unbox_i($i))); $i++; } @res; } else { ().list } } # XXX TODO: A few more bits :-) multi method perl(Parameter:D:) { my $perl = ''; my $type = $!nominal_type.HOW.name($!nominal_type); if $!flags +& $SIG_ELEM_ARRAY_SIGIL { # XXX Need inner type } elsif $!flags +& $SIG_ELEM_HASH_SIGIL { # XXX Need inner type } else { $perl = $type; if $!flags +& $SIG_ELEM_DEFINED_ONLY { $perl ~= ':D'; } elsif $!flags +& $SIG_ELEM_UNDEFINED_ONLY { $perl ~= ':U'; } } $perl = '' if $perl eq any(); $perl ~= ' ' if $perl; if $!variable_name { my $name = $!variable_name; if $!flags +& $SIG_ELEM_IS_CAPTURE { $perl ~= '|' ~ $name; } elsif $!flags +& $SIG_ELEM_IS_PARCEL { $perl ~= '\\' ~ $name; } else { my $default = self.default(); if self.slurpy { $name = '*' ~ $name; } elsif self.named { my @names := self.named_names; my $/ := $name ~~ / ^^ $=<[$@%&]> $=(@names) $$ /; $name = ':' ~ $name if $/; unless +@names == 1 and $_ and "\$$_" eq $name { for @names { next if $/ and $_ eq $; $name = ':' ~ $_ ~ '(' ~ $name ~ ')'; } } $name ~= '!' unless self.optional; } elsif self.optional && !$default { $name ~= '?'; } $perl ~= $name; if $!flags +& $SIG_ELEM_IS_RW { $perl ~= ' is rw'; } elsif $!flags +& $SIG_ELEM_IS_COPY { $perl ~= ' is copy'; } $perl ~= ' = { ... }' if $default; unless nqp::isnull($!sub_signature) { $perl ~= ' ' ~ $!sub_signature.perl(); } } } $perl } method sub_signature(Parameter:D:) { nqp::isnull($!sub_signature) ?? Any !! $!sub_signature } } rakudo-2013.12/src/core/Parcel.pm0000664000175000017500000001174612242026101016065 0ustar moritzmoritzmy class Parcel does Positional { # declared in BOOTSTRAP # class Parcel is Cool { # has Mu $!storage; # VM's array of Parcel's elements submethod BUILD() { $!storage := nqp::list() } multi method Bool(Parcel:D:) { nqp::p6bool($!storage) } multi method Numeric(Parcel:D:) { self.flat.elems } multi method Str(Parcel:D:) { self.flat.Str } # multi method Int(Parcel:D:) { self.flat.elems } multi method ACCEPTS(Parcel:D: $topic) { self.list.ACCEPTS($topic) } method Parcel() { self } method Capture() { my $cap := nqp::create(Capture); my Mu $list := nqp::list(); my Mu $hash := nqp::hash(); my int $c = nqp::elems($!storage); my int $i = 0; while $i < $c { my $v := nqp::atpos($!storage, $i); nqp::istype($v, Pair) ?? nqp::bindkey($hash, nqp::unbox_s($v.key), $v.value) !! nqp::push($list, $v); $i = $i + 1; } nqp::bindattr($cap, Capture, '$!list', $list); nqp::bindattr($cap, Capture, '$!hash', $hash); $cap } method elems() { self.flat.elems } method item() { my $v = self; } method flat() { nqp::p6list(nqp::clone($!storage), List, Bool::True) } method list() { nqp::p6list(nqp::clone($!storage), List, Mu) } method lol() { nqp::p6list(nqp::clone($!storage), LoL, Mu) } method reverse() { my Mu $reverse := nqp::list(); my Mu $original := nqp::clone($!storage); nqp::push($reverse, nqp::pop($original)) while $original; my $parcel := nqp::create(self.WHAT); nqp::bindattr($parcel, Parcel, '$!storage', $reverse); $parcel; } method rotate (Int $n is copy = 1) { my Mu $storage := nqp::clone($!storage); $n %= nqp::p6box_i(nqp::elems($!storage)); if $n > 0 { nqp::push($storage, nqp::shift($storage)) while $n--; } elsif $n < 0 { nqp::unshift($storage, nqp::pop($storage)) while $n++; } my $parcel := nqp::create(self.WHAT); nqp::bindattr($parcel, Parcel, '$!storage', $storage); $parcel; } method at_pos(Parcel:D: \x) is rw { self.flat.at_pos(x); } multi method gist(Parcel:D:) { my Mu $gist := nqp::list(); my Mu $iter := nqp::iterator($!storage); nqp::push($gist, nqp::unbox_s(nqp::shift($iter).gist)) while $iter; nqp::p6box_s(nqp::join(' ', $gist)) } multi method perl(Parcel:D \SELF:) { my Mu $rpa := nqp::clone($!storage); my $perl = nqp::iscont(SELF) ?? '$(' !! '('; if $rpa { $perl = $perl ~ nqp::shift($rpa).perl; if $rpa { $perl = $perl ~ ', ' ~ nqp::shift($rpa).perl while $rpa; } else { $perl = $perl ~ ','; } $perl ~ ')' } elsif nqp::iscont(SELF) { $perl ~ ' )' # beause $() is about Matches... } else { $perl ~ ')' } } method STORE(|) { # get the list of rvalues to store and lhs containers my Mu $args := nqp::p6argvmarray(); nqp::shift($args); my $rhs := nqp::p6list($args, List, Bool::True); # XXX this might need to be Seq # first pass -- scan lhs containers and pick out # scalar versus list assignment. This also reifies # the rhs values my Mu $lhs := nqp::clone($!storage); my Mu $tv := nqp::list(); while ($lhs) { my Mu $x := nqp::shift($lhs); if nqp::iscont($x) { # container: scalar assignment nqp::push($tv, $x); nqp::push($tv, $rhs.gimme(1) ?? nqp::decont($rhs.shift) !! Nil); } elsif nqp::istype($x, Whatever) { # Whatever: skip assigning value $rhs.shift; } elsif nqp::istype($x, Parcel) { # Parcel: splice into current lhs nqp::splice($lhs, nqp::getattr($x, Parcel, '$!storage'), 0, 0) } else { # store entire rhs nqp::push($tv, $x); nqp::push($tv, $rhs); $rhs := ().list; } } # second pass, perform the assignments while ($tv) { my $x := nqp::shift($tv); $x = nqp::shift($tv); } self } multi method DUMP(Parcel:D: :$indent-step = 4, :%ctx?) { return DUMP(self, :$indent-step) unless %ctx; my Mu $attrs := nqp::list(); nqp::push($attrs, '$!storage'); nqp::push($attrs, $!storage ); self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx); } method FLATTENABLE_LIST() { $!storage } method FLATTENABLE_HASH() { nqp::hash() } method fmt($format = '%s', $separator = ' ') { self.list.fmt($format, $separator); } } my sub infix:<,>(|) is pure { nqp::p6parcel(nqp::p6argvmarray(), nqp::null()); } rakudo-2013.12/src/core/Pod.pm0000664000175000017500000000341612224263172015407 0ustar moritzmoritzmy class Pod::Block { has %.config; has @.content; sub pod-gist(Pod::Block $pod, $level = 0) { my $leading = ' ' x $level; my %confs; my @chunks; for { 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 ~~ Positional { @chunks.push: $c>>.Str.perl.indent($level + 2), "\n"; } else { @chunks.push: $c.Str.indent($level + 2), "\n"; } } @chunks.join; } multi method gist(Pod::Block:D:) { pod-gist(self) } } my class Pod::Block::Para is Pod::Block { } my class Pod::Block::Named is Pod::Block { has $.name; } my class Pod::Block::Comment is Pod::Block { } my class Pod::Block::Code is Pod::Block { has @.allowed; } my class Pod::Block::Declarator is Pod::Block { has $.WHEREFORE; method set_docee($d) { $!WHEREFORE = $d } method Str { ~@.content } multi method gist(Pod::Block::Declarator:D:) { self.Str } } my class Pod::Block::Table is Pod::Block { has $.caption; has @.headers; # optional, may be empty } my class Pod::FormattingCode is Pod::Block { has $.type; } my class Pod::Heading is Pod::Block { has $.level; } my class Pod::Item is Pod::Block { has $.level; } class Pod::Config { has $.type; has %.config; } # vim: ft=perl6 rakudo-2013.12/src/core/Positional.pm0000664000175000017500000000006712224263172017005 0ustar moritzmoritzmy role Positional[::T = Mu] { method of() { T } } rakudo-2013.12/src/core/precedence.pm0000664000175000017500000001462412224263172016765 0ustar moritzmoritz# We attach precedence information to all operators here. This is instead of # putting the traits directly on the op bodies, since some of the things that # the traits are implemented using aren't defined that early. BEGIN { my Mu $methodcall := nqp::hash('prec', 'y='); my Mu $autoincrement := nqp::hash('prec', 'x='); my Mu $exponentiation := nqp::hash('prec', 'w='); my Mu $symbolic_unary := nqp::hash('prec', 'v='); my Mu $multiplicative := nqp::hash('prec', 'u='); my Mu $additive := nqp::hash('prec', 't='); my Mu $replication := nqp::hash('prec', 's='); my Mu $concatenation := nqp::hash('prec', 'r='); my Mu $junctive_and := nqp::hash('prec', 'q='); my Mu $junctive_or := nqp::hash('prec', 'p='); my Mu $structural := nqp::hash('prec', 'n='); my Mu $chaining := nqp::hash('prec', 'm=', 'iffy', 1, 'pasttype', 'chain'); my Mu $iffy := nqp::hash('prec', 'u=', 'iffy', 1); trait_mod:(&postfix:, :prec($methodcall)); trait_mod:(&prefix:<++>, :prec($autoincrement)); trait_mod:(&prefix:<-->, :prec($autoincrement)); trait_mod:(&postfix:<++>, :prec($autoincrement)); trait_mod:(&postfix:<-->, :prec($autoincrement)); trait_mod:(&infix:<**>, :prec($exponentiation)); trait_mod:(&prefix:<+>, :prec($symbolic_unary)); trait_mod:(&prefix:<~>, :prec($symbolic_unary)); trait_mod:(&prefix:<->, :prec($symbolic_unary)); trait_mod:(&prefix:, :prec($symbolic_unary)); trait_mod:(&prefix:, :prec($symbolic_unary)); trait_mod:(&prefix:<+^>, :prec($symbolic_unary)); trait_mod:(&prefix:<~^>, :prec($symbolic_unary)); trait_mod:(&prefix:, :prec($symbolic_unary)); trait_mod:(&prefix:<^>, :prec($symbolic_unary)); trait_mod:(&infix:<*>, :prec($multiplicative)); trait_mod:(&infix:, :prec($multiplicative)); trait_mod:(&infix:
, :prec($multiplicative)); trait_mod:(&infix:, :prec($multiplicative)); trait_mod:(&infix:, :prec($multiplicative)); trait_mod:(&infix:<%>, :prec($multiplicative)); trait_mod:(&infix:, :prec($multiplicative)); trait_mod:(&infix:<+&>, :prec($multiplicative)); trait_mod:(&infix:<~&>, :prec($multiplicative)); trait_mod:(&infix:, :prec($multiplicative)); trait_mod:(&infix:<%%>, :prec($iffy)); trait_mod:(&infix:<+>, :prec($additive)); trait_mod:(&infix:<->, :prec($additive)); trait_mod:(&infix:<+|>, :prec($additive)); trait_mod:(&infix:<+^>, :prec($additive)); trait_mod:(&infix:<~|>, :prec($additive)); trait_mod:(&infix:<~^>, :prec($additive)); trait_mod:(&infix:, :prec($additive)); trait_mod:(&infix:, :prec($additive)); trait_mod:(&infix:, :prec($replication)); trait_mod:(&infix:, :prec($replication)); trait_mod:(&infix:<~>, :prec($concatenation)); trait_mod:(&infix:<&>, :prec($junctive_and)); trait_mod:(&infix:<(&)>, :prec($junctive_and)); trait_mod:(&infix:<<"\x2229">>, :prec($junctive_and)); trait_mod:(&infix:<(.)>, :prec($junctive_and)); trait_mod:(&infix:<<"\x228D">>, :prec($junctive_and)); trait_mod:(&infix:<|>, :prec($junctive_or)); trait_mod:(&infix:<^>, :prec($junctive_or)); trait_mod:(&infix:<(+)>, :prec($junctive_or)); trait_mod:(&infix:<<"\x228E">>, :prec($junctive_or)); trait_mod:(&infix:<(|)>, :prec($junctive_or)); trait_mod:(&infix:<<"\x222A">>, :prec($junctive_or)); trait_mod:(&infix:<(-)>, :prec($junctive_or)); trait_mod:(&infix:<<"\x2216">>, :prec($junctive_or)); trait_mod:(&infix:<(^)>, :prec($junctive_or)); trait_mod:(&infix:<<"\x2296">>, :prec($junctive_or)); trait_mod:(&infix:<==>, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:<=:=>, :prec($chaining)); trait_mod:(&infix:<===>, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:, :prec($chaining)); trait_mod:(&infix:<~~>, :prec($chaining)); trait_mod:(&infix:<(elem)>, :prec($chaining)); trait_mod:(&infix:<<"\x2208">>, :prec($chaining)); trait_mod:(&infix:<<"\x2209">>, :prec($chaining)); trait_mod:(&infix:<(cont)>, :prec($chaining)); trait_mod:(&infix:<<"\x220B">>, :prec($chaining)); trait_mod:(&infix:<<"\x220C">>, :prec($chaining)); trait_mod:(&infix:<<(<)>>, :prec($chaining)); trait_mod:(&infix:<<"\x2282">>, :prec($chaining)); trait_mod:(&infix:<<"\x2284">>, :prec($chaining)); trait_mod:(&infix:<<(>)>>, :prec($chaining)); trait_mod:(&infix:<<"\x2283">>, :prec($chaining)); trait_mod:(&infix:<<"\x2285">>, :prec($chaining)); trait_mod:(&infix:<<(<=)>>, :prec($chaining)); trait_mod:(&infix:<<"\x2286">>, :prec($chaining)); trait_mod:(&infix:<<"\x2288">>, :prec($chaining)); trait_mod:(&infix:<<(>=)>>, :prec($chaining)); trait_mod:(&infix:<<"\x2287">>, :prec($chaining)); trait_mod:(&infix:<<"\x2289">>, :prec($chaining)); trait_mod:(&infix:<<(<+)>>, :prec($chaining)); trait_mod:(&infix:<<"\x227C">>, :prec($chaining)); trait_mod:(&infix:<<(>+)>>, :prec($chaining)); trait_mod:(&infix:<<"\x227D">>, :prec($chaining)); trait_mod:(&infix:<..>, :prec($structural)); trait_mod:(&infix:<^..>, :prec($structural)); trait_mod:(&infix:<..^>, :prec($structural)); trait_mod:(&infix:<^..^>, :prec($structural)); trait_mod:(&infix:, :prec($structural)); trait_mod:(&infix:, :prec($structural)); trait_mod:(&infix:, :prec($structural)); trait_mod:(&infix:, :prec($structural)); } rakudo-2013.12/src/core/PseudoStash.pm0000664000175000017500000001627112232021472017124 0ustar moritzmoritzmy class X::Bind { ... } my class X::Caller::NotDynamic { ... } my class PseudoStash is EnumMap { has Mu $!ctx; has int $!mode; # Lookup modes. my int constant PICK_CHAIN_BY_NAME = 0; my int constant STATIC_CHAIN = 1; my int constant DYNAMIC_CHAIN = 2; my int constant PRECISE_SCOPE = 4; my int constant REQUIRE_DYNAMIC = 8; method new() { my $obj := nqp::create(self); my $ctx := nqp::ctxcaller(nqp::ctx()); nqp::bindattr($obj, PseudoStash, '$!ctx', $ctx); nqp::bindattr($obj, EnumMap, '$!storage', nqp::ctxlexpad($ctx)); $obj } my %pseudoers = 'MY' => sub ($cur) { my $stash := nqp::clone($cur); nqp::bindattr_i($stash, PseudoStash, '$!mode', PRECISE_SCOPE); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('MY')), $stash); }, 'CORE' => sub ($cur) { my Mu $ctx := nqp::getattr(nqp::decont($cur), PseudoStash, '$!ctx'); until nqp::existskey(nqp::ctxlexpad($ctx), '!CORE_MARKER') { $ctx := nqp::ctxouter($ctx); } my $stash := nqp::create(PseudoStash); nqp::bindattr($stash, EnumMap, '$!storage', nqp::ctxlexpad($ctx)); nqp::bindattr($stash, PseudoStash, '$!ctx', $ctx); nqp::bindattr_i($stash, PseudoStash, '$!mode', PRECISE_SCOPE); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('CORE')), $stash); }, 'CALLER' => sub ($cur) { my Mu $ctx := nqp::ctxcaller( nqp::getattr(nqp::decont($cur), PseudoStash, '$!ctx')); my $stash := nqp::create(PseudoStash); nqp::bindattr($stash, EnumMap, '$!storage', nqp::ctxlexpad($ctx)); nqp::bindattr($stash, PseudoStash, '$!ctx', $ctx); nqp::bindattr_i($stash, PseudoStash, '$!mode', PRECISE_SCOPE +| REQUIRE_DYNAMIC); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('CALLER')), $stash); }, 'OUTER' => sub ($cur) { my Mu $ctx := nqp::ctxouter( nqp::getattr(nqp::decont($cur), PseudoStash, '$!ctx')); my $stash := nqp::create(PseudoStash); nqp::bindattr($stash, EnumMap, '$!storage', nqp::ctxlexpad($ctx)); nqp::bindattr($stash, PseudoStash, '$!ctx', $ctx); nqp::bindattr_i($stash, PseudoStash, '$!mode', PRECISE_SCOPE); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('OUTER')), $stash); }, 'DYNAMIC' => sub ($cur) { my $stash := nqp::clone($cur); nqp::bindattr_i($stash, PseudoStash, '$!mode', DYNAMIC_CHAIN); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('DYNAMIC')), $stash); }, 'UNIT' => sub ($cur) { my Mu $ctx := nqp::getattr(nqp::decont($cur), PseudoStash, '$!ctx'); until nqp::existskey(nqp::ctxlexpad($ctx), '!UNIT_MARKER') { $ctx := nqp::ctxouter($ctx); } my $stash := nqp::create(PseudoStash); nqp::bindattr($stash, EnumMap, '$!storage',nqp::ctxlexpad($ctx)); nqp::bindattr($stash, PseudoStash, '$!ctx', $ctx); nqp::bindattr_i($stash, PseudoStash, '$!mode', PRECISE_SCOPE); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('UNIT')), $stash); }, 'SETTING' => sub ($cur) { # Same as UNIT, but go a little further out (two steps, for # internals reasons). my Mu $ctx := nqp::getattr(nqp::decont($cur), PseudoStash, '$!ctx'); until nqp::existskey(nqp::ctxlexpad($ctx), '!UNIT_MARKER') { $ctx := nqp::ctxouter($ctx); } $ctx := nqp::ctxouter(nqp::ctxouter($ctx)); my $stash := nqp::create(PseudoStash); nqp::bindattr($stash, EnumMap, '$!storage', nqp::ctxlexpad($ctx)); nqp::bindattr($stash, PseudoStash, '$!ctx', $ctx); nqp::bindattr_i($stash, PseudoStash, '$!mode', PRECISE_SCOPE); nqp::setwho( Metamodel::ModuleHOW.new_type(:name('UNIT')), $stash); }, 'OUR' => sub ($cur) { nqp::getlexrel( nqp::getattr(nqp::decont($cur), PseudoStash, '$!ctx'), '$?PACKAGE') }; method at_key($key is copy) is rw { $key = $key.Str; my Mu $nkey := nqp::unbox_s($key); if %pseudoers.exists_key($key) { %pseudoers{$key}(self) } elsif nqp::bitand_i($!mode, PRECISE_SCOPE) { my Mu $store := nqp::getattr(self, EnumMap, '$!storage'); my Mu $res := nqp::existskey($store, $nkey) ?? nqp::atkey($store, $nkey) !! Any; if !($res =:= Any) && nqp::bitand_i($!mode, REQUIRE_DYNAMIC) { if !$res.VAR.dynamic { X::Caller::NotDynamic.new( symbol => $key, ).throw; } } $res; } elsif nqp::bitand_i($!mode, nqp::bitor_i(DYNAMIC_CHAIN, PICK_CHAIN_BY_NAME)) && substr($key, 1, 1) eq '*' { my $found := nqp::getlexreldyn( nqp::getattr(self, PseudoStash, '$!ctx'), $nkey); nqp::isnull($found) ?? Any !! $found } else { my $found := nqp::getlexrel( nqp::getattr(self, PseudoStash, '$!ctx'), $nkey); nqp::isnull($found) ?? Any !! $found } } method bind_key($key is copy, \value) { $key = $key.Str; if %pseudoers.exists_key($key) { X::Bind.new(target => "pseudo-package $key").throw; } elsif nqp::bitand_i($!mode, PRECISE_SCOPE) { my Mu $store := nqp::getattr(self, EnumMap, '$!storage'); nqp::bindkey($store, nqp::unbox_s($key), value) } elsif nqp::bitand_i($!mode, nqp::bitor_i(DYNAMIC_CHAIN, PICK_CHAIN_BY_NAME)) && substr($key, 1, 1) eq '*' { die "Binding to dynamic variables not yet implemented"; } else { die "This case of binding is not yet implemented"; } } method exists_key($key is copy) { $key = $key.Str; if %pseudoers.exists_key($key) { True } elsif nqp::bitand_i($!mode, PRECISE_SCOPE) { nqp::p6bool(nqp::existskey( nqp::getattr(self, EnumMap, '$!storage'), nqp::unbox_s($key))) } elsif nqp::bitand_i($!mode, nqp::bitor_i(DYNAMIC_CHAIN, PICK_CHAIN_BY_NAME)) && substr($key, 1, 1) eq '*' { nqp::isnull( nqp::getlexreldyn( nqp::getattr(self, PseudoStash, '$!ctx'), nqp::unbox_s($key))) ?? False !! True } else { nqp::isnull( nqp::getlexrel( nqp::getattr(self, PseudoStash, '$!ctx'), nqp::unbox_s($key))) ?? False !! True } } } rakudo-2013.12/src/core/QuantHash.pm0000664000175000017500000000040012224263172016547 0ustar moritzmoritzmy role QuantHash does Associative { method Int ( --> Int) { self.total.Int } method Num ( --> Num) { self.total.Num } method Numeric ( --> Numeric) { self.total.Numeric } method Real ( --> Real) { self.total.Real } } rakudo-2013.12/src/core/Range.pm0000664000175000017500000001644612224263172015730 0ustar moritzmoritzmy class X::Range::InvalidArg { ... } my class Range is Iterable is Cool does Positional { has $.min; has $.max; has $.excludes_min; has $.excludes_max; proto method new(|) { * } # The order of "method new" declarations matters here, to ensure # appropriate candidate tiebreaking when mixed type arguments # are present (e.g., Range,Whatever or Real,Range). multi method new(Range $min, $max, :$excludes_min, :$excludes_max) { X::Range::InvalidArg.new(:got($min)).throw; } multi method new($min, Range $max, :$excludes_min, :$excludes_max) { X::Range::InvalidArg.new(:got($max)).throw; } multi method new(Whatever $min, Whatever $max, :$excludes_min, :$excludes_max) { fail "*..* is not a valid range"; } multi method new(Whatever $min, $max, :$excludes_min, :$excludes_max) { nqp::create(self).BUILD(-$Inf, $max, $excludes_min, $excludes_max) } multi method new($min, Whatever $max, :$excludes_min, :$excludes_max) { nqp::create(self).BUILD($min, $Inf, $excludes_min, $excludes_max) } multi method new(Real $min, $max, :$excludes_min, :$excludes_max) { nqp::create(self).BUILD($min, $max.Real, $excludes_min, $excludes_max) } multi method new($min is copy, $max, :$excludes_min, :$excludes_max) { $min = +$min if $min ~~ any(List|Match|Parcel); nqp::create(self).BUILD($min, $max, $excludes_min, $excludes_max) } submethod BUILD($min, $max, $excludes_min, $excludes_max) { $!min = $min; $!max = $max; $!excludes_min = $excludes_min.Bool; $!excludes_max = $excludes_max.Bool; self; } method flat() { nqp::p6list(nqp::list(self), List, Bool::True) } method infinite() { nqp::p6bool(nqp::istype($!max, Num)) && $!max eq 'Inf' } method iterator() { self } method list() { self.flat } method bounds() { ($!min, $!max) } multi method ACCEPTS(Range:D: Mu \topic) { (topic cmp $!min) > -(!$!excludes_min) and (topic cmp $!max) < +(!$!excludes_max) } multi method ACCEPTS(Range:D: Range \topic) { (topic.min > $!min || topic.min == $!min && !(!topic.excludes_min && $!excludes_min)) && (topic.max < $!max || topic.max == $!max && !(!topic.excludes_max && $!excludes_max)) } method reify($n = 10) { my $value = $!excludes_min ?? $!min.succ !! $!min; # Iterating a Str range delegates to iterating a sequence. if Str.ACCEPTS($value) { return $value after $!max ?? () !! SEQUENCE($value, $!max, :exclude_end($!excludes_max)).iterator.reify($n) } my $count; if nqp::istype($n, Whatever) { $count = self.infinite ?? 10 !! $Inf; } else { $count = $n.Num; fail "request for infinite elements from range" if $count == $Inf && self.infinite; } my $cmpstop = $!excludes_max ?? 0 !! 1; my $realmax = nqp::istype($!min, Numeric) && !nqp::istype($!max, Callable) && !nqp::istype($!max, Whatever) ?? $!max.Numeric !! $!max; # Pre-size the buffer, to avoid reallocations. my Mu $rpa := nqp::list(); nqp::setelems($rpa, $count == $Inf ?? 256 !! $count.Int); nqp::setelems($rpa, 0); if nqp::istype($value, Int) && nqp::istype($!max, Int) && !nqp::isbig_I(nqp::decont $!max) || nqp::istype($value, Num) { # optimized for int/num ranges $value = $value.Num; my $max = $!max.Num; my $box_int = nqp::p6bool(nqp::istype($!min, Int)); my num $nvalue = $value; my num $ncount = $count; my num $nmax = $max; my int $icmpstop = $cmpstop; my int $ibox_int = $box_int; nqp::while( (nqp::isgt_n($ncount, 0e0) && nqp::islt_i(nqp::cmp_n($nvalue, $nmax), $icmpstop)), nqp::stmts( nqp::push($rpa, $ibox_int ?? nqp::p6box_i($nvalue) !! nqp::p6box_n($nvalue)), ($nvalue = nqp::add_n($nvalue, 1e0)), ($ncount = nqp::sub_n($ncount, 1e0)) )); $value = nqp::p6box_i($nvalue); } else { (nqp::push($rpa, $value++); $count--) while $count > 0 && ($value cmp $realmax) < $cmpstop; } if ($value cmp $!max) < $cmpstop { nqp::push($rpa, ($value.succ cmp $!max < $cmpstop) ?? nqp::create(self).BUILD($value, $!max, 0, $!excludes_max) !! $value); } nqp::p6parcel($rpa, nqp::null()); } method at_pos($pos) { self.flat.at_pos($pos) } multi method perl(Range:D:) { $.min.perl ~ ('^' if $.excludes_min) ~ '..' ~ ('^' if $.excludes_max) ~ $.max.perl } proto method roll(|) { * } multi method roll(Range:D: Whatever) { gather loop { take self.roll } } multi method roll(Range:D:) { return self.list.roll unless nqp::istype($!min, Int) && nqp::istype($!max, Int); my Int:D $least = $!excludes_min ?? $!min + 1 !! $!min; my Int:D $elems = 1 + ($!excludes_max ?? $!max - 1 !! $!max) - $least; $elems ?? ($least + nqp::rand_I(nqp::decont($elems), Int)) !! Any; } multi method roll(Cool $num as Int) { return self.list.roll($num) unless nqp::istype($!min, Int) && nqp::istype($!max, Int); return self.roll if $num == 1; my int $n = nqp::unbox_i($num); gather loop (my int $i = 0; $i < $n; $i = $i + 1) { take self.roll; } } proto method pick(|) { * } multi method pick() { self.roll }; multi method pick(Whatever) { self.list.pick(*) }; multi method pick(Cool $n as Int) { return self.list.pick($n) unless nqp::istype($!min, Int) && nqp::istype($!max, Int); return self.roll if $n == 1; my Int:D $least = $!excludes_min ?? $!min + 1 !! $!min; my Int:D $elems = 1 + ($!excludes_max ?? $!max - 1 !! $!max) - $least; return self.list.pick($n) unless $elems > 3 * $n; my %seen; my int $i_n = nqp::unbox_i($n); gather while $i_n > 0 { my Int $x = $least + nqp::rand_I(nqp::decont($elems), Int); unless %seen{$x} { %seen{$x} = 1; $i_n = $i_n - 1; take $x; } } } multi method Numeric (Range:D:) { nextsame unless $.max ~~ Numeric and $.min ~~ Numeric; my $diff := $.max - $.min - $.excludes_min; # empty range return 0 if $diff < 0; my $floor := $diff.floor; return $floor + 1 - ($floor == $diff ?? $.excludes_max !! 0); } } sub infix:<..>($min, $max) { Range.new($min, $max) } sub infix:<^..>($min, $max) { Range.new($min, $max, :excludes_min) } sub infix:<..^>($min, $max) { Range.new($min, $max, :excludes_max) } sub infix:<^..^>($min, $max) is pure { Range.new($min, $max, :excludes_min, :excludes_max) } sub prefix:<^>($max) is pure { Range.new(0, $max.Numeric, :excludes_max) } rakudo-2013.12/src/core/Rational.pm0000664000175000017500000000756512224263172016447 0ustar moritzmoritzmy role Rational[::NuT, ::DeT] does Real { has NuT $.numerator; has DeT $.denominator; multi method WHICH(Rational:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.^name), '|'), nqp::concat( nqp::tostr_I($!numerator), nqp::concat('/', nqp::tostr_I($!denominator)) ) ), ObjAt ); } method new(NuT \nu = 0, DeT \de = 1) { my $new := nqp::create(self); my $gcd := nu gcd de; my $numerator = nu div $gcd; my $denominator = de div $gcd; if $denominator < 0 { $numerator = -$numerator; $denominator = -$denominator; } nqp::bindattr($new, self.WHAT, '$!numerator', nqp::decont($numerator)); nqp::bindattr($new, self.WHAT, '$!denominator', nqp::decont($denominator)); $new; } method nude() { $!numerator, $!denominator } method Num() { $!denominator == 0 ?? ($!numerator < 0 ?? -$Inf !! $Inf) !! nqp::p6box_n(nqp::div_In( nqp::decont($!numerator), nqp::decont($!denominator) )); } method floor(Rational:D:) returns Int:D { #?if !parrot # correct formula $!denominator == 1 ?? $!numerator !! $!numerator div $!denominator #?endif #?if parrot # incorrect formula needed for NQP Parrot's broken div $!denominator == 1 ?? $!numerator !! $!numerator < 0 ?? ($!numerator div $!denominator - 1) # XXX because div for negati !! $!numerator div $!denominator #?endif } method ceiling(Rational:D:) returns Int:D { #?if !parrot # correct formula $!denominator == 1 ?? $!numerator !! ($!numerator div $!denominator + 1) #?endif #?if parrot # incorrect formula needed for NQP Parrot's broken div $!denominator == 1 ?? $!numerator !! $!numerator < 0 ?? ($!numerator div $!denominator) # XXX should be +1, but div is buggy !! ($!numerator div $!denominator + 1) #?endif } method Int() { self.truncate } method Bridge() { self.Num } multi method Str(::?CLASS:D:) { my $s = $!numerator < 0 ?? '-' !! ''; my $r = self.abs; my $i = $r.floor; $r -= $i; $s ~= $i; if $r { $s ~= '.'; my $want = $!denominator < 100_000 ?? 6 !! $!denominator.Str.chars + 1; my $f = ''; while $r and $f.chars < $want { $r *= 10; $i = $r.floor; $f ~= $i; $r -= $i; } $f++ if 2 * $r >= 1; $s ~= $f; } $s; } method base($base) { my $s = $!numerator < 0 ?? '-' !! ''; my $r = self.abs; my $i = $r.floor; $r -= $i; $s ~= $i.base($base); if $r { my $want = $!denominator < $base**6 ?? 6 !! $!denominator.log($base).ceiling + 1; my @f; while $r and @f < $want { $r *= $base; $i = $r.floor; push @f, $i; $r -= $i; } if 2 * $r >= 1 { for @f-1 ... 0 -> $x { last if ++@f[$x] < $base; @f[$x] = 0; $s ~= ($i+1).base($base) if $x == 0; # never happens? } } $s ~= '.'; $s ~= (0..9,'A'..'Z')[@f].join; } $s; } method succ { self.new($!numerator + $!denominator, $!denominator); } method pred { self.new($!numerator - $!denominator, $!denominator); } method norm() { self } } rakudo-2013.12/src/core/Rat.pm0000664000175000017500000001372712224263172015421 0ustar moritzmoritz# XXX: should be Rational[Int, UInt64] my class Rat is Cool does Rational[Int, Int] { method Rat (Rat:D: Real $?) { self } method FatRat(Rat:D: Real $?) { FatRat.new($.numerator, $.denominator); } multi method perl(Rat:D:) { my $d = $.denominator; return $.numerator ~ '.0' if $d == 1; unless $d == 0 { $d div= 5 while $d %% 5; $d div= 2 while $d %% 2; } ($d == 1) ?? self.Str !! '<' ~ $.numerator ~ '/' ~ $.denominator ~ '>'; } } my class FatRat is Cool does Rational[Int, Int] { method FatRat(FatRat:D: Real $?) { self } method Rat (FatRat:D: Real $?) { $.denominator < $UINT64_UPPER ?? Rat.new($.numerator, $.denominator) !! fail "Cannot convert from FatRat to Rat because denominator is too big"; } multi method perl(FatRat:D:) { "FatRat.new($.numerator, $.denominator)"; } } sub DIVIDE_NUMBERS(Int:D \nu, Int:D \de, $t1, $t2) { my Int $gcd := nu gcd de; my Int $numerator = nu div $gcd; my Int $denominator = de div $gcd; if $denominator < 0 { $numerator = -$numerator; $denominator = -$denominator; } if nqp::istype($t1, FatRat) || nqp::istype($t2, FatRat) { my $r := nqp::create(FatRat); nqp::bindattr($r, FatRat, '$!numerator', nqp::decont($numerator)); nqp::bindattr($r, FatRat, '$!denominator', nqp::decont($denominator)); $r; } elsif $denominator < $UINT64_UPPER { my $r := nqp::create(Rat); nqp::bindattr($r, Rat, '$!numerator', nqp::decont($numerator)); nqp::bindattr($r, Rat, '$!denominator', nqp::decont($denominator)); $r; } else { nqp::p6box_n(nqp::div_In( nqp::decont($numerator), nqp::decont($denominator) ) ); } } multi prefix:<->(Rat \a) { Rat.new(-a.numerator, a.denominator); } multi prefix:<->(FatRat \a) { FatRat.new(-a.numerator, a.denominator); } multi infix:<+>(Rational \a, Rational \b) { my Int $gcd := a.denominator gcd b.denominator; DIVIDE_NUMBERS( (a.numerator * (b.denominator div $gcd) + b.numerator * (a.denominator div $gcd)), ((a.denominator div $gcd) * b.denominator), a, b, ); } multi sub infix:<+>(Rational \a, Int \b) { DIVIDE_NUMBERS( (a.numerator + b * a.denominator), a.denominator, a, b, ); } multi sub infix:<+>(Int \a, Rational \b) { DIVIDE_NUMBERS( (a * b.denominator + b.numerator), b.denominator, a, b, ); } multi sub infix:<->(Rational \a, Rational \b) { my Int $gcd = a.denominator gcd b.denominator; DIVIDE_NUMBERS a.numerator * (b.denominator div $gcd) - b.numerator * (a.denominator div $gcd), (a.denominator div $gcd) * b.denominator, a, b; } multi sub infix:<->(Rational \a, Int \b) { DIVIDE_NUMBERS a.numerator - b * a.denominator, a.denominator, a, b; } multi sub infix:<->(Int \a, Rational \b) { DIVIDE_NUMBERS a * b.denominator - b.numerator, b.denominator, a, b; } multi sub infix:<*>(Rational \a, Rational \b) { DIVIDE_NUMBERS a.numerator * b.numerator, a.denominator * b.denominator, a, b; } multi sub infix:<*>(Rational \a, Int \b) { DIVIDE_NUMBERS a.numerator * b, a.denominator, a, b; } multi sub infix:<*>(Int \a, Rational \b) { DIVIDE_NUMBERS a * b.numerator, b.denominator, a, b; } multi sub infix:(Rational \a, Rational \b) { DIVIDE_NUMBERS a.numerator * b.denominator, a.denominator * b.numerator, a, b; } multi sub infix:(Rational \a, Int \b) { DIVIDE_NUMBERS a.numerator, a.denominator * b, a, b; } multi sub infix:(Int \a, Rational \b) { DIVIDE_NUMBERS b.denominator * a, b.numerator, a, b; } multi sub infix:(Int \a, Int \b) { DIVIDE_NUMBERS a, b, a, b } multi sub infix:<**>(Rational \a, Int \b) { DIVIDE_NUMBERS a.numerator ** b, a.denominator ** b, a, b; } multi sub infix:<==>(Rational:D \a, Rational:D \b) { a.numerator == b.numerator && a.denominator == b.denominator } multi sub infix:<==>(Rational:D \a, Int:D \b) { a.numerator == b && a.denominator == 1 } multi sub infix:<==>(Int:D \a, Rational:D \b) { a == b.numerator && b.denominator == 1; } multi sub infix:«<»(Rational:D \a, Rational:D \b) { a.numerator * b.denominator < b.numerator * a.denominator } multi sub infix:«<»(Rational:D \a, Int:D \b) { a.numerator < b * a.denominator } multi sub infix:«<»(Int:D \a, Rational:D \b) { a * b.denominator < b.numerator } multi sub infix:«<=»(Rational:D \a, Rational:D \b) { a.numerator * b.denominator <= b.numerator * a.denominator } multi sub infix:«<=»(Rational:D \a, Int:D \b) { a.numerator <= b * a.denominator } multi sub infix:«<=»(Int:D \a, Rational:D \b) { a * b.denominator <= b.numerator } multi sub infix:«>»(Rational:D \a, Rational:D \b) { a.numerator * b.denominator > b.numerator * a.denominator } multi sub infix:«>»(Rational:D \a, Int:D \b) { a.numerator > b * a.denominator } multi sub infix:«>»(Int:D \a, Rational:D \b) { a * b.denominator > b.numerator } multi sub infix:«>=»(Rational:D \a, Rational:D \b) { a.numerator * b.denominator >= b.numerator * a.denominator } multi sub infix:«>=»(Rational:D \a, Int:D \b) { a.numerator >= b * a.denominator } multi sub infix:«>=»(Int:D \a, Rational:D \b) { a * b.denominator >= b.numerator } multi sub infix:«<=>»(Rational:D \a, Rational:D \b) { a.numerator * b.denominator <=> b.numerator * a.denominator } multi sub infix:«<=>»(Rational:D \a, Int:D \b) { a.numerator <=> b * a.denominator } multi sub infix:«<=>»(Int:D \a, Rational:D \b) { a * b.denominator <=> b.numerator } rakudo-2013.12/src/core/Real.pm0000664000175000017500000001212612224263172015546 0ustar moritzmoritzmy class Complex { ... } my role Real does Numeric { method Rat(Real:D: Real $epsilon = 1.0e-6) { self.Bridge.Rat($epsilon) } method abs() { self < 0 ?? -self !! self } proto method sign(|) {*} multi method sign(Real:U:) { Mu } multi method sign(Real:D:) { self < 0 ?? -1 !! self == 0 ?? 0 !! 1 } method conj(Real:D:) { self } method sqrt() { self.Bridge.sqrt } method rand() { self.Bridge.rand } method sin() { self.Bridge.sin } method asin() { self.Bridge.asin } method cos() { self.Bridge.cos } method acos() { self.Bridge.acos } method tan() { self.Bridge.tan } method atan() { self.Bridge.atan } proto method atan2(|) {*} multi method atan2(Real $x = 1e0) { self.Bridge.atan2($x.Bridge) } multi method atan2(Cool $x = 1e0) { self.Bridge.atan2($x.Numeric.Bridge) } method sec() { self.Bridge.sec } method asec() { self.Bridge.asec } method cosec() { self.Bridge.cosec } method acosec() { self.Bridge.acosec } method cotan() { self.Bridge.cotan } method acotan() { self.Bridge.acotan } method sinh() { self.Bridge.sinh } method asinh() { self.Bridge.asinh } method cosh() { self.Bridge.cosh } method acosh() { self.Bridge.acosh } method tanh() { self.Bridge.tanh } method atanh() { self.Bridge.atanh } method sech() { self.Bridge.sech } method asech() { self.Bridge.asech } method cosech() { self.Bridge.cosech } method acosech() { self.Bridge.acosech } method cotanh() { self.Bridge.cotanh } method acotanh() { self.Bridge.acotanh } method floor() { self.Bridge.floor } method ceiling() { self.Bridge.ceiling } # cannot use '0.5' here, because Rat isn't initialized yet method round($scale as Real = 1) { (self / $scale + 1/2).floor * $scale } method unpolar(Real $angle) { Complex.new(self * $angle.cos, self * $angle.sin); } method cis() { Complex.new(self.cos, self.sin); } method Complex() { Complex.new(self.Num, 0e0) } proto method log(|) {*} multi method log(Real:D: ) { self.Bridge.log } multi method log(Real:D: Real $base) { self.Bridge.log($base.Bridge) } proto method exp(|) {*} multi method exp(Real:D: ) { self.Bridge.exp } method truncate(Real:D:) { self == 0 ?? 0 !! self < 0 ?? self.ceiling !! self.floor } method isNaN { Bool::False } method base(Int:D $base) { my Int $int_part = self.Int; my $frac = abs(self - $int_part); my @frac_digits; my @conversion = qw/0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T/; # pretty arbitrary precision limit for now # but better than endless loops my $limit = 1e8.log($base.Num).Int; for ^$limit { last if $frac == 0; $frac = $frac * $base; push @frac_digits, @conversion[$frac.Int]; $frac = $frac - $frac.Int; } my Str $r = $int_part.base($base) ~ '.' ~ @frac_digits.join(''); # if $int_part is 0, $int_part.base doesn't see the sign of self $int_part == 0 && self < 0 ?? '-' ~ $r !! $r; } method Real(Real:D:) { self } method Bridge(Real:D:) { self.Num } method Int(Real:D:) { self.Bridge.Int } method Num(Real:D:) { self.Bridge.Num } multi method Str(Real:D:) { self.Bridge.Str } } proto sub cis($) {*} multi sub cis(Real $a) { $a.cis } multi infix:<+>(Real \a, Real \b) { a.Bridge + b.Bridge } multi infix:<->(Real \a, Real \b) { a.Bridge - b.Bridge } multi infix:<*>(Real \a, Real \b) { a.Bridge * b.Bridge } multi infix:(Real \a, Real \b) { a.Bridge / b.Bridge } multi infix:<%>(Real \a, Real \b) { a.Bridge % b.Bridge } multi infix:<**>(Real \a, Real \b) { a.Bridge ** b.Bridge } multi infix:«<=>»(Real \a, Real \b) { a.Bridge <=> b.Bridge } multi infix:<==>(Real \a, Real \b) { a.Bridge == b.Bridge } multi infix:«<»(Real \a, Real \b) { a.Bridge < b.Bridge } multi infix:«<=»(Real \a, Real \b) { a.Bridge <= b.Bridge } multi infix:«>»(Real \a, Real \b) { a.Bridge > b.Bridge } multi infix:«>=»(Real \a, Real \b) { a.Bridge >= b.Bridge } multi prefix:<->(Real \a) { -a.Bridge } # NOTE: According to the spec, infix: is "Not coercive, # so fails on differing types." Thus no casts here. proto sub infix:($, $) {*} multi sub infix:(Real $a, Real $b) { $a - ($a div $b) * $b; } multi sub abs(Real \a) { a < 0 ?? -a !! a; } proto sub truncate($) {*} multi sub truncate(Real:D $x) { $x.truncate } multi sub truncate(Cool:D $x) { $x.Numeric.truncate } proto sub atan2($, $?) { * } multi sub atan2(Real \a, Real \b = 1e0) { a.Bridge.atan2(b.Bridge) } # should really be (Cool, Cool), and then (Cool, Real) and (Real, Cool) # candidates, but since Int both conforms to Cool and Real, we'd get lots # of ambiguous dispatches. So just go with (Any, Any) for now. multi sub atan2( \a, \b = 1e0) { a.Numeric.atan2(b.Numeric) } proto sub unpolar($, $) {*} multi sub unpolar(Real $mag, Real $angle) { $mag.unpolar($angle) } rakudo-2013.12/src/core/Regex.pm0000664000175000017500000000273112224263172015736 0ustar moritzmoritzmy class Regex { # declared in BOOTSTRAP # class Regex is Method { # has Mu $!caps; # has Mu $!nfa; # has Mu $!alt_nfas multi method ACCEPTS(Regex:D \SELF: Mu \topic) { my $dollar_slash := nqp::getlexrelcaller( nqp::ctxcaller(nqp::ctxcaller(nqp::ctx())), '$/'); $dollar_slash = SELF.(Cursor."!cursor_init"(topic, :c(0))).MATCH_SAVE; } multi method ACCEPTS(Regex:D \SELF: @a) { my $dollar_slash := nqp::getlexrelcaller( nqp::ctxcaller(nqp::ctxcaller(nqp::ctx())), '$/'); for @a { $dollar_slash = SELF.(Cursor.'!cursor_init'($_, :c(0))).MATCH_SAVE; return $dollar_slash if $dollar_slash; } Nil; } multi method ACCEPTS(Regex:D \SELF: %h) { my $dollar_slash := nqp::getlexrelcaller( nqp::ctxcaller(nqp::ctxcaller(nqp::ctx())), '$/'); for %h.keys { $dollar_slash = SELF.(Cursor.'!cursor_init'($_, :c(0))).MATCH_SAVE; return $dollar_slash if $dollar_slash; } Nil; } multi method Bool(Regex:D:) { my $dollar_slash := nqp::getlexrelcaller( nqp::ctxcaller(nqp::ctxcaller(nqp::ctx())), '$/'); my $dollar_underscore := nqp::getlexrelcaller( nqp::ctxcaller(nqp::ctxcaller(nqp::ctx())), '$_'); $dollar_slash = $dollar_underscore.match(self); $dollar_slash.Bool() } } rakudo-2013.12/src/core/Routine.pm0000664000175000017500000000721312255230273016311 0ustar moritzmoritzmy class X::Routine::Unwrap { ... } my role HardRoutine { method soft() { False } } my role SoftRoutine { method soft() { True } } my class Routine { # declared in BOOTSTRAP # class Routine is Block { # has Mu $!dispatchees; # has Mu $!dispatcher_cache; # has Mu $!dispatcher; # has int $!rw; # has Mu $!inline_info; # has int $!yada; # has Mu $!package; # has int $!onlystar; # has Mu $!dispatch_order; # has Mu $!dispatch_cache; method of() { self.signature.returns } method returns() { self.signature.returns } method rw() { $!rw } method onlystar() { nqp::p6bool($!onlystar) } method assuming($r: *@curried_pos, *%curried_named) { return sub CURRIED (*@pos, *%named) { $r(|@curried_pos, |@pos, |%curried_named, |%named) } } method candidates() { self.is_dispatcher ?? nqp::hllize($!dispatchees) !! (self,) } method cando(Capture $c) { my $disp; if self.is_dispatcher { $disp := self; } else { $disp := nqp::create(self); nqp::bindattr($disp, Routine, '$!dispatchees', nqp::list(self)); } # Call this lexical sub to get rid of 'self' in the signature. sub checker(|) { nqp::hllize($disp.find_best_dispatchee(nqp::usecapture(), 1)) } checker(|$c); } method multi() { self.dispatcher.defined } multi method perl(Routine:D:) { my $perl = self.^name.lc(); if self.name() -> $n { $perl ~= " $n"; } $perl ~= self.signature().perl.substr(1); $perl ~= ' { ... }'; $perl } method soft() { Mu } method wrap(&wrapper) { my class WrapHandle { has $!dispatcher; has $!wrapper; method restore() { nqp::p6bool($!dispatcher.remove($!wrapper)); } } my role Wrapped { has $!dispatcher; method UNSHIFT_WRAPPER(&wrapper) { # Add candidate. $!dispatcher := WrapDispatcher.new() unless nqp::isconcrete($!dispatcher); $!dispatcher.add(&wrapper); # Return a handle. my $handle := nqp::create(WrapHandle); nqp::bindattr($handle, WrapHandle, '$!dispatcher', $!dispatcher); nqp::bindattr($handle, WrapHandle, '$!wrapper', &wrapper); $handle } method postcircumfix:<( )>($c) { $!dispatcher.enter(|$c); } method soft() { True } } # We can't wrap a hardened routine (that is, one that's been # marked inlinable). if nqp::istype(self, HardRoutine) { die "Cannot wrap a HardRoutine, since it may have been inlined; " ~ "use the 'soft' pragma to avoid marking routines as hard."; } # If we're not wrapped already, do the initial dispatcher # creation. unless nqp::istype(self, Wrapped) { my $orig = self.clone(); self does Wrapped; self.UNSHIFT_WRAPPER($orig); } # Add this wrapper. self.UNSHIFT_WRAPPER(&wrapper); } method unwrap($handle) { $handle.can('restore') && $handle.restore() || X::Routine::Unwrap.new.throw } method yada() { nqp::p6bool(nqp::getattr_i(self, Routine, '$!yada')) } method package() { $!package } } rakudo-2013.12/src/core/Scalar.pm0000664000175000017500000000106612224263172016071 0ustar moritzmoritzmy class Scalar { # declared in BOOTSTRAP # class Scalar is Any { # has Mu $!descriptor; # has Mu $!value; # has Mu $!whence; method name() { my $d := $!descriptor; nqp::isnull($d) ?? Str !! $d.name() } method of() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! $d.of; } method default() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! $d.default; } method dynamic() { my $d := $!descriptor; nqp::isnull($d) ?? Mu !! so $d.dynamic; } } rakudo-2013.12/src/core/Seq.pm0000664000175000017500000000003112224263172015403 0ustar moritzmoritzmy class Seq is List { } rakudo-2013.12/src/core/SetHash.pm0000664000175000017500000000173112255230273016222 0ustar moritzmoritzmy class SetHash does Setty { method at_key($k --> Bool) { Proxy.new( FETCH => { so %!elems.exists_key($k.WHICH); }, STORE => -> $, $value { if $value { %!elems{$k.WHICH} = $k; } else { %!elems.delete_key($k.WHICH); } so $value; }); } method delete($k) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($k); } method delete_key($k --> Bool) { my $key := $k.WHICH; return False unless %!elems.exists_key($key); %!elems.delete_key($key); True; } method Set (:$view) { if $view { my $set := nqp::create(Set); $set.BUILD( :elems(%!elems) ); $set; } else { Set.new(self.keys); } } method SetHash { self } } rakudo-2013.12/src/core/set_operators.pm0000664000175000017500000001474212224263172017562 0ustar moritzmoritz proto sub infix:<(elem)>($, $ --> Bool) {*} multi sub infix:<(elem)>($a, Any $b --> Bool) { $a (elem) $b.Set(:view); } multi sub infix:<(elem)>($a, Set $b --> Bool) { $b.exists_key($a); } # U+2208 ELEMENT OF only sub infix:<<"\x2208">>($a, $b --> Bool) { $a (elem) $b; } # U+2209 NOT AN ELEMENT OF only sub infix:<<"\x2209">>($a, $b --> Bool) { $a !(elem) $b; } proto sub infix:<(cont)>($, $ --> Bool) {*} multi sub infix:<(cont)>(Any $a, $b --> Bool) { $a.Set(:view) (cont) $b; } multi sub infix:<(cont)>(Set $a, $b --> Bool) { $a.exists_key($b); } # U+220B CONTAINS AS MEMBER only sub infix:<<"\x220B">>($a, $b --> Bool) { $a (cont) $b; } # U+220C DOES NOT CONTAIN AS MEMBER only sub infix:<<"\x220C">>($a, $b --> Bool) { $a !(cont) $b; } only sub infix:<(|)>(**@p) { if @p.grep(Baggy) { my $baghash = BagHash.new; for @p.map(*.Bag(:view)) -> $bag { $baghash{$_} max= $bag{$_} for $bag.keys; } $baghash.Bag(:view); } else { Set.new( @p.map(*.Set(:view).keys) ); } } # U+222A UNION only sub infix:<<"\x222A">>(|p) { infix:<(|)>(|p); } only sub infix:<(&)>(**@p) { return set() unless @p; if @p.grep(Baggy) { my $baghash = @p[0] ~~ BagHash ?? BagHash.new-fp(@p.shift.pairs) !! @p.shift.BagHash; for @p.map(*.Bag(:view)) -> $bag { $bag{$_} ?? $baghash{$_} min= $bag{$_} !! $baghash.delete_key($_) for $baghash.keys; } $baghash.Bag(:view); } else { my $sethash = @p[0] ~~ SetHash ?? SetHash.new(@p.shift.keys) !! @p.shift.SetHash; for @p.map(*.Set(:view)) -> $set { $set{$_} || $sethash.delete_key($_) for $sethash.keys; } $sethash.Set(:view); } } # U+2229 INTERSECTION only sub infix:<<"\x2229">>(|p) { infix:<(&)>(|p); } only sub infix:<(-)>(**@p) { return set() unless @p; if @p[0] ~~ Baggy { my $baghash = @p[0] ~~ BagHash ?? BagHash.new-fp(@p.shift.pairs) !! @p.shift.BagHash; for @p.map(*.Bag(:view)) -> $bag { $bag{$_} < $baghash{$_} ?? $baghash{$_} -= $bag{$_} !! $baghash.delete_key($_) for $baghash.keys; } $baghash.Bag(:view); } else { my $sethash = @p[0] ~~ SetHash ?? SetHash.new(@p.shift.keys) !! @p.shift.SetHash; for @p.map(*.Set(:view)) -> $set { $set{$_} && $sethash.delete_key($_) for $sethash.keys; } $sethash.Set(:view); } } # U+2216 SET MINUS only sub infix:<<"\x2216">>(|p) { infix:<(-)>(|p); } proto sub infix:<(^)>($, $ --> Setty) {*} multi sub infix:<(^)>(Any $a, Any $b --> Setty) { $a.Set(:view) (^) $b.Set(:view); } multi sub infix:<(^)>(Set $a, Set $b --> Setty) { ($a (-) $b) (|) ($b (-) $a); } # U+2296 CIRCLED MINUS only sub infix:<<"\x2296">>($a, $b --> Setty) { $a (^) $b; } # TODO: polymorphic eqv # multi sub infix:(Any $a, Any $b --> Bool) { # $a.Set(:view) eqv $b.Set(:view); # } # multi sub infix:(Setty $a, Setty $b --> Bool) { # $a == $b and so $a.keys.all (elem) $b # } proto sub infix:<<(<=)>>($, $ --> Bool) {*} multi sub infix:<<(<=)>>(Any $a, Any $b --> Bool) { $a.Set(:view) (<=) $b.Set(:view); } multi sub infix:<<(<=)>>(Setty $a, Setty $b --> Bool) { $a <= $b and so $a.keys.all (elem) $b } # U+2286 SUBSET OF OR EQUAL TO only sub infix:<<"\x2286">>($a, $b --> Bool) { $a (<=) $b; } # U+2288 NEITHER A SUBSET OF NOR EQUAL TO only sub infix:<<"\x2288">>($a, $b --> Bool) { $a !(<=) $b; } proto sub infix:<<(<)>>($, $ --> Bool) {*} multi sub infix:<<(<)>>(Any $a, Any $b --> Bool) { $a.Set(:view) (<) $b.Set(:view); } multi sub infix:<<(<)>>(Setty $a, Setty $b --> Bool) { $a < $b and so $a.keys.all (elem) $b; } # U+2282 SUBSET OF only sub infix:<<"\x2282">>($a, $b --> Bool) { $a (<) $b; } # U+2284 NOT A SUBSET OF only sub infix:<<"\x2284">>($a, $b --> Bool) { $a !(<) $b; } proto sub infix:<<(>=)>>($, $ --> Bool) {*} multi sub infix:<<(>=)>>(Any $a, Any $b --> Bool) { $a.Set(:view) (>=) $b.Set(:view); } multi sub infix:<<(>=)>>(Setty $a, Setty $b --> Bool) { $a >= $b and so $b.keys.all (elem) $a; } # U+2287 SUPERSET OF OR EQUAL TO only sub infix:<<"\x2287">>($a, $b --> Bool) { $a (>=) $b; } # U+2289 NEITHER A SUPERSET OF NOR EQUAL TO only sub infix:<<"\x2289">>($a, $b --> Bool) { $a !(>=) $b; } proto sub infix:<<(>)>>($, $ --> Bool) {*} multi sub infix:<<(>)>>(Any $a, Any $b --> Bool) { $a.Set(:view) (>) $b.Set(:view); } multi sub infix:<<(>)>>(Setty $a, Setty $b --> Bool) { $a > $b and so $b.keys.all (elem) $a; } # U+2283 SUPERSET OF only sub infix:<<"\x2283">>($a, $b --> Bool) { $a (>) $b; } # U+2285 NOT A SUPERSET OF only sub infix:<<"\x2285">>($a, $b --> Bool) { $a !(>) $b; } only sub infix:<(.)>(**@p) { my $baghash = @p[0] ~~ BagHash ?? BagHash.new-fp(@p.shift.pairs) !! @p.shift.BagHash; for @p.map(*.Bag(:view)) -> $bag { $bag{$_} ?? $baghash{$_} *= $bag{$_} !! $baghash.delete_key($_) for $baghash.keys; } $baghash.Bag(:view); } # U+228D MULTISET MULTIPLICATION only sub infix:<<"\x228D">>(|p) { infix:<(.)>(|p); } only sub infix:<(+)>(**@p) { return bag() unless @p; my $baghash = @p[0] ~~ BagHash ?? BagHash.new-fp(@p.shift.pairs) !! @p.shift.BagHash; for @p.map(*.Bag(:view)) -> $bag { $baghash{$_} += $bag{$_} for $bag.keys; } $baghash.Bag(:view); } # U+228E MULTISET UNION only sub infix:<<"\x228E">>(|p) { infix:<(+)>(|p); } proto sub infix:<<(<+)>>($, $ --> Bool) {*} multi sub infix:<<(<+)>>(Any $a, Any $b --> Bool) { $a.Bag(:view) (<+) $b.Bag(:view); } multi sub infix:<<(<+)>>(Baggy $a, Baggy $b --> Bool) { so all $a.keys.map({ $a{$_} <= $b{$_} }) } # U+227C PRECEDES OR EQUAL TO only sub infix:<<"\x227C">>($a, $b --> Bool) { $a (<+) $b; } proto sub infix:<<(>+)>>($, $ --> Bool) {*} multi sub infix:<<(>+)>>(Baggy $a, Baggy $b --> Bool) { so all $b.keys.map({ $b{$_} <= $a{$_} }); } multi sub infix:<<(>+)>>(Any $a, Any $b --> Bool) { $a.Bag(:view) (>+) $b.Bag(:view); } # U+227D SUCCEEDS OR EQUAL TO only sub infix:<<"\x227D">>($a, $b --> Bool) { $a (>+) $b; } sub set(*@args --> Set) { Set.new(@args) } sub bag(*@args --> Bag) { Bag.new(|@args) } sub mix(*@args --> Mix) { Mix.new(|@args) } # U+2205 EMPTY SET #constant term:<<"\x2205">> = set(); #Cannot call ACCEPTS; no signatures match rakudo-2013.12/src/core/Set.pm0000664000175000017500000000177212255230273015423 0ustar moritzmoritzmy class Set does Setty { has Int $!total; has $!WHICH; method total { $!total //= %!elems.elems } submethod WHICH { $!WHICH } submethod BUILD (:%elems) { my @keys := %elems.keys.sort; $!WHICH := self.^name ~ '|' ~ @keys.sort; nqp::bindattr(self, Set, '%!elems', %elems); } method at_key($k --> Bool) { so %!elems.exists_key($k.WHICH); } method delete ($a --> Bool) { # is DEPRECATED doesn't work in settings DEPRECATED("the :delete adverb"); self.delete_key($a); } method delete_key($k --> Bool) is hidden_from_backtrace { X::Immutable.new( method => 'delete_key', typename => self.^name ).throw; } method grab ($count = 1) { X::Immutable.new( method => 'grab', typename => self.^name ).throw; } method grabpairs ($count = 1) { X::Immutable.new( method => 'grabpairs', typename => self.^name ).throw; } method Set { self } method SetHash { SetHash.new(self.keys) } } rakudo-2013.12/src/core/Setty.pm0000664000175000017500000000432312232244553015774 0ustar moritzmoritzmy role Setty does QuantHash { has %!elems; # key.WHICH => key method BUILD (:%!elems) {} method default(--> Bool) { False } method keys { %!elems.values } method values { True xx %!elems.elems } method elems(--> Int) { %!elems.elems } method total(--> Int) { %!elems.elems } method exists ($k --> Bool) { # is DEPRECATED doesn't work in settings DEPRECATED("the :exists adverb"); self.exists_key($k); } method exists_key($k --> Bool) { so ( %!elems && nqp::existskey(%!elems, nqp::unbox_s($k.WHICH)) ); } method Bool { %!elems.Bool } method hash(--> Hash) { my %e; %e{$_} = True for %!elems.values; %e; } method new(*@args --> Setty) { my %e; %e{$_.WHICH} = $_ for @args; self.bless(:elems(%e)); } method new-fp(*@pairs --> Setty) { my %e; for @pairs { when Pair { %e{.key.WHICH} //= $_.key if .value; } default { %e{.WHICH} //= $_; } } self.bless(:elems(%e)); } method ACCEPTS($other) { self.defined ?? $other (<=) self && self (<=) $other !! $other.^does(self); } multi method Str(Setty:D $ : --> Str) { ~ %!elems.values } multi method gist(Setty:D $ : --> Str) { my $name := self.^name; ( $name eq 'Set' ?? 'set' !! "$name.new" ) ~ '(' ~ %!elems.values.map( {.gist} ).join(', ') ~ ')'; } multi method perl(Setty:D $ : --> Str) { my $name := self.^name; ( $name eq 'Set' ?? 'set' !! "$name.new" ) ~ '(' ~ %!elems.values.map( {.perl} ).join(',') ~ ')'; } method list() { %!elems.values } method pairs() { %!elems.values.map({ $_ => True }) } method grab($count = 1) { (%!elems{ %!elems.keys.pick($count) }:delete).list; } method grabpairs($count = 1) { (%!elems{ %!elems.keys.pick($count) }:delete).map( { ($_=>True) } ); } method pick($count = 1) { %!elems.values.pick($count) } method roll($count = 1) { %!elems.values.roll($count) } # TODO: WHICH will require the capability for >1 pointer in ObjAt } rakudo-2013.12/src/core/Signature.pm0000664000175000017500000000503312224263172016623 0ustar moritzmoritzmy class Signature { # declared in BOOTSTRAP # class Signature is Any { # has Mu $!params; # VM's array of parameters # has Mu $!returns; # return type # has Mu $!arity; # cached arity # has Mu $!count; # cached count # has Mu $!code; multi method ACCEPTS(Signature:D: Capture $topic) { nqp::p6bool(nqp::p6isbindable(self, nqp::decont($topic))); } multi method ACCEPTS(Signature:D: @topic) { self.ACCEPTS(@topic.Capture) } multi method ACCEPTS(Signature:D: %topic) { self.ACCEPTS(%topic.Capture) } multi method ACCEPTS(Signature:D: Signature:D $topic) { return False unless $topic.params == self.params; for $topic.params Z self.params -> $t, $s { return False unless $t.type ~~ $s.type; } return True; } method arity() { self.count if nqp::isnull($!arity) || !$!arity.defined; $!arity; } method count() { if nqp::isnull($!count) || !$!count.defined { # calculate the count and arity -- we keep them # cached for when we're called the next time. my $count = 0; my $arity = 0; my Mu $iter := nqp::iterator($!params); my $param; while $iter { $param := nqp::shift($iter); if $param.capture || $param.slurpy && !$param.named { $count = Inf; } elsif $param.positional { $count++; $arity++ unless $param.optional; } } nqp::bindattr(self, Signature, '$!arity', $arity); nqp::bindattr(self, Signature, '$!count', $count); } $!count } method params() { nqp::p6list(nqp::clone($!params), List, Mu); } # XXX TODO: Parameter separators. multi method perl(Signature:D:) { # Opening. my $perl = ':('; # Parameters. my $params = self.params(); my $sep = ''; my int $i = 0; while $i < $params.elems { my $param := $params[$i]; $perl = $perl ~ $sep ~ $param.perl; # this works because methods always have at least one # other parameter, *%_ $sep = ($i == 0 && $param.invocant) ?? ': ' !! ', '; $i = $i + 1; } # Closer. $perl ~ ')' } method returns() { $!returns } } rakudo-2013.12/src/core/Stash.pm0000664000175000017500000000257112224263172015750 0ustar moritzmoritzmy class Stash { # declared in BOOTSTRAP # class Stash is Hash { multi method at_key(Stash:D: $key is copy, :$global_fallback) is rw { my Mu $storage := nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) ?? nqp::getattr(self, EnumMap, '$!storage') !! nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); $key = $key.Str; if nqp::existskey($storage, nqp::unbox_s($key)) { nqp::atkey($storage, nqp::unbox_s($key)) } elsif $global_fallback { nqp::existskey(GLOBAL.WHO, $key) ?? GLOBAL.WHO.at_key($key) !! fail("Could not find symbol '$key'") } else { nqp::p6bindattrinvres(my $v, Scalar, '$!whence', -> { nqp::bindkey($storage, nqp::unbox_s($key), $v) } ) } } method package_at_key(Stash:D: str $key) { my Mu $storage := nqp::defined(nqp::getattr(self, EnumMap, '$!storage')) ?? nqp::getattr(self, EnumMap, '$!storage') !! nqp::bindattr(self, EnumMap, '$!storage', nqp::hash()); if nqp::existskey($storage, nqp::unbox_s($key)) { nqp::atkey($storage, $key) } else { my $pkg := Metamodel::PackageHOW.new_type(:name($key)); $pkg.HOW.compose($pkg); nqp::bindkey($storage, $key, $pkg) } } } rakudo-2013.12/src/core/Stringy.pm0000664000175000017500000000410712224263172016322 0ustar moritzmoritzmy role Stringy { } multi sub infix:(Stringy:D $a, Stringy:D $b) { $a.WHAT === $b.WHAT && ($a cmp $b) == 0 } proto prefix:<~>($) is pure { * } multi prefix:<~>(\a) { a.Stringy } proto infix:<~>($?, $?) is pure { * } multi infix:<~>($x = '') { $x.Stringy } multi infix:<~>(\a, \b) { a.Stringy ~ b.Stringy } proto infix:($?, $?) { * } multi infix:() { fail "No zero-arg meaning for infix:" } multi infix:($x) { $x.Stringy } multi infix:($s, $n) { $s.Stringy x ($n.Int // 0) } proto infix:($?, $?) is pure { * } multi infix:(\a, \b) { a.Stringy cmp b.Stringy } proto infix:($?, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { a.Stringy eq b.Stringy } proto infix:(Mu $?, Mu $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(Mu \a, Mu \b) { a !eq b } proto infix:($?, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { a.Stringy lt b.Stringy } proto infix:($?, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { a.Stringy le b.Stringy } proto infix:($?, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { a.Stringy gt b.Stringy } proto infix:($?, $?) is pure { * } multi infix:($x?) { Bool::True } multi infix:(\a, \b) { a.Stringy ge b.Stringy } proto infix:<~|>($?, $?) is pure { * } multi infix:<~|>($x = '') { $x.Stringy } multi infix:<~|>(\a, \b) { a.Stringy ~| b.Stringy } proto infix:<~^>($?, $?) is pure { * } multi infix:<~^>($x = '') { $x.Stringy } multi infix:<~^>(\a, \b) { a.Stringy ~^ b.Stringy } proto infix:<~&>($?, $?) is pure { * } multi infix:<~&>() { fail "No zero-arg meaning for infix:<~&>" } multi infix:<~&>($x) { $x.Stringy } multi infix:<~&>(\a, \b) { a.Stringy ~& b.Stringy } proto prefix:<~^>($?, $?) is pure { * } multi prefix:<~^>(\a) { ~^ a.Stringy } rakudo-2013.12/src/core/Str.pm0000664000175000017500000012701412242026101015423 0ustar moritzmoritzmy class Cursor {... } my class Range {... } my class Match {... } my class IO::Path { ... } my class X::Str::Numeric { ... } my class X::Str::Match::x { ... } my class X::Str::Trans::IllegalKey { ... } my class X::Str::Trans::InvalidArg { ... } my class X::NYI { ... } my $?TABSTOP = 8; sub NORMALIZE_ENCODING(Str:D $s) { state %map = ( # fast mapping for identicals 'utf8' => 'utf8', 'utf16' => 'utf16', 'utf32' => 'utf32', 'ascii' => 'ascii', 'iso-8859-1' => 'iso-8859-1', # with dash 'utf-8' => 'utf8', 'utf-16' => 'utf16', 'utf-32' => 'utf32', # according to http://de.wikipedia.org/wiki/ISO-8859-1 'iso_8859-1:1987' => 'iso-8859-1', 'iso_8859-1' => 'iso-8859-1', 'iso-ir-100' => 'iso-8859-1', 'latin1' => 'iso-8859-1', 'latin-1' => 'iso-8859-1', 'csisolatin1' => 'iso-8859-1', 'l1' => 'iso-8859-1', 'ibm819' => 'iso-8859-1', 'cp819' => 'iso-8859-1', ); %map{$s} // %map{lc $s} // lc $s; } my class Str does Stringy { # declared in BOOTSTRAP # class Str is Cool { # has str $!value is box_target; multi method WHICH(Str:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.^name), '|'), $!value ), ObjAt ); } submethod BUILD(:$value as Str = '') { nqp::bindattr_s(self, Str, '$!value', nqp::unbox_s($value)) } multi method Bool(Str:D:) { self ne '' && self ne '0' } multi method Str(Str:D:) { self } multi method Stringy(Str:D:) { self } multi method DUMP(Str:D:) { self.perl } method Int(Str:D:) { self.Numeric.Int; } method Num(Str:D:) { self.Numeric.Num; } multi method ACCEPTS(Str:D: $other) { $other eq self } method chomp(Str:D:) { my str $sself = nqp::unbox_s(self); my int $chars = nqp::chars($sself); return '' if $chars == 0; my str $last = nqp::substr($sself, $chars - 1); my int $to_remove = 0; $to_remove = 1 if $last eq "\n" || $last eq "\r"; $to_remove = 2 if $chars > 1 && nqp::p6box_s(nqp::substr($sself, $chars - 2)) eq "\r\n"; nqp::p6box_s(nqp::substr($sself, 0, $chars - $to_remove)) } method chop(Str:D:) { my str $sself = nqp::unbox_s(self); nqp::p6box_s(nqp::substr($sself, 0, nqp::chars($sself) - 1)) } method substr(Str:D: $start, $length? is copy) { my str $sself = nqp::unbox_s(self); my int $istart = nqp::unbox_i( nqp::istype($start, Callable) ?? $start(nqp::p6box_i(nqp::chars($sself))) !! $start.Int ); my int $ichars = nqp::chars($sself); X::OutOfRange.new( what => 'Start argument to substr', got => $start, range => (0..*), comment => "use *{$istart} if you want to index relative to the end" ).fail if $istart < 0; X::OutOfRange.new( what => 'Start of substr', got => $istart, range => (0..$ichars), ).fail if $istart > $ichars; $length = $length($ichars - $istart) if nqp::istype($length, Callable); my int $ilength = !$length.defined || $length === Inf ?? $ichars - $istart !! $length.Int; X::OutOfRange.new( what => 'Length argument to substr', got => $length, range => (0..*), comment => "use *{$ilength} if you want to index relative to the end" ).fail if $ilength < 0; nqp::p6box_s(nqp::substr($sself, $istart, $ilength)); } # chars used to handle ranges for pred/succ my str $RANGECHAR = "01234567890" # arabic digits ~ "ABCDEFGHIJKLMNOPQRSTUVWXYZA" # latin uppercase ~ "abcdefghijklmnopqrstuvwxyza" # latin lowercase ~ "\x[391,392,393,394,395,396,397,398,399,39A,39B,39C,39D,39E,39F,3A0,3A1,3A3,3A4,3A5,3A6,3A7,3A8,3A9,391]" # greek uppercase ~ "\x[3B1,3B2,3B3,3B4,3B5,3B6,3B7,3B8,3B9,3BA,3BB,3BC,3BD,3BE,3BF,3C0,3C1,3C3,3C4,3C5,3C6,3C7,3C8,3C9,3B1]" # greek lowercase ~ "\x[5D0,5D1,5D2,5D3,5D4,5D5,5D6,5D7,5D8,5D9,5DA,5DB,5DC,5DD,5DE,5DF,5E0,5E1,5E2,5E3,5E4,5E5,5E6,5E7,5E8,5E9,5EA,5D0]" # hebrew ~ "\x[410,411,412,413,414,415,416,417,418,419,41A,41B,41C,41D,41E,41F,420,421,422,423,424,425,426,427,428,429,42A,42B,42C,42D,42E,42F,410]" # cyrillic uppercase ~ "\x[430,431,432,433,434,435,436,437,438,439,43A,43B,43C,43D,43E,43F,440,441,442,443,444,445,446,447,448,449,44A,44B,44C,44D,44E,44F,430]" # cyrillic lowercase ~ "\x[660,661,662,663,664,665,666,667,668,669,660]" # arabic-indic digits ~ "\x[966,967,968,969,96A,96B,96C,96D,96E,96F,966]" # devanagari digits ~ "\x[9E6,9E7,9E8,9E9,9EA,9EB,9EC,9ED,9EE,9EF,9E6]" # bengali digits ~ "\x[A66,A67,A68,A69,A6A,A6B,A6C,A6D,A6E,A6F,A66]" # gurmukhi digits ~ "\x[AE6,AE7,AE8,AE9,AEA,AEB,AEC,AED,AEE,AEF,AE6]" # gujarati digits ~ "\x[B66,B67,B68,B69,B6A,B6B,B6C,B6D,B6E,B6F,B66]" # oriya digits ~ "\x[FF10,FF11,FF12,FF13,FF14,FF15,FF16,FF17,FF18,FF19,FF10]" # fullwidth digits ~ "\x[2070,2071,00B2,00B3,2074,2075,2076,2077,2078,2079]" # superscripts ~ "\x[2080,2081,2082,2083,2084,2085,2086,2087,2088,2089]" # subscripts ~ "\x[2160,2161,2162,2163,2164,2165,2166,2167,2168,2169,216a,216b,2160]" # clock roman uc ~ "\x[2170,2171,2172,2173,2174,2175,2176,2177,2178,2179,217a,217b,2170]" # clock roman lc ~ "\x[2460,2461,2462,2463,2464,2465,2466,2467,2468,2469,246A,246B,246C,246D,246E,246F,2470,2471,2472,2473,2460]" # circled digits 1..20 ~ "\x[2474,2475,2476,2477,2478,2479,247A,247B,247C,247D,247E,247F,2480,2481,2482,2483,2484,2485,2486,2487,2474]" # parenthesized digits 1..20 ~ "\x[249C,249D,249E,249F,24A0,24A1,24A2,24A3,24A4,24A5,24A6,24A7,24A8,24A9,24AA,24AB,24AC,24AD,24AE,24AF,24B0,24B1,24B2,24B3,24B4,24B5,249C]" # parenthesized latin lc ~ "\x[2581,2582,2583,2584,2585,2586,2587,2588]" # lower blocks ~ "\x[2680,2681,2682,2683,2684,2685,2680]" # die faces ~ "\x[2776,2777,2778,2779,277A,277B,277C,277D,277E,277F,2776]"; # dingbat negative circled 1..10 # digit to extend the string with if carried past first rangechar position my $carrydigit := nqp::hash( '0', '1', # arabic "\x0660", "\x0661", # arabic-indic "\x0966", "\x0967", # devanagari "\x09E6", "\x09E7", # bengali "\x0A66", "\x0A67", # gurmukhi "\x0AE6", "\x0AE7", # gujarati "\x0B66", "\x0B67", # oriya "\xFF10", "\xFF11", # fullwidth XXX: should be treated as digit? "\x2070", "\x2071", # superscripts XXX: should be treated as digit? "\x2080", "\x2081", # subscripts XXX: should be treated as digit? ); # calculate the beginning and ending positions of my sub RANGEPOS(str $str) { my int $pos = nqp::chars($str); while $pos > 0 { $pos = $pos - 1; my str $ch = nqp::substr($str, $pos, 1); if nqp::isge_i(nqp::index($RANGECHAR, $ch, 0), 0) { my int $end = $pos; while $pos > 0 { $pos = $pos - 1; $ch = nqp::substr($str, $pos, 1); last if nqp::iseq_s($ch, '.'); return ($pos+1, $end) unless nqp::isge_i(nqp::index($RANGECHAR, $ch, 0), 0); } return ($pos, $end) unless nqp::iseq_s($ch, '.'); } } return (0, -1); } method pred(Str:D:) { my str $str = self; my Int ($Ir0, $Ir1) = RANGEPOS($str); my int $r0 = $Ir0; my int $r1 = $Ir1; while $r1 >= $r0 { my str $ch0 = nqp::substr($str, $r1, 1); my int $ipos = nqp::index($RANGECHAR, $ch0); $ipos = $RANGECHAR.index($ch0, $ipos+1) // $ipos; my str $ch1 = nqp::substr($RANGECHAR, $ipos-1, 1); $str = nqp::replace($str, $r1, 1, $ch1); # return if no carry return $str if $ch0 gt $ch1; # carry to previous position $r1 = $r1 - 1; } # cannot carry beyond first rangechar position fail('Decrement out of range'); } method succ(Str:D:) { my str $str = self; my Int ($Ir0, $Ir1) = RANGEPOS($str); my int $r0 = $Ir0; my int $r1 = $Ir1; while $r1 >= $r0 { my str $ch0 = nqp::substr($str, $r1, 1); my int $ipos = nqp::index($RANGECHAR, $ch0); my str $ch1 = nqp::substr($RANGECHAR, $ipos+1, 1); $str = nqp::replace($str, $r1, 1, $ch1); return $str if $ch1 gt $ch0; # carry to previous position $r1 = $r1 - 1; # extend string if carried past first rangechar position $str = nqp::replace($str, $r0, 0, nqp::existskey($carrydigit, $ch1) ?? nqp::atkey($carrydigit, $ch1) !! $ch1) if $r1 < $r0; } $str; } # TODO: # * Additional numeric styles: # + fractions in [] radix notation: :100[10,'.',53] # * Performance tuning # * Fix remaining XXXX multi method Numeric(Str:D: :$strict = True) { my str $str = nqp::unbox_s(self); my int $eos = nqp::chars($str); # S02:3276-3277: Ignore leading and trailing whitespace my int $pos = nqp::findnotcclass(nqp::const::CCLASS_WHITESPACE, $str, 0, $eos); my int $end = nqp::sub_i($eos, 1); $end = nqp::sub_i($end, 1) while nqp::isge_i($end, $pos) && nqp::iscclass(nqp::const::CCLASS_WHITESPACE, $str, $end); # Return 0 if no non-whitespace characters in string return 0 if nqp::islt_i($end, $pos); # Reset end-of-string after trimming $eos = nqp::add_i($end, 1); # Fail all the way out when parse failures occur my &parse_fail := -> $msg { fail X::Str::Numeric.new( source => self, reason => $msg, :$pos, ); }; my sub parse-simple-number () { # Handle NaN here, to make later parsing simpler if nqp::iseq_s(nqp::substr($str, $pos, 3), 'NaN') { $pos = nqp::add_i($pos, 3); return nqp::p6box_n(nqp::nan()); } # Handle any leading +/- sign my int $ch = nqp::ord($str, $pos); my int $neg = nqp::iseq_i($ch, 45); # '-' if nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 43) { # '-', '+' $pos = nqp::add_i($pos, 1); $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); } # nqp::radix_I parse results, and helper values my Mu $parse; my str $prefix; my int $radix; my int $p; my sub parse-int-frac-exp () { # Integer part, if any my Int:D $int := 0; if nqp::isne_i($ch, 46) { # '.' $parse := nqp::radix_I($radix, $str, $pos, $neg, Int); $p = nqp::atpos($parse, 2); parse_fail "base-$radix number must begin with valid digits or '.'" if nqp::iseq_i($p, -1); $pos = $p; $int := nqp::atpos($parse, 0); $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); } # Fraction, if any my Int:D $frac := 0; my Int:D $base := 0; if nqp::iseq_i($ch, 46) { # '.' $pos = nqp::add_i($pos, 1); $parse := nqp::radix_I($radix, $str, $pos, nqp::add_i($neg, 4), Int); $p = nqp::atpos($parse, 2); parse_fail 'radix point must be followed by one or more valid digits' if nqp::iseq_i($p, -1); $pos = $p; $frac := nqp::atpos($parse, 0); $base := nqp::atpos($parse, 1); $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); } # Exponent, if 'E' or 'e' are present (forces return type Num) if nqp::iseq_i($ch, 69) || nqp::iseq_i($ch, 101) { # 'E', 'e' parse_fail "'E' or 'e' style exponent only allowed on decimal (base-10) numbers, not base-$radix" unless nqp::iseq_i($radix, 10); $pos = nqp::add_i($pos, 1); $parse := nqp::radix_I(10, $str, $pos, 2, Int); $p = nqp::atpos($parse, 2); parse_fail "'E' or 'e' must be followed by decimal (base-10) integer" if nqp::iseq_i($p, -1); $pos = $p; my num $exp = nqp::atpos($parse, 0).Num; my num $coef = $frac ?? nqp::add_n($int.Num, nqp::div_n($frac.Num, $base.Num)) !! $int.Num; return nqp::p6box_n(nqp::mul_n($coef, nqp::pow_n(10e0, $exp))); } # Multiplier with exponent, if single '*' is present # (but skip if current token is '**', as otherwise we # get recursive multiplier parsing stupidity) if nqp::iseq_i($ch, 42) && nqp::isne_s(substr($str, $pos, 2), '**') { # '*' $pos = nqp::add_i($pos, 1); my $mult_base := parse-simple-number(); parse_fail "'*' multiplier base must be an integer" unless $mult_base.WHAT === Int; parse_fail "'*' multiplier base must be followed by '**' and exponent" unless nqp::iseq_s(nqp::substr($str, $pos, 2), '**'); $pos = nqp::add_i($pos, 2); my $mult_exp := parse-simple-number(); parse_fail "'**' multiplier exponent must be an integer" unless $mult_exp.WHAT === Int; my $mult := $mult_base ** $mult_exp; $int := $int * $mult; $frac := $frac * $mult; } # Return an Int if there was no radix point return $int unless $base; # Otherwise, return a Rat my Int:D $numerator := $int * $base + $frac; return Rat.new($numerator, $base); } # Look for radix specifiers if nqp::iseq_i($ch, 58) { # ':' # A string of the form :16 or :60[12,34,56] $pos = nqp::add_i($pos, 1); $parse := nqp::radix_I(10, $str, $pos, 0, Int); $p = nqp::atpos($parse, 2); parse_fail "radix (in decimal) expected after ':'" if nqp::iseq_i($p, -1); $pos = $p; $radix = nqp::atpos($parse, 0); $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); if nqp::iseq_i($ch, 60) { # '<' $pos = nqp::add_i($pos, 1); my $result := parse-int-frac-exp(); parse_fail "malformed ':$radix<>' style radix number, expecting '>' after the body" unless nqp::islt_i($pos, $eos) && nqp::iseq_i(nqp::ord($str, $pos), 62); # '>' $pos = nqp::add_i($pos, 1); return $result; } elsif nqp::iseq_i($ch, 171) { # '«' $pos = nqp::add_i($pos, 1); my $result := parse-int-frac-exp(); parse_fail "malformed ':$radix«»' style radix number, expecting '»' after the body" unless nqp::islt_i($pos, $eos) && nqp::iseq_i(nqp::ord($str, $pos), 187); # '»' $pos = nqp::add_i($pos, 1); return $result; } elsif nqp::iseq_i($ch, 91) { # '[' $pos = nqp::add_i($pos, 1); my Int:D $result := 0; my Int:D $digit := 0; while nqp::islt_i($pos, $eos) && nqp::isne_i(nqp::ord($str, $pos), 93) { # ']' $parse := nqp::radix_I(10, $str, $pos, 0, Int); $p = nqp::atpos($parse, 2); parse_fail "malformed ':$radix[]' style radix number, expecting comma separated decimal values after opening '['" if nqp::iseq_i($p, -1); $pos = $p; $digit := nqp::atpos($parse, 0); parse_fail "digit is larger than {$radix - 1} in ':$radix[]' style radix number" if $digit >= $radix; $result := $result * $radix + $digit; $pos = nqp::add_i($pos, 1) if nqp::islt_i($pos, $eos) && nqp::iseq_i(nqp::ord($str, $pos), 44); # ',' } parse_fail "malformed ':$radix[]' style radix number, expecting ']' after the body" unless nqp::islt_i($pos, $eos) && nqp::iseq_i(nqp::ord($str, $pos), 93); # ']' $pos = nqp::add_i($pos, 1); # XXXX: Handle fractions! # XXXX: Handle exponents! return $neg ?? -$result !! $result; } else { parse_fail "malformed ':$radix' style radix number, expecting '<' or '[' after the base"; } } elsif nqp::iseq_i($ch, 48) # '0' and $radix = nqp::index(' b o d x', nqp::substr($str, nqp::add_i($pos, 1), 1)) and nqp::isge_i($radix, 2) { # A string starting with 0x, 0d, 0o, or 0b, # followed by one optional '_' $pos = nqp::add_i($pos, 2); $pos = nqp::add_i($pos, 1) if nqp::islt_i($pos, $eos) && nqp::iseq_i(nqp::ord($str, $pos), 95); # '_' return parse-int-frac-exp(); } elsif nqp::iseq_s(nqp::substr($str, $pos, 3), 'Inf') { # 'Inf' $pos = nqp::add_i($pos, 3); return $neg ?? -$Inf !! $Inf; } else { # Last chance: a simple decimal number $radix = 10; return parse-int-frac-exp(); } } my sub parse-real () { # Parse a simple number or a Rat numerator my $result := parse-simple-number(); return $result if nqp::iseq_i($pos, $eos); # Check for '/' indicating Rat denominator if nqp::iseq_i(nqp::ord($str, $pos), 47) { # '/' $pos = nqp::add_i($pos, 1); parse_fail "denominator expected after '/'" unless nqp::islt_i($pos, $eos); my $denom := parse-simple-number(); $result := $result.WHAT === Int && $denom.WHAT === Int ?? Rat.new($result, $denom) !! $result / $denom; } return $result; } # Parse a real number, magnitude of a pure imaginary number, # or real part of a complex number my $result := parse-real(); return $result if nqp::iseq_i($pos, $eos); # Check for 'i' or '\\i' indicating first parsed number was # the magnitude of a pure imaginary number if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i' $pos = nqp::add_i($pos, 1); $result := Complex.new(0, $result); } elsif nqp::iseq_s(nqp::substr($str, $pos, 2), '\\i') { $pos = nqp::add_i($pos, 2); $result := Complex.new(0, $result); } # Check for '+' or '-' indicating first parsed number was # the real part of a complex number elsif nqp::iseq_i(nqp::ord($str, $pos), 45) # '-' || nqp::iseq_i(nqp::ord($str, $pos), 43) { # '+' # Don't move $pos -- we want parse-real() to see the sign my $im := parse-real(); parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'" unless nqp::islt_i($pos, $eos); if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i' $pos = nqp::add_i($pos, 1); } elsif nqp::iseq_s(nqp::substr($str, $pos, 2), '\\i') { $pos = nqp::add_i($pos, 2); } else { parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'" } $result := Complex.new($result, $im); } # Check for trailing garbage parse_fail "trailing characters after number" if nqp::islt_i($pos, $eos); return $result; } my %esc = ( '$' => '\$', '@' => '\@', '%' => '\%', '&' => '\&', '{' => '\{', "\b" => '\b', "\n" => '\n', "\r" => '\r', "\t" => '\t', '"' => '\"', '\\' => '\\\\' ); multi method gist(Str:D:) { self } multi method perl(Str:D:) { my $result = '"'; my $icu = $*VM; for ^self.chars -> $i { my $ch = self.substr($i, 1); $result ~= %esc{$ch} // ( ((!$icu && $ch.ord >= 256) || nqp::iscclass( nqp::const::CCLASS_PRINTING, nqp::unbox_s($ch), 0)) ?? $ch !! $ch.ord.fmt('\x[%x]') ); } $result ~ '"' } multi method comb(Str:D:) { (^self.chars).map({self.substr($_, 1) }); } multi method comb(Str:D: Regex $pat, $limit = $Inf, :$match) { my $x; $x = (1..$limit) unless nqp::istype($limit, Whatever) || $limit == $Inf; $match ?? self.match(:g, :$x, $pat) !! self.match(:g, :$x, $pat).map: { .Str } } method match($pat, :continue(:$c), :pos(:$p), :global(:$g), :overlap(:$ov), :exhaustive(:$ex), :st(:nd(:rd(:th(:$nth)))), :$x) { my $caller_dollar_slash := nqp::getlexcaller('$/'); my %opts; if $p.defined { %opts

= $p } else { %opts = $c // 0; } my $patrx := $pat ~~ Code ?? $pat !! / "$pat": /; my $cur := $patrx(Cursor.'!cursor_init'(self, |%opts)); %opts = $ov if $ov; %opts = $ex if $ex; my @matches := gather { while $cur.pos >= 0 { take $cur.MATCH_SAVE; $cur := $cur.'!cursor_more'(|%opts); } } my $multi = $g || $ov || $ex; if $nth.defined { $multi = Positional.ACCEPTS($nth); my @nlist := $nth.list; my @src := @matches; @matches := gather { my $max = 0; while @nlist { my $n = shift @nlist; fail "Attempt to retrieve negative match :nth($n)" if $n < 1; if $n > $max { take @src[$n-1]; $max = $n; } } } } if $x.defined { $multi = True; if nqp::istype($x, Int) { @matches := @matches.gimme($x) >= $x ?? @matches[^$x] !! ().list } elsif nqp::istype($x, Range) { my $min = $x.min.ceiling; my $max = $x.max; $min++ while $min <= $max && $min !~~ $x; if @matches.gimme($min) >= $min && $min ~~ $x { my @src := @matches; @matches := gather { my $n = 0; while @src && ($n < $min || $n+1 ~~ $x) { take @src.shift; $n++; } } } else { @matches := ().list } } elsif nqp::istype($x, Whatever) { } else { X::Str::Match::x.new(got => $x).fail; } } if $multi { if nqp::istype($pat, Regex) { try $caller_dollar_slash = +@matches ?? @matches[ +@matches - 1 ] !! Cursor.'!cursor_init'(nqp::unbox_s('self')).'!cursor_start_cur'().MATCH; } @matches } else { try $caller_dollar_slash = (@matches[0] // $cur.MATCH_SAVE); (@matches[0] // $cur.MATCH_SAVE) } } multi method subst($matcher, $replacement, :ii(:$samecase), :ss(:$samespace), :$SET_CALLER_DOLLAR_SLASH, *%options) { my $caller_dollar_slash := nqp::getlexcaller('$/'); my $SET_DOLLAR_SLASH = $SET_CALLER_DOLLAR_SLASH || nqp::istype($matcher, Regex); my @matches = self.match($matcher, |%options); try $caller_dollar_slash = $/ if $SET_DOLLAR_SLASH; return self unless @matches; return self if @matches == 1 && !@matches[0]; my $prev = 0; my $result = ''; for @matches -> $m { try $caller_dollar_slash = $m if $SET_DOLLAR_SLASH; $result ~= self.substr($prev, $m.from - $prev); my $real_replacement = ~($replacement ~~ Callable ?? ($replacement.count == 0 ?? $replacement() !! $replacement($m)) !! $replacement); $real_replacement = $real_replacement.samecase(~$m) if $samecase; $real_replacement = $real_replacement.samespace(~$m) if $samespace; $result ~= $real_replacement; $prev = $m.to; } my $last = @matches.pop; $result ~= self.substr($last.to); $result; } method ords(Str:D:) { my Int $c = self.chars; my str $ns = nqp::unbox_s(self); (^$c).map: { nqp::p6box_i(nqp::ord(nqp::substr($ns, $_, 1))) } } method lines(Str:D: $limit = $Inf) { my $prev_pos = -1; my $l = 0; gather { while defined(my $current_pos = self.index("\n", $prev_pos + 1)) && $l++ < $limit { take self.substr($prev_pos + 1, $current_pos - $prev_pos - 1); $prev_pos = $current_pos; } take self.substr($prev_pos + 1) if $prev_pos + 1 < self.chars && $l <= $limit; } } multi method split(Str:D: Regex $pat, $limit = *, :$all) { return ().list if $limit ~~ Numeric && $limit <= 0; my @matches = nqp::istype($limit, Whatever) ?? self.match($pat, :g) !! self.match($pat, :x(1..$limit-1), :g); # add dummy for last push @matches, Match.new( :from(self.chars) ); my $prev-pos = 0; if ($all) { my $elems = +@matches; map { my $value = self.substr($prev-pos, .from - $prev-pos); $prev-pos = .to; # we don't want the dummy object --$elems ?? ($value, $_) !! $value; }, @matches; } else { map { my $value = self.substr($prev-pos, .from - $prev-pos); $prev-pos = .to; $value; }, @matches; } } multi method split(Str:D: Cool $delimiter, $limit = *, :$all) { my $match-string = $delimiter.Str; return if self eq '' && $delimiter eq ''; my $l = $limit ~~ Whatever ?? $Inf !! $limit; return ().list if $l <= 0; return (self).list if $l == 1; my $c = 0; my $done = 0; if $match-string eq "" { my $chars = self.chars; map { last if $done; if --$chars and --$l { self.substr($c++, 1); } else { $done = 1; self.substr($c); } }, 1 .. $l; } else { my $width = $match-string.chars; map { last if $done; my $m = self.index($match-string, $c); if $m.defined and --$l { my $value = self.substr($c, $m - $c); $c = $m + $width; $all ?? ($value,$match-string) !! $value; } else { $done = 1; self.substr($c); } }, 1 .. $l; } } method samecase(Str:D: Str $pattern) { my @chars; my @pat = $pattern.comb; my $p = ''; for self.comb -> $s { $p = @pat.shift if @pat; push @chars, $p ~~ /<.upper>/ ?? $s.uc !! $p ~~ /<.lower>/ ?? $s.lc !! $s; } @chars.join(''); } method samespace(Str:D: Str:D $pat) { my @self-chunks = self.split(rx/\s+/, :all); my @pat-chunks := $pat.split(rx/\s+/, :all); loop (my $i = 1; $i < @pat-chunks && $i < @self-chunks; $i += 2) { @self-chunks[$i] = @pat-chunks[$i]; } @self-chunks.join; } method trim-leading(Str:D:) { my str $str = nqp::unbox_s(self); my int $pos = nqp::findnotcclass( nqp::const::CCLASS_WHITESPACE, $str, 0, nqp::chars($str)); nqp::p6box_s(nqp::substr($str, $pos)); } method trim-trailing(Str:D:) { my str $str = nqp::unbox_s(self); my int $pos = nqp::chars($str) - 1; $pos = $pos - 1 while nqp::isge_i($pos, 0) && nqp::iscclass(nqp::const::CCLASS_WHITESPACE, $str, $pos); nqp::islt_i($pos, 0) ?? '' !! nqp::p6box_s(nqp::substr($str, 0, $pos + 1)); } method trim(Str:D:) { my str $str = nqp::unbox_s(self); my int $pos = nqp::chars($str) - 1; my int $left = nqp::findnotcclass( nqp::const::CCLASS_WHITESPACE, $str, 0, $pos + 1); $pos = $pos - 1 while nqp::isge_i($pos, $left) && nqp::iscclass(nqp::const::CCLASS_WHITESPACE, $str, $pos); nqp::islt_i($pos, $left) ?? '' !! nqp::p6box_s(nqp::substr($str, $left, $pos + 1 - $left)); } method words(Str:D: $limit = *) { my @chunks := self.comb( / \S+ /, $limit ); +@chunks == 1 ?? @chunks[0] !! @chunks } my %enc_type = utf8 => utf8, utf16 => utf16, utf32 => utf32; method encode(Str:D $encoding = 'utf8') { my $enc := NORMALIZE_ENCODING($encoding); my $enc_type := %enc_type.exists_key($enc) ?? %enc_type{$enc} !! blob8; nqp::encode(nqp::unbox_s(self), nqp::unbox_s($enc), nqp::decont($enc_type.new)) } method wordcase(Str:D: :&filter = &tclc, Mu :$where = True) { self.subst(:g, / [<:L> \w* ] +% <['\-]> /, -> $m { my Str $s = $m.Str; $s ~~ $where ?? filter($s) !! $s; }); } my class LSM { has Str $!source; has @!substitutions; has int $!index; has int $!next_match; has $!next_substitution; has $!substitution_length; has str $.unsubstituted_text; has str $.substituted_text; submethod BUILD(:$!source) { } method add_substitution($key, $value) { push @!substitutions, $key => $value; } submethod compare_substitution($substitution, Int $pos, Int $length) { if $!next_match > $pos || $!next_match == $pos && $!substitution_length < $length { $!next_match = $pos; $!substitution_length = $length; $!next_substitution = $substitution; } } proto method triage_substitution(|) {*} multi method triage_substitution($_ where { .key ~~ Regex }) { my $key = .key; return unless $!source.substr($!index) ~~ $key; self.compare_substitution($_, $!index + $/.from, $/.to - $/.from); } multi method triage_substitution($_ where { .key ~~ Cool }) { return unless defined index($!source, .key, $!index); self.compare_substitution($_, index($!source, .key, $!index), .key.chars); } multi method triage_substitution($_) { X::Str::Trans::IllegalKey.new(key => $_).throw; } proto method increment_index(|) {*} multi method increment_index(Regex $s) { $!source.substr($!index) ~~ $s; $!index = $!next_match + $/.chars; } multi method increment_index(Cool $s) { $!index = $!next_match + nqp::chars($s.Str); } method next_substitution() { $!next_match = $!source.chars; for @!substitutions { self.triage_substitution($_); } $!unsubstituted_text # = nqp::substr(nqp::unbox_s($!source), $!index, = $!source.substr($!index, $!next_match - $!index); if defined $!next_substitution { my $result = $!next_substitution.value; $!substituted_text = nqp::unbox_s(($result ~~ Callable ?? $result() !! $result).Str); self.increment_index($!next_substitution.key); } return $!next_match < $!source.chars; } } method trans(Str:D: *@changes) { my sub expand($s) { return $s.list if $s ~~ Iterable|Positional; gather for $s.comb(/ (\w) '..' (\w) | . /, :match) { if .[0] { take $_ for ~.[0] .. ~.[1]; 0; } else { take ~$_; } } } my $lsm = LSM.new(:source(self)); for (@changes) -> $p { X::Str::Trans::InvalidArg.new(got => $p).throw unless $p ~~ Pair; if $p.key ~~ Regex { $lsm.add_substitution($p.key, $p.value); } elsif $p.value ~~ Callable { my @from = expand $p.key; for @from -> $f { $lsm.add_substitution($f, $p.value); } } else { my @from = expand $p.key; my @to = expand $p.value; for @from Z (@to ?? @to xx ceiling(@from / @to) !! '' xx @from) -> $f, $t { $lsm.add_substitution($f, $t); } } } my str $r; while $lsm.next_substitution { $r = $r ~ nqp::unbox_s($lsm.unsubstituted_text) ~ nqp::unbox_s($lsm.substituted_text); } $r = $r ~ nqp::unbox_s($lsm.unsubstituted_text); return $r; } proto method indent($) {*} # Zero indent does nothing multi method indent(Int $steps where { $_ == 0 }) { self; } # Positive indent does indent multi method indent(Int $steps where { $_ > 0 }) { # We want to keep trailing \n so we have to .comb explicitly instead of .lines return self.comb(/:r ^^ \N* \n?/).map({ given $_.Str { when /^ \n? $ / { $_; } # Use the existing space character if they're all the same # (but tabs are done slightly differently) when /^(\t+) ([ \S .* | $ ])/ { $0 ~ "\t" x ($steps div $?TABSTOP) ~ ' ' x ($steps mod $?TABSTOP) ~ $1 } when /^(\h) $0* [ \S | $ ]/ { $0 x $steps ~ $_ } # Otherwise we just insert spaces after the existing leading space default { $_ ~~ /^(\h*) (.*)$/; $0 ~ (' ' x $steps) ~ $1 } } }).join; } # Negative values and Whatever-* do outdent multi method indent($steps where { nqp::istype($_, Whatever) || nqp::istype($_, Int) && $_ < 0 }) { # Loop through all lines to get as much info out of them as possible my @lines = self.comb(/:r ^^ \N* \n?/).map({ # Split the line into indent and content my ($indent, $rest) = @($_ ~~ /^(\h*) (.*)$/); # Split the indent into characters and annotate them # with their visual size my $indent-size = 0; my @indent-chars = $indent.comb.map(-> $char { my $width = $char eq "\t" ?? $?TABSTOP - ($indent-size mod $?TABSTOP) !! 1; $indent-size += $width; $char => $width; }).eager; { :$indent-size, :@indent-chars, :rest(~$rest) }; }); # Figure out the amount * should outdent by, we also use this for warnings my $common-prefix = min @lines.grep({ . || . ~~ /\S/}).map({ $_ }); return self if $common-prefix === $Inf; # Set the actual outdent amount here my Int $outdent = $steps ~~ Whatever ?? $common-prefix !! -$steps; warn "Asked to remove $outdent spaces, but the shortest indent is $common-prefix spaces" if $outdent > $common-prefix; # Work backwards from the right end of the indent whitespace, removing # array elements up to # (or over, in the case of tab-explosion) # the specified outdent amount. @lines.map({ my $pos = 0; while $_ and $pos < $outdent { $pos += $_.pop.value; } $_».key.join ~ ' ' x ($pos - $outdent) ~ $_; }).join; } method codes(Str:D:) returns Int:D { nqp::p6box_i(nqp::chars(nqp::unbox_s(self))) } method path(Str:D:) returns IO::Path:D { IO::Path.new(self) } } multi prefix:<~>(Str:D \a) returns Str:D { a } multi prefix:<~>(str $a) returns str { $a } multi infix:<~>(Str:D \a, Str:D \b) returns Str:D { nqp::p6box_s(nqp::concat(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:<~>(str $a, str $b) returns str { nqp::concat($a, $b) } multi infix:(Str:D $s, Int:D $repetition) returns Str:D { $repetition < 0 ?? '' !! nqp::p6box_s(nqp::x(nqp::unbox_s($s), nqp::unbox_i($repetition))) } multi infix:(str $s, int $repetition) returns str { nqp::if(nqp::islt_i($repetition, 0), '', nqp::x($s, $repetition)) } multi infix:(Str:D \a, Str:D \b) returns Order:D { Order.(nqp::p6box_i(nqp::cmp_s(nqp::unbox_s(a), nqp::unbox_s(b)))) } multi infix:(str $a, str $b) returns Order:D { Order.(nqp::p6box_i(nqp::cmp_s($a, $b))) } multi infix:<===>(Str:D \a, Str:D \b) returns Bool:D { nqp::p6bool(nqp::iseq_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:<===>(str $a, str $b) returns Bool:D { nqp::p6bool(nqp::iseq_s($a, $b)) } multi infix:(Str:D \a, Str:D \b) returns Order:D { Order.(nqp::p6box_i(nqp::cmp_s(nqp::unbox_s(a), nqp::unbox_s(b)))) } multi infix:(str $a, str $b) returns Order:D { Order.(nqp::p6box_i(nqp::cmp_s($a, $b))) } multi infix:(Str:D \a, Str:D \b) returns Bool:D { nqp::p6bool(nqp::iseq_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:(str $a, str $b) returns Bool:D { nqp::p6bool(nqp::iseq_s($a, $b)) } multi infix:(Str:D \a, Str:D \b) returns Bool:D { nqp::p6bool(nqp::islt_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:(str $a, str $b) returns Bool:D { nqp::p6bool(nqp::islt_s($a, $b)) } multi infix:(Str:D \a, Str:D \b) returns Bool:D { nqp::p6bool(nqp::isle_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:(str $a, str $b) returns Bool:D { nqp::p6bool(nqp::isle_s($a, $b)) } multi infix:(Str:D \a, Str:D \b) returns Bool:D { nqp::p6bool(nqp::isgt_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:(str $a, str $b) returns Bool:D { nqp::p6bool(nqp::isgt_s($a, $b)) } multi infix:(Str:D \a, Str:D \b) returns Bool:D { nqp::p6bool(nqp::isge_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:(str $a, str $b) returns Bool:D { nqp::p6bool(nqp::isle_s($a, $b)) } multi infix:<~|>(Str:D \a, Str:D \b) returns Str:D { nqp::p6box_s(nqp::bitor_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:<~|>(str $a, str $b) returns str { nqp::bitor_s($a, $b) } multi infix:<~&>(Str:D \a, Str:D \b) returns Str:D { nqp::p6box_s(nqp::bitand_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:<~&>(str $a, str $b) returns str { nqp::bitand_s($a, $b) } multi infix:<~^>(Str:D \a, Str:D \b) returns Str:D { nqp::p6box_s(nqp::bitxor_s(nqp::unbox_s(a), nqp::unbox_s(b))) } multi infix:<~^>(str $a, str $b) returns str { nqp::bitxor_s($a, $b) } multi prefix:<~^>(Str \a) { fail "prefix:<~^> NYI"; # XXX } # XXX: String-wise shifts NYI multi infix:«~>»(Str:D \a, Int:D \b) returns Str:D { X::NYI.new(feature => "infix:«~>»").throw; } multi infix:«~>»(str $a, int $b) { X::NYI.new(feature => "infix:«~>»").throw; } multi infix:«~<»(Str:D \a, Int:D \b) returns Str:D { X::NYI.new(feature => "infix:«~<»").throw; } multi infix:«~<»(str $a, int $b) { X::NYI.new(feature => "infix:«~<»").throw; } multi sub ords(Str $s) returns List:D { my Int $c = $s.chars; my str $ns = nqp::unbox_s($s); (^$c).map: { nqp::p6box_i(nqp::ord(nqp::substr($ns, $_, 1))) } } # TODO: Cool variants sub trim (Str:D $s) returns Str:D { $s.trim } sub trim-leading (Str:D $s) returns Str:D { $s.trim-leading } sub trim-trailing(Str:D $s) returns Str:D { $s.trim-trailing } # the opposite of Real.base, used for :16($hex_str) sub unbase(Int:D $base, Str:D $str) returns Numeric:D { my Str $prefix = $str.substr(0, 2); if $base <= 10 && $prefix eq any(<0x 0d 0o 0b>) or $base <= 24 && $prefix eq any <0o 0x> or $base <= 33 && $prefix eq '0x' { $str.Numeric; } else { ":{$base}<$str>".Numeric; } } # for :16[1, 2, 3] sub unbase_bracket($base, @a) { my $v = 0; my $denom = 1; my Bool $seen-dot = False; for @a { if $seen-dot { die "Only one decimal dot allowed" if $_ eq '.'; $denom *= $base; $v += $_ / $denom } elsif $_ eq '.' { $seen-dot = True; } else { $v = $v * $base + $_; } } $v; } sub chrs(*@c) returns Str:D { @c.map({.chr}).join(''); } sub substr-rw($s is rw, $from = 0, $chars = $s.chars - $from) { my Str $substr = $s.substr($from, $chars); Proxy.new( FETCH => sub ($) { $substr }, STORE => sub ($, $new) { $s = $s.substr(0, $from) ~ $new ~ $s.substr($from + $chars); } ); } rakudo-2013.12/src/core/stubs.pm0000664000175000017500000000256612224263172016032 0ustar moritzmoritz# This file contains various stubs. Note that a few are created already # outside of the setting, such as Mu/Any/Cool, Attribute, Signature/Parameter, # Code/Block/Routine/Sub/Method and Str/Int/Num. They are built in BOOTSTRAP.pm # in Perl6::Metamodel for now, though should be a BEGIN block in CORE.setting # in the end. my class Seq is List does Positional { } my class Exception { ... } my class X::AdHoc { ... } my class FatRat { ... } my class Enum { ... } my class X::OutOfRange { ... } my role QuantHash { ... } my role Setty { ... } my class Set { ... } my class SetHash { ... } my role Baggy { ... } my class Bag { ... } my class BagHash { ... } my role Mixy { ... } my class Mix { ... } my class MixHash { ... } sub DYNAMIC(\name) is rw { my Mu $x := nqp::getlexdyn(nqp::unbox_s(name)); if nqp::isnull($x) { my str $pkgname = nqp::replace(nqp::unbox_s(name), 1, 1, ''); if nqp::existskey(GLOBAL.WHO, $pkgname) { $x := nqp::atkey(GLOBAL.WHO, $pkgname) } elsif nqp::existskey(PROCESS.WHO, $pkgname) { $x := nqp::atkey(PROCESS.WHO, $pkgname) } else { fail "Dynamic variable {name} not found" } } $x } # Set up ClassHOW's auto-gen proto (nested scope so it won't # actually appear in the setting). { my class Dummy { our proto method AUTOGEN(::T $: |) { * } } Dummy.HOW.set_autogen_proto(&Dummy::AUTOGEN); } rakudo-2013.12/src/core/Submethod.pm0000664000175000017500000000021312224263172016607 0ustar moritzmoritzmy class Submethod { # declared in BOOTSTRAP # class Submethod is Routine { ... } multi method gist(Submethod:D:) { self.name } } rakudo-2013.12/src/core/Sub.pm0000664000175000017500000000011512224263172015407 0ustar moritzmoritzmy class Sub { # declared in BOOTSTRAP # class Sub is Routine { ... } } rakudo-2013.12/src/core/tai-utc.pm0000664000175000017500000000367012255230571016236 0ustar moritzmoritz# This file keeps track of the differences between TAI and UTC # for internal use. The "BEGIN" and "END" comments are for # tools/update-tai-utc.pl. # Some handy tables: # http://tf.nist.gov/pubs/bulletin/leapsecond.htm # http://hpiers.obspm.fr/eop-pc/earthor/utc/TAI-UTC_tab.html my module tai-utc { #our $initial-offset = 10; our sub initial-offset() { 10 } # TAI - UTC at the Unix epoch (1970-01-01T00:00:00Z). # our @leap-second-dates = < our sub leap-second-dates() { BEGIN #BEGIN leap-second-dates < 1972-06-30 1972-12-31 1973-12-31 1974-12-31 1975-12-31 1976-12-31 1977-12-31 1978-12-31 1979-12-31 1981-06-30 1982-06-30 1983-06-30 1985-06-30 1987-12-31 1989-12-31 1990-12-31 1992-06-30 1993-06-30 1994-06-30 1995-12-31 1997-06-30 1998-12-31 2005-12-31 2008-12-31 2012-06-30 > #END leap-second-dates }; # our %leap-seconds = # @leap-second-dates Z=> $initial-offset + 1 .. *; # So for any date $d in @leap-second-dates, $d 23:59:00 UTC # is the leap second that made (or will make) UTC # %leap-seconds{$d} seconds behind TAI. # Ambiguous POSIX times. our sub leap-second-posix() { BEGIN #BEGIN leap-second-posix < 78796800 94694400 126230400 157766400 189302400 220924800 252460800 283996800 315532800 362793600 394329600 425865600 489024000 567993600 631152000 662688000 709948800 741484800 773020800 820454400 867715200 915148800 1136073600 1230768000 1341100800 > #END leap-second-posix }; }; rakudo-2013.12/src/core/Temporal.pm0000664000175000017500000005070212255230273016450 0ustar moritzmoritzmy class DateTime { ... } my class Date { ... } my enum TimeUnit ( :second(1), :seconds(2), :minute(3), :minutes(4), :hour(5), :hours(6), :day(7), :days(8), :week(9), :weeks(10), :month(11), :months(12), :year(13), :years(14), ); my role Dateish { method is-leap-year($y = $.year) { $y %% 4 and not $y %% 100 or $y %% 400 } method days-in-month($year = $.year, $month = $.month) { $month == 2 ?? self.is-leap-year($year) ?? 29 !! 28 !! $month == 4|6|9|11 ?? 30 !! 31 } method daycount-from-ymd($y is copy, $m is copy, $d) { # taken from $y .= Int; $m .= Int; if $m < 3 { $m += 12; --$y; } -678973 + $d + (153 * $m - 2) div 5 + 365 * $y + $y div 4 - $y div 100 + $y div 400; } method ymd-from-daycount($daycount) { # taken from my int $day = $daycount.Int + 678881; my int $t = (4 * ($day + 36525)) div 146097 - 1; my int $year = 100 * $t; $day = $day - (36524 * $t + ($t +> 2)); $t = (4 * ($day + 366)) div 1461 - 1; $year = $year + $t; $day = $day - (365 * $t + ($t +> 2)); my int $month = (5 * $day + 2) div 153; $day = $day - ((2 + $month * 153) div 5 - 1); if ($month > 9) { $month = $month - 12; $year = $year + 1; } ($year, $month + 3, $day) } method get-daycount { self.daycount-from-ymd($.year, $.month, $.day) } method day-of-month() { $.day } method day-of-week($daycount = self.get-daycount) { ($daycount + 2) % 7 + 1 } method week() { # algorithm from Claus Tøndering my $a = $.year - ($.month <= 2).floor.Int; my $b = $a div 4 - $a div 100 + $a div 400; my $c = ($a - 1) div 4 - ($a - 1) div 100 + ($a - 1) div 400; my $s = $b - $c; my $e = $.month <= 2 ?? 0 !! $s + 1; my $f = $.day + do $.month <= 2 ?? 31*($.month - 1) - 1 !! (153*($.month - 3) + 2) div 5 + 58 + $s; my $g = ($a + $b) % 7; my $d = ($f + $g - $e) % 7; my $n = $f + 3 - $d; $n < 0 ?? ($.year - 1, 53 - ($g - $s) div 5) !! $n > 364 + $s ?? ($.year + 1, 1) !! ($.year, $n div 7 + 1); } method week-year() { self.week.[0] } method week-number() { self.week.[1] } method weekday-of-month { ($.day - 1) div 7 + 1 } method day-of-year() { [+] $.day, map { self.days-in-month($.year, $^m) }, 1 ..^ $.month } method check-value($val is copy, $name, $range, :$allow-nonint) { $val = $allow-nonint ?? +$val !! $val.Int; $val ~~ $range or X::OutOfRange.new( what => $name, got => $val, range => $range, ).throw; } method check-date { self.check-value($.month, 'month', 1 .. 12); self.check-value($.day, "day of $.year/$.month", 1 .. self.days-in-month); } method truncate-parts(TimeUnit $unit, %parts? is copy) { # Helper for DateTime.truncated-to and Date.truncated-to. if $unit == week | weeks { my $dc = self.get-daycount; my $new-dc = $dc - self.day-of-week($dc) + 1; %parts = self.ymd-from-daycount($new-dc); } else { # $unit == month | months | year | years %parts = 1; $unit eq 'year' and %parts = 1; } %parts; } } sub default-formatter(DateTime $dt, Bool :$subseconds) { # ISO 8601 timestamp (well, not strictly ISO 8601 if $subseconds # is true) my $o = $dt.offset; $o %% 60 or warn "Default DateTime formatter: offset $o not divisible by 60.\n"; sprintf '%04d-%02d-%02dT%02d:%02d:%s%s', $dt.year, $dt.month, $dt.day, $dt.hour, $dt.minute, $subseconds ?? $dt.second.fmt('%09.6f') !! $dt.whole-second.fmt('%02d'), do $o ?? sprintf '%s%02d%02d', $o < 0 ?? '-' !! '+', ($o.abs / 60 / 60).floor, ($o.abs / 60 % 60).floor !! 'Z'; } sub get-local-timezone-offset { my $utc = DateTime.new(now).posix.Int; my Mu $fia := nqp::p6decodelocaltime(nqp::unbox_i($utc)); my $second = nqp::p6box_i(nqp::atpos_i($fia, 0)); my $minute = nqp::p6box_i(nqp::atpos_i($fia, 1)); my $hour = nqp::p6box_i(nqp::atpos_i($fia, 2)); my $day = nqp::p6box_i(nqp::atpos_i($fia, 3)); my $month = nqp::p6box_i(nqp::atpos_i($fia, 4)); my $year = nqp::p6box_i(nqp::atpos_i($fia, 5)); my $local = DateTime.new(:$year, :$month, :$day, :$hour, :$minute, :$second); my $ltime = $local.posix(True).Int; $ltime - $utc; } my class DateTime does Dateish { has Int $.year; has Int $.month = 1; has Int $.day = 1; has Int $.hour = 0; has Int $.minute = 0; has $.second = 0.0; has $.timezone = 0; # UTC has &.formatter = &default-formatter; # Not an optimization but a necessity to ensure that # $dt.utc.local.utc is equivalent to $dt.utc. Otherwise, # DST-induced ambiguity could ruin our day. multi method new() { fail "Must provide arguments to DateTime.new()"; } multi method new(Int :$year!, :&formatter=&default-formatter, *%_) { my $dt = self.bless(:$year, :&formatter, |%_); $dt.check-date; $dt.check-time; $dt; } method check-time { # Asserts the validity of and numifies $!hour, $!minute, and $!second. self.check-value($!hour, 'hour', 0 ..^ 24); self.check-value($!minute, 'minute', 0 ..^ 60); self.check-value($!second, 'second', 0 ..^ 62, :allow-nonint); if $!second >= 60 { # Ensure this is an actual leap second. self.second < 61 or X::OutOfRange.new( what => 'second', range => (0..^60), got => self.second, comment => 'No second 61 has yet been defined', ).throw; my $dt = self.utc; $dt.hour == 23 && $dt.minute == 59 or X::OutOfRange.new( what => 'second', range => (0..^60), got => self.second, comment => 'a leap second can occur only at hour 23 and minute 59 UTC', ).throw; my $date = sprintf '%04d-%02d-%02d', $dt.year, $dt.month, $dt.day; $date eq any(tai-utc::leap-second-dates) or X::OutOfRange.new( what => 'second', range => (0..^60), got => self.second, comment => "There is no leap second on UTC $date", ).throw; } } multi method new(Date :$date!, *%_) { self.new(year => $date.year, month => $date.month, day => $date.day, |%_) } multi method new(Instant $i, :$timezone=0, :&formatter=&default-formatter) { my ($p, $leap-second) = $i.to-posix; my $dt = self.new: floor($p - $leap-second).Int, :&formatter; $dt.clone(second => ($dt.second + $p % 1 + $leap-second) ).in-timezone($timezone); } multi method new(Int $time is copy, :$timezone=0, :&formatter=&default-formatter) { # Interpret $time as a POSIX time. my $second = $time % 60; $time = $time div 60; my $minute = $time % 60; $time = $time div 60; my $hour = $time % 24; $time = $time div 24; # Day month and leap year arithmetic, based on Gregorian day #. # 2000-01-01 noon UTC == 2451558.0 Julian == 2451545.0 Gregorian $time += 2440588; # because 2000-01-01 == Unix epoch day 10957 my $a = $time + 32044; # date algorithm from Claus Tøndering my $b = (4 * $a + 3) div 146097; # 146097 = days in 400 years my $c = $a - (146097 * $b) div 4; my $d = (4 * $c + 3) div 1461; # 1461 = days in 4 years my $e = $c - ($d * 1461) div 4; my $m = (5 * $e + 2) div 153; # 153 = days in Mar-Jul Aug-Dec my $day = $e - (153 * $m + 2) div 5 + 1; my $month = $m + 3 - 12 * ($m div 10); my $year = $b * 100 + $d - 4800 + $m div 10; self.bless(:$year, :$month, :$day, :$hour, :$minute, :$second, :&formatter).in-timezone($timezone); } multi method new(Str $format, :$timezone is copy = 0, :&formatter=&default-formatter) { $format ~~ /^ (\d**4) '-' (\d\d) '-' (\d\d) T (\d\d) ':' (\d\d) ':' (\d\d) (Z || (<[\-\+]>) (\d\d)(\d\d))? $/ or X::Temporal::InvalidFormat.new( invalid-str => $format, target => 'DateTime', format => 'an ISO 8601 timestamp (yyyy-mm-ddThh::mm::ssZ or yyyy-mm-ddThh::mm::ss+0100)', ).throw; my $year = (+$0).Int; my $month = (+$1).Int; my $day = (+$2).Int; my $hour = (+$3).Int; my $minute = (+$4).Int; my $second = +$5; if $6 { $timezone and X::DateTime::TimezoneClash.new.throw; if $6 eq 'Z' { $timezone = 0; } else { $timezone = (($6[1]*60 + $6[2]) * 60).Int; # RAKUDO: .Int is needed to avoid to avoid the nasty '-0'. $6[0] eq '-' and $timezone = -$timezone; } } self.new(:$year, :$month, :$day, :$hour, :$minute, :$second, :$timezone, :&formatter); } method now(:$timezone=$*TZ, :&formatter=&default-formatter) { self.new(now, :$timezone, :&formatter) } method clone(*%_) { my %args = { :$!year, :$!month, :$!day, :$!hour, :$!minute, :$!second, :$!timezone, :&!formatter, %_ }; self.new(|%args); } method clone-without-validating(*%_) { # A premature optimization. my %args = { :$!year, :$!month, :$!day, :$!hour, :$!minute, :$!second, :$!timezone, :&!formatter, %_ }; self.bless(|%args); } method Instant() { Instant.from-posix: self.posix + $.second % 1, $.second >= 60; } method posix($ignore-timezone?) { $ignore-timezone or self.offset == 0 or return self.utc.posix; # algorithm from Claus Tøndering my $a = (14 - $.month.Int) div 12; my $y = $.year.Int + 4800 - $a; my $m = $.month.Int + 12 * $a - 3; my $jd = $.day + (153 * $m + 2) div 5 + 365 * $y + $y div 4 - $y div 100 + $y div 400 - 32045; ($jd - 2440588) * 24 * 60 * 60 + 60*(60*$.hour + $.minute) + self.whole-second; } method offset { $!timezone.Int; } method offset-in-minutes { $!timezone.Int / 60; } method offset-in-hours { $!timezone.Int / 60 / 60; } method delta($amount, TimeUnit $unit) { my ($hour, $minute) = $!hour, $!minute; my $date; given $unit { when second | seconds { return DateTime.new(self.Instant + $amount); } when minute | minutes { $minute += $amount; proceed } $hour += floor($minute / 60); $minute %= 60; when hour | hours { $hour += $amount; proceed } my $day-delta += floor($hour / 24); $hour %= 24; when day | days { $day-delta += $amount; proceed } when week | weeks { $day-delta += 7 * $amount; proceed } when month | months { my ($month, $year) = $!month, $!year; $month += $amount; $year += floor(($month - 1) / 12); $month = ($month - 1) % 12 + 1; $date = Date.new(:$year, :$month, :$!day); succeed; } when year | years { my $year = $!year + $amount; $date = Date.new(:$year, :$!month, :$!day); succeed; } my $daycount = Date.new(self).daycount; $daycount += $day-delta; $date = Date.new-from-daycount($daycount); } my $second = $!second; if $second > 59 && $date ne any(tai-utc::leap-second-dates) { $second -= 60; $minute++; if $minute > 59 { $minute -= 60; $hour++; if $hour > 23 { $hour -= 24; $date++; } } } self.new(:$date, :$hour, :$minute, :$second); } method truncated-to(TimeUnit $unit) { my %parts; given $unit { %parts = self.whole-second; when second {} %parts = 0; when minute {} %parts = 0; when hour {} %parts = 0; when day {} # Fall through to Dateish. %parts = self.truncate-parts($unit, %parts); } self.clone-without-validating(|%parts); } method whole-second() { floor($.second).Int } method in-timezone($timezone) { $timezone eqv $!timezone and return self; my $old-offset = self.offset; my $new-offset = $timezone.Int; my %parts; # Is the logic for handling leap seconds right? # I don't know, but it passes the tests! my $a = ($!second >= 60 ?? 59 !! $!second) + $new-offset - $old-offset; %parts = $!second >= 60 ?? $!second !! ($a % 60).Int; my $b = $!minute + floor $a / 60; %parts = ($b % 60).Int; my $c = $!hour + floor $b / 60; %parts = ($c % 24).Int; # Let Dateish handle any further rollover. floor $c / 24 and %parts = self.ymd-from-daycount\ (self.get-daycount + floor $c / 24); self.clone-without-validating: :$timezone, |%parts; } method utc() { self.in-timezone(0) } method local() { self.in-timezone($*TZ) } method Date() { Date.new(:$.year, :$.month, :$.day); } method Str() { &!formatter(self) } multi method perl(DateTime:D:) { sprintf 'DateTime.new(%s)', join ', ', map { "{.key} => {.value}" }, do :$.year, :$.month, :$.day, :$.hour, :$.minute, second => $.second.perl, (timezone => $.timezone.perl unless $.timezone === 0), (formatter => $.formatter.perl unless &.formatter eqv &default-formatter) } multi method gist(DateTime:D:) { self.Str; } } my class Date does Dateish { has Int $.year; has Int $.month = 1; has Int $.day = 1; has Int $.daycount; method !set-daycount($dc) { $!daycount = $dc } method get-daycount { $!daycount } multi method new(:$year!, :$month = 1, :$day = 1) { my $d = self.bless(:$year, :$month, :$day); $d.check-date; $d!set-daycount(self.daycount-from-ymd($year,$month,$day)); $d; } multi method new($year, $month, $day) { self.new(:$year, :$month, :$day); } multi method new(Str $date) { $date ~~ /^ \d\d\d\d '-' \d\d '-' \d\d $/ or X::Temporal::InvalidFormat.new( invalid-str => $date, format => 'yyyy-mm-dd', ).throw; self.new(|$date.split('-').map({.Int})); } multi method new() { my $n = self.today; if $n.month == 12 && $n.day >= 24 { Date.new($n.year + 1, 12, 24); } else { Date.new($n.year, 12, 24); } } multi method new(DateTime $dt) { self.bless( :year($dt.year), :month($dt.month), :day($dt.day), :daycount(self.daycount-from-ymd($dt.year,$dt.month,$dt.day)) ); } multi method WHICH(Date:D:) { nqp::box_s( nqp::concat( nqp::concat(nqp::unbox_s(self.^name), '|'), nqp::unbox_i($!daycount) ), ObjAt ); } method new-from-daycount($daycount) { my ($year, $month, $day) = self.ymd-from-daycount($daycount); self.bless(:$daycount, :$year, :$month, :$day); } method today() { self.new(DateTime.now); } method truncated-to(TimeUnit $unit) { self.clone(|self.truncate-parts($unit)); } method delta($amount, TimeUnit $unit) { my $date; given $unit { X::DateTime::InvalidDeltaUnit.new(:$unit).throw when second | seconds | minute | minutes | hour | hours; my $day-delta; when day | days { $day-delta = $amount; proceed } when week | weeks { $day-delta = 7 * $amount; proceed } when month | months { my ($month, $year) = $!month, $!year; $month += $amount; $year += floor(($month - 1) / 12); $month = ($month - 1) % 12 + 1; $date = Date.new(:$year, :$month, :$!day); succeed; } when year | years { my $year = $!year + $amount; $date = Date.new(:$year, :$!month, :$!day); succeed; } $date = Date.new-from-daycount(self.daycount + $day-delta); } $date; } method clone(*%_) { my %args = { :$!year, :$!month, :$!day, %_ }; self.new(|%args); } method succ() { Date.new-from-daycount($!daycount + 1); } method pred() { Date.new-from-daycount($!daycount - 1); } multi method gist(Date:D:) { sprintf '%04d-%02d-%02d', $.year, $.month, $.day; } multi method Str(Date:D:) { sprintf '%04d-%02d-%02d', $.year, $.month, $.day; } multi method perl(Date:D:) { "Date.new($.year.perl(), $.month.perl(), $.day.perl())"; } } multi infix:<+>(Date:D $d, Int:D $x) { Date.new-from-daycount($d.daycount + $x) } multi infix:<+>(Int:D $x, Date:D $d) { Date.new-from-daycount($d.daycount + $x) } multi infix:<->(Date:D $d, Int:D $x) { Date.new-from-daycount($d.daycount - $x) } multi infix:<->(Date:D $a, Date:D $b) { $a.daycount - $b.daycount; } multi infix:(Date:D $a, Date:D $b) { $a.daycount cmp $b.daycount } multi infix:«<=>»(Date:D $a, Date:D $b) { $a.daycount <=> $b.daycount } multi infix:<==>(Date:D $a, Date:D $b) { $a.daycount == $b.daycount } multi infix:«<=»(Date:D $a, Date:D $b) { $a.daycount <= $b.daycount } multi infix:«<»(Date:D $a, Date:D $b) { $a.daycount < $b.daycount } multi infix:«>=»(Date:D $a, Date:D $b) { $a.daycount >= $b.daycount } multi infix:«>»(Date:D $a, Date:D $b) { $a.daycount > $b.daycount } $PROCESS::TZ = get-local-timezone-offset(); sub sleep($seconds = Inf --> Nil) { if $seconds ~~ (Inf|Whatever) { nqp::sleep(1e16) while True; } elsif $seconds > 0 { nqp::sleep($seconds.Num); } Nil; } sub sleep-timer (Real $seconds = Inf --> Duration) { if $seconds <= 0 { Duration.new(0); } else { my $time1 = now; nqp::sleep($seconds.Num); Duration.new( ( $seconds - now - $time1 ) max 0 ); } } sub sleep-till (Instant $till --> Bool) { my $seconds = $till - now; return False if $seconds < 0; 1 while $seconds = sleep-timer($seconds); True; } # =begin pod # # =head1 SEE ALSO # Perl 6 spec . # The Perl 5 DateTime Project home page L. # Perl 5 perldoc L and L. # # The best yet seen explanation of calendars, by Claus Tøndering # L. # Similar algorithms at L # and L. # # #

{ # also covers the -np case, like Perl 5 $mainline := wrap_option_p_code($/, $mainline); } elsif %*COMPILING<%?OPTIONS> { $mainline := wrap_option_n_code($/, $mainline); } # We'll install our view of GLOBAL as the main one; any other # compilation unit that is using this one will then replace it # with its view later (or be in a position to restore it). my $global_install := QAST::Op.new( :op('bindcurhllsym'), QAST::SVal.new( :value('GLOBAL') ), QAST::WVal.new( :value($*GLOBALish) ) ); $*W.add_fixup_task(:deserialize_past($global_install), :fixup_past($global_install)); # Get the block for the entire compilation unit. my $outer := $*UNIT_OUTER; $outer.node($/); $*UNIT_OUTER.unshift(QAST::Var.new( :name('__args__'), :scope('local'), :decl('param'), :slurpy(1) )); # Load the needed libraries. $*W.add_libs($unit); # If the unit defines &MAIN, and this is in the mainline, # add a &MAIN_HELPER. if !$*W.is_precompilation_mode && +(@*MODULES // []) == 0 && $unit.symbol('&MAIN') { $mainline := QAST::Op.new( :op('call'), :name('&MAIN_HELPER'), $mainline, ); } # If our caller wants to know the mainline ctx, provide it here. # (CTXSAVE is inherited from HLL::Actions.) Don't do this when # there was an explicit {YOU_ARE_HERE}. unless $*HAS_YOU_ARE_HERE { $unit.push( self.CTXSAVE() ); } # Add the mainline code to the unit. $unit.push($mainline); # Executing the compilation unit causes the mainline to be executed. $outer.push(QAST::Op.new( :op, $unit )); # Wrap everything in a QAST::CompUnit. my $compunit := QAST::CompUnit.new( :hll('perl6'), # Serialization related bits. :sc($*W.sc()), :code_ref_blocks($*W.code_ref_blocks()), :compilation_mode($*W.is_precompilation_mode()), :pre_deserialize($*W.load_dependency_tasks()), :post_deserialize($*W.fixup_tasks()), :repo_conflict_resolver(QAST::Op.new( :op('callmethod'), :name('resolve_repossession_conflicts'), QAST::Op.new( :op('getcurhllsym'), QAST::SVal.new( :value('ModuleLoader') ) ) )), # If this unit is loaded as a module, we want it to automatically # execute the mainline code above after all other initializations # have occurred. :load(QAST::Op.new( :op('call'), QAST::BVal.new( :value($outer) ), )), # Finally, the outer block, which in turn contains all of the # other program elements. $outer ); # Pass some extra bits along to the optimizer. $compunit := $unit; $compunit := $*GLOBALish; $compunit := $*W; # Do any final compiler state cleanup tasks. $*W.cleanup(); make $compunit; } # XXX Move to HLL::Actions after NQP gets QAST. method CTXSAVE() { QAST::Stmt.new( QAST::Op.new( :op('bind'), QAST::Var.new( :name('ctxsave'), :scope('local'), :decl('var') ), QAST::Var.new( :name('$*CTXSAVE'), :scope('contextual') ) ), QAST::Op.new( :op('unless'), QAST::Op.new( :op('isnull'), QAST::Var.new( :name('ctxsave'), :scope('local') ) ), QAST::Op.new( :op('if'), QAST::Op.new( :op, QAST::Var.new( :name('ctxsave'), :scope('local') ), QAST::SVal.new( :value('ctxsave') ) ), QAST::Op.new( :op('callmethod'), :name('ctxsave'), QAST::Var.new( :name('ctxsave'), :scope('local') ))))) } method install_doc_phaser($/) { # Add a default DOC INIT phaser my $doc := %*COMPILING<%?OPTIONS>; if $doc { my $block := $*W.push_lexpad($/); my $renderer := "Pod::To::$doc"; my $module := $*W.load_module($/, $renderer, {}, $*GLOBALish); my $pod2text := QAST::Op.new( :op, :name, :node($/), self.make_indirect_lookup([$renderer]), QAST::Var.new(:name<$=pod>, :scope('lexical'), :node($/)) ); $block.push( QAST::Op.new( :op, :node($/), :name('&say'), $pod2text, ), ); # TODO: We should print out $?USAGE too, # once it's known at compile time $block.push( QAST::Op.new( :op, :node($/), :name('&exit'), ) ); $*W.pop_lexpad(); $*W.add_phaser( $/, 'INIT', $*W.create_simple_code_object($block, 'Block'), $block ); } } method pod_content_toplevel($/) { my $child := $.ast; # make sure we don't push the same thing twice if $child { my $id := $/.from ~ "," ~ ~$/.to; if !$*POD_BLOCKS_SEEN{$id} { $*POD_BLOCKS.push($child); $*POD_BLOCKS_SEEN{$id} := 1; } } make $child; } method pod_content:sym($/) { make $.ast; } method pod_configuration($/) { make Perl6::Pod::make_config($/); } method pod_block:sym($/) { make Perl6::Pod::any_block($/); } method pod_block:sym($/) { make Perl6::Pod::raw_block($/); } method pod_block:sym($/) { make Perl6::Pod::table($/); } method pod_block:sym($/) { make Perl6::Pod::any_block($/); } method pod_block:sym($/) { make Perl6::Pod::raw_block($/); } method pod_block:sym($/) { make Perl6::Pod::table($/); } method pod_block:sym($/) { make Perl6::Pod::any_block($/); } method pod_block:sym($/) { make Perl6::Pod::raw_block($/); } method pod_block:sym($/) { make Perl6::Pod::table($/); } method pod_block:sym($/) { } method pod_content:sym($/) { make Perl6::Pod::config($/); } method pod_content:sym($/) { my @ret := []; for $ { @ret.push($_.ast); } my $past := Perl6::Pod::serialize_array(@ret); make $past.compile_time_value; } method pod_textcontent:sym($/) { my @t := Perl6::Pod::merge_twines($); my $twine := Perl6::Pod::serialize_array(@t).compile_time_value; make Perl6::Pod::serialize_object( 'Pod::Block::Para', :content($twine) ).compile_time_value } method pod_textcontent:sym($/) { my $s := $.Str; my $t := subst($.Str, /\n$s/, "\n", :global); $t := subst($t, /\n$/, ''); # chomp! my $past := Perl6::Pod::serialize_object( 'Pod::Block::Code', :content(Perl6::Pod::serialize_aos([$t]).compile_time_value), ); make $past.compile_time_value; } method pod_formatting_code($/) { if ~$ eq 'V' { make ~$; } else { my @content := []; for $ { @content.push($_.ast) } my @t := Perl6::Pod::build_pod_string(@content); my $past := Perl6::Pod::serialize_object( 'Pod::FormattingCode', :type( $*W.add_string_constant(~$).compile_time_value ), :content( Perl6::Pod::serialize_array(@t).compile_time_value ) ); make $past.compile_time_value; } } method pod_string($/) { my @content := []; for $ { @content.push($_.ast) } make Perl6::Pod::build_pod_string(@content); } method pod_balanced_braces($/) { if $ { my @content := []; my @stringparts := []; @stringparts.push(~$); if $ { for $ { if nqp::isstr($_.ast) { @stringparts.push($_.ast); } else { @content.push(nqp::join("", @stringparts)); @stringparts := nqp::list(); @content.push($_.ast); } } } @stringparts.push(~$); @content.push(nqp::join("", @stringparts)); if +@content == 1 { make @content[0]; } else { make Perl6::Pod::build_pod_string(@content); } } else { make ~$ } } method pod_string_character($/) { if $ { make $.ast } elsif $ { make $.ast } else { make ~$; } } method table_row($/) { make ~$/ } method unitstart($/) { # Use SET_BLOCK_OUTER_CTX (inherited from HLL::Actions) # to set dynamic outer lexical context and namespace details # for the compilation unit. self.SET_BLOCK_OUTER_CTX($*UNIT_OUTER); } method statementlist($/) { my $past := QAST::Stmts.new( :node($/) ); if $ { for $ { my $ast := $_.ast; if $ast { if $ast { $ast := QAST::Want.new($ast, 'v', $ast); } elsif $ast { $ast := autosink($ast); } else { $ast := QAST::Stmt.new(autosink($ast), :returns($ast.returns)) if $ast ~~ QAST::Node; } $past.push( $ast ); } } } if +$past.list < 1 { $past.push(QAST::Var.new(:name('Nil'), :scope('lexical'))); } else { $past.returns($past[+@($past) - 1].returns); } make $past; } method semilist($/) { my $past := QAST::Stmts.new( :node($/) ); if $ { for $ { $past.push($_.ast) if $_.ast; } } unless +@($past) { $past.push( QAST::Op.new( :op('call'), :name('&infix:<,>') ) ); } make $past; } method statement($/, $key?) { my $past; if $ { my $mc := $; my $ml := $; $past := $.ast; if $mc { $mc.ast.push($past); $mc.ast.push(QAST::Var.new(:name('Nil'), :scope('lexical'))); $past := $mc.ast; } if $ml { my $cond := $ml.ast; if ~$ml eq 'given' { $past := QAST::Op.new( :op('call'), make_topic_block_ref($past), $cond ); } elsif ~$ml eq 'for' { unless $past { $past := make_topic_block_ref($past); } $past := QAST::Op.new( :op, :name, :node($/), QAST::Op.new(:op('call'), :name('&infix:<,>'), $cond), block_closure($past) ); $past := QAST::Op.new( :op, :name, $past ); } else { $past := QAST::Op.new($cond, $past, :op(~$ml), :node($/) ); } } } elsif $ { $past := $.ast; } elsif $ { $past := $.ast; } else { $past := 0; } if $STATEMENT_PRINT && $past { $past := QAST::Stmts.new(:node($/), QAST::Op.new( :op, QAST::SVal.new(:value(~$/)) ), $past ); } make $past; } method xblock($/) { make QAST::Op.new( $.ast, $.ast, :op('if'), :node($/) ); } method pblock($/) { if $ { make $.ast; } else { # Locate or build a set of parameters. my %sig_info; my @params; my $block := $.ast; if $block && $ { $*W.throw($/, ['X', 'Signature', 'Placeholder'], placeholder => $block[0], ); } elsif $block { @params := $block; %sig_info := @params; if $*IMPLICIT { $block[0].push(QAST::Op.new( :op('bind'), QAST::Var.new( :name('$_'), :scope('lexical') ), QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ) )); } } elsif $ { %sig_info := $.ast; @params := %sig_info; if $*IMPLICIT { $block[0].push(QAST::Op.new( :op('bind'), QAST::Var.new( :name('$_'), :scope('lexical') ), QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ) )); } } else { if $*IMPLICIT { @params.push(hash( :variable_name('$_'), :optional(1), :nominal_type($*W.find_symbol(['Mu'])), :default_from_outer(1), :is_parcel(1), )); } elsif !$block.symbol('$_') { $block[0].push(QAST::Op.new( :op('bind'), QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') ), QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ) )); $block.symbol('$_', :scope('lexical'), :type($*W.find_symbol(['Mu']))); } %sig_info := @params; } # Create signature object and set up binding. if $ eq '<->' { for @params { $_ := 1 } } set_default_parameter_type(@params, 'Mu'); my $signature := create_signature_object($, %sig_info, $block); add_signature_binding_code($block, $signature, @params); # Add a slot for a $*DISPATCHER, and a call to take one. $block[0].push(QAST::Var.new( :name('$*DISPATCHER'), :scope('lexical'), :decl('var') )); $block[0].push(QAST::Op.new( :op('takedispatcher'), QAST::SVal.new( :value('$*DISPATCHER') ) )); # We'll install PAST in current block so it gets capture_lex'd. # Then evaluate to a reference to the block (non-closure - higher # up stuff does that if it wants to). ($*W.cur_lexpad())[0].push(my $uninst := QAST::Stmts.new($block)); $*W.attach_signature($*DECLARAND, $signature); $*W.finish_code_object($*DECLARAND, $block); $*W.add_phasers_handling_code($*DECLARAND, $block); my $ref := reference_to_code_object($*DECLARAND, $block); $ref := $uninst; make $ref; } } method block($/) { my $block := $.ast; if $block { my $name := $block[0]; unless $name eq '%_' || $name eq '@_' { $name := nqp::concat(nqp::substr($name, 0, 1), nqp::concat('^', nqp::substr($name, 1))); } $*W.throw( $/, ['X', 'Placeholder', 'Block'], placeholder => $name, ); } ($*W.cur_lexpad())[0].push(my $uninst := QAST::Stmts.new($block)); $*W.attach_signature($*DECLARAND, $*W.create_signature(nqp::hash('parameters', []))); $*W.finish_code_object($*DECLARAND, $block); $*W.add_phasers_handling_code($*DECLARAND, $block); my $ref := reference_to_code_object($*DECLARAND, $block); $ref := $uninst; make $ref; } method blockoid($/) { if $ { my $past := $.ast; if %*HANDLERS { $past := QAST::Op.new( :op('handle'), $past ); for %*HANDLERS { $past.push($_.key); $past.push($_.value); } } my $BLOCK := $*CURPAD; $BLOCK.push($past); $BLOCK.node($/); $BLOCK := $.ast; $BLOCK := %*HANDLERS if %*HANDLERS; make $BLOCK; } else { if $*HAS_YOU_ARE_HERE { $/.CURSOR.panic('{YOU_ARE_HERE} may only appear once in a setting'); } $*HAS_YOU_ARE_HERE := 1; make $.ast; } } method you_are_here($/) { make self.CTXSAVE(); } method newpad($/) { my $new_block := $*W.cur_lexpad(); $new_block := $*IN_DECL; } method finishpad($/) { # Generate the $_, $/, and $! lexicals for routines if they aren't # already declared. For blocks, $_ will come from the outer if it # isn't already declared. my $BLOCK := $*W.cur_lexpad(); my $type := $BLOCK; if $type eq 'mainline' && %*COMPILING<%?OPTIONS> eq 'NULL' { # Don't do anything in the case where we are in the mainline of # the setting; we don't have any symbols (Scalar, etc.) yet. return 1; } my $is_routine := $type eq 'sub' || $type eq 'method' || $type eq 'submethod' || $type eq 'mainline'; if $is_routine { # Generate the lexical variable except if... # (1) the block already has one, or # (2) the variable is '$_' and $*IMPLICIT is set # (this case gets handled by getsig) for <$_ $/ $!> { unless $BLOCK.symbol($_) || ($_ eq '$_' && $*IMPLICIT) { $*W.install_lexical_magical($BLOCK, $_); } } } else { unless $BLOCK.symbol('$_') { if $*IMPLICIT { $BLOCK[0].push(QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') )); } else { $BLOCK[0].push(QAST::Op.new( :op('bind'), QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') ), QAST::Op.new( :op('getlexouter'), QAST::SVal.new( :value('$_') ) ) )); } $BLOCK.symbol('$_', :scope('lexical'), :type($*W.find_symbol(['Mu']))); } } } ## Statement control method statement_control:sym($/) { my $count := +$ - 1; my $past := xblock_immediate( $[$count].ast ); # push the else block if any, otherwise 'if' returns C (per S04) $past.push( $ ?? pblock_immediate( $.ast ) !! QAST::Var.new(:name('Nil'), :scope('lexical')) ); # build if/then/elsif structure while $count > 0 { $count--; my $else := $past; $past := xblock_immediate( $[$count].ast ); $past.push($else); } make $past; } method statement_control:sym($/) { my $past := xblock_immediate( $.ast ); $past.op('unless'); make $past; } method statement_control:sym($/) { my $past := xblock_immediate( $.ast ); $past.op(~$); make tweak_loop($past); } method statement_control:sym($/) { my $op := 'repeat_' ~ ~$; my $past; if $ { $past := xblock_immediate( $.ast ); $past.op($op); } else { $past := QAST::Op.new( $.ast, pblock_immediate( $.ast ), :op($op), :node($/) ); } make tweak_loop($past); } method statement_control:sym($/) { my $xblock := $.ast; my $past := QAST::Op.new( :op, :name, :node($/), QAST::Op.new(:name('&infix:<,>'), :op('call'), $xblock[0]), block_closure($xblock[1]) ); $past := QAST::Want.new( QAST::Op.new( :op, :name, $past ), 'v', QAST::Op.new( :op, :name, $past )); make $past; } method statement_control:sym($/) { my $block := pblock_immediate($.ast); my $cond := $ ?? $.ast !! QAST::Var.new(:name, :scope); my $loop := QAST::Op.new( $cond, :op('while'), :node($/) ); $loop.push($block); if $ { $loop.push($.ast); } $loop := tweak_loop($loop); if $ { $loop := QAST::Stmts.new( $.ast, $loop, :node($/) ); } make $loop; } sub tweak_loop($loop) { # Make sure the body is in sink context (for now; in the long run, # need to handle the l-value case). my $body_past := $loop[1][1]; $body_past.push(QAST::Var.new( :name('Nil'), :scope('lexical') )); # Handle phasers. my $code := $loop[1]; my $block_type := $*W.find_symbol(['Block']); my $phasers := nqp::getattr($code, $block_type, '$!phasers'); unless nqp::isnull($phasers) { if nqp::existskey($phasers, 'NEXT') { my $phascode := $*W.run_phasers_code($code, $block_type, 'NEXT'); if +@($loop) == 2 { $loop.push($phascode); } else { $loop[2] := QAST::Stmts.new($phascode, $loop[2]); } } if nqp::existskey($phasers, 'FIRST') { $loop := QAST::Stmts.new( QAST::Op.new( :op('p6setfirstflag'), QAST::WVal.new( :value($code) ) ), $loop); } if nqp::existskey($phasers, 'LAST') { $loop := QAST::Stmts.new( :resultchild(0), $loop, $*W.run_phasers_code($code, $block_type, 'LAST')); } } $loop } method statement_control:sym($/) { my $past := QAST::Var.new( :name('Nil'), :scope('lexical') ); for $ { # XXX TODO: Version checks. } make $past; } method statement_control:sym($/) { my $past := QAST::Var.new( :name('Nil'), :scope('lexical') ); make $past; } method statement_control:sym($/) { my $past := QAST::Var.new( :name('Nil'), :scope('lexical') ); if $ { # TODO: replace this by code that doesn't always die with # a useless error message # my $i := -1; # for $ { # ++$i; # if $_ ne '*' && $_ < @MAX_PERL_VERSION[$i] { # last; # } elsif $_ > @MAX_PERL_VERSION[$i] { # my $mpv := nqp::join('.', @MAX_PERL_VERSION); # $/.CURSOR.panic("Perl $ required--this is only v$mpv") # } # } } elsif $ { if ~$ eq 'fatal' { my $*SCOPE := 'my'; declare_variable($/, QAST::Stmts.new(), '$', '*', 'FATAL', []); $past := QAST::Op.new( :op('p6store'), :node($/), QAST::Var.new( :name('$*FATAL'), :scope('lexical') ), QAST::Op.new( :op('p6bool'), QAST::IVal.new( :value(1) ) ) ); } elsif ~$ eq 'FORBID_PIR' { $FORBID_PIR := 1; } elsif ~$ eq 'Devel::Trace' { $STATEMENT_PRINT := 1; } } make $past; } method statement_control:sym($/) { my $past := QAST::Stmts.new(:node($/)); my $name_past := $ ?? $*W.dissect_longname($).name_past() !! $.ast; my $op := QAST::Op.new( :op('callmethod'), :name('load_module'), QAST::Op.new( :op('getcurhllsym'), QAST::SVal.new( :value('ModuleLoader') ) ), $name_past, QAST::Op.new( :op('hash') ), $*W.symbol_lookup(['GLOBAL'], $/), ); if $ { for $ -> $colonpair { $op.push( QAST::Op.new( :named(~$colonpair), :op, :name, $colonpair.ast ) ); } } else { $op.push( QAST::Op.new( :named, :op, :name, $.ast ) ); } $past.push($op); if $ { my $p6_arglist := $*W.compile_time_evaluate($/, $.ast).list.eager; my $arglist := nqp::getattr($p6_arglist, $*W.find_symbol(['List']), '$!items'); my $lexpad := $*W.cur_lexpad(); my $*SCOPE := 'my'; my $import_past := QAST::Op.new(:node($/), :op, :name<&REQUIRE_IMPORT>, $name_past); for $arglist { my $symbol := nqp::unbox_s($_.Str()); $*W.throw($/, ['X', 'Redeclaration'], :$symbol) if $lexpad.symbol($symbol); declare_variable($/, $past, nqp::substr($symbol, 0, 1), '', nqp::substr($symbol, 1), []); $import_past.push($*W.add_string_constant($symbol)); } $past.push($import_past); } $past.push(QAST::Var.new( :name('Nil'), :scope('lexical') )); make $past; } method statement_control:sym($/) { my $past := $.ast; $past.push($past.shift); # swap [0] and [1] elements $past.op('call'); make $past; } method statement_control:sym($/) { # Get hold of the smartmatch expression and the block. my $xblock := $.ast; my $sm_exp := $xblock.shift; my $pblock := $xblock.shift; # Handle the smart-match. my $match_past := QAST::Op.new( :op('callmethod'), :name('ACCEPTS'), $sm_exp, QAST::Var.new( :name('$_'), :scope('lexical') ) ); # Use the smartmatch result as the condition for running the block, # and ensure continue/succeed handlers are in place and that a # succeed happens after the block. $pblock := pblock_immediate($pblock); make QAST::Op.new( :op('if'), :node( $/ ), $match_past, when_handler_helper($pblock) ); } method statement_control:sym($/) { # We always execute this, so just need the block, however we also # want to make sure we succeed after running it. make when_handler_helper($.ast); } method term:sym($/) { my @inner_statements := $; my $wild_done; my $wild_more; my $wait; my $wait_time; my $past := QAST::Op.new( :op('call'), :name('&WINNER'), :node($/) ); if $ { if nqp::istype($.ast.returns, $*W.find_symbol(['Whatever'])) { $past.push( QAST::Op.new( :op('callmethod'), :name('new'), QAST::WVal.new( :value($*W.find_symbol(['List'])) ) )); } else { $past.push( QAST::Op.new(:name('&infix:<,>'), :op('call'), $.ast) ); } } elsif $ { $past.push( QAST::Op.new( :op('callmethod'), :name('new'), QAST::WVal.new( :value($*W.find_symbol(['List'])) ) )); } # TODO verify that the inner block only has more/done/later blocks in it for @inner_statements -> $/ { if $ -> $/ { if $ eq 'done' || $ eq 'more' { if $ eq 'done' { if nqp::istype($.ast.returns, $*W.find_symbol(['Whatever'])) { # TODO error $wild_done := block_closure($.ast); $wild_done.named('wild_done'); } else { $past.push(QAST::IVal.new(:value(0))); # "DONE" $past.push($.ast); $past.push(block_closure($.ast)); } } elsif $ eq 'more' { if nqp::istype($.ast.returns, $*W.find_symbol(['Whatever'])) { $wild_more := block_closure($.ast); $wild_more.named('wild_more'); } else { $past.push(QAST::IVal.new(:value(1))); # "MORE" $past.push($.ast); $past.push(block_closure($.ast)); } } } elsif $ eq 'wait' { # TODO error $wait_time:= $.ast; $wait_time.named('wait_time'); $wait := block_closure($.ast); $wait.named('wait'); } } else { # TODO error } } if $wild_done { $past.push( $wild_done ) } if $wild_more { $past.push( $wild_more ) } if $wait { $past.push( $wait ); $past.push( $wait_time ) } make $past; } method term:sym($/) { $*W.throw($/, ['X', 'NYI'], feature => 'combine blocks'); } method statement_control:sym($/) { $*W.throw($/, ['X', 'NYI'], feature => 'combine blocks (and "quit")'); } method statement_control:sym($/) { if nqp::existskey(%*HANDLERS, 'CATCH') { $*W.throw($/, ['X', 'Phaser', 'Multiple'], block => 'CATCH'); } my $block := $.ast; set_block_handler($/, $block, 'CATCH'); make QAST::Var.new( :name('Nil'), :scope('lexical') ); } method statement_control:sym($/) { if nqp::existskey(%*HANDLERS, 'CONTROL') { $*W.throw($/, ['X', 'Phaser', 'Multiple'], block => 'CONTROL'); } my $block := $.ast; set_block_handler($/, $block, 'CONTROL'); make QAST::Var.new( :name('Nil'), :scope('lexical') ); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'BEGIN', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'COMPOSE', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'CHECK', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'INIT', ($.ast), ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'ENTER', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'FIRST', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'END', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'LEAVE', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'KEEP', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'UNDO', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'NEXT', ($.ast)); } method statement_prefix:sym($/) { make $*W.add_phaser($/, 'LAST', ($.ast)); } method statement_prefix:sym

($/)   { make $*W.add_phaser($/, 'PRE', ($.ast), ($.ast)); }
    method statement_prefix:sym($/)  { make $*W.add_phaser($/, 'POST', ($.ast), ($.ast)); }

    method statement_prefix:sym($/)   {
        $*W.add_phaser($/, ~$, ($.ast))
            if %*COMPILING<%?OPTIONS>;
    }

    method statement_prefix:sym($/) {
        make QAST::Op.new( :op('call'), $.ast );
    }

    method statement_prefix:sym($/) {
        my $past := block_closure($.ast);
        $past.push(QAST::Var.new( :name('Nil'), :scope('lexical') ));
        make QAST::Op.new( :op('call'), :name('&GATHER'), $past );
    }

    method statement_prefix:sym($/) {

        # create state variable to remember whether we ran the block
        my $pad := $*W.cur_lexpad();
        my $sym := $pad.unique('once_');
        my $mu := $*W.find_symbol(['Mu']);
        my $descriptor := $*W.create_container_descriptor($mu, 1, $sym);
        my %info;
        %info := %info := $*W.find_symbol(['Scalar']);
        %info := %info := %info := %info := $mu;
        $*W.install_lexical_container($pad, $sym, %info, $descriptor, :scope('state'));

        # generate code that runs the block only once
        make QAST::Op.new(
            :op('if'),
            QAST::Op.new( :op('p6stateinit') ),
            QAST::Op.new(
                :op('p6store'),
                QAST::Var.new( :name($sym), :scope('lexical') ),
                QAST::Op.new( :op('call'), $.ast )
            ),
            QAST::Var.new( :name($sym), :scope('lexical') )
        );
    }

    method statement_prefix:sym($/) {
        my $blast := QAST::Op.new( :op('call'), $.ast );
        make QAST::Stmts.new(
            QAST::Op.new( :name('&eager'), :op('call'), $blast ),
            QAST::Var.new( :name('Nil'), :scope('lexical')),
            :node($/)
        );
    }

    method statement_prefix:sym($/) {
        my $block := $.ast;
        my $past;
        if $block && $block {
            # we already have a CATCH block, nothing to do here
            $past := QAST::Op.new( :op('call'), $block );
        } else {
            $block := QAST::Op.new(:op, $block); # XXX should be immediate
            $past := QAST::Op.new(
                :op('handle'),
                
                # Success path puts Any into $! and evaluates to the block.
                QAST::Stmt.new(
                    :resultchild(0),
                    $block,
                    QAST::Op.new(
                        :op('p6store'),
                        QAST::Var.new( :name<$!>, :scope ),
                        QAST::Var.new( :name, :scope )
                    )
                ),

                # On failure, capture the exception object into $!.
                'CATCH', QAST::Stmts.new(
                    QAST::Op.new(
                        :op('p6store'),
                        QAST::Var.new(:name<$!>, :scope),
                        QAST::Op.new(
                            :name<&EXCEPTION>, :op,
                            QAST::Op.new( :op('exception') )
                        ),
                    ),
                    QAST::VM.new(
                        :parrot(QAST::VM.new(
                            pirop => 'perl6_invoke_catchhandler 1PP',
                            QAST::Op.new( :op('null') ),
                            QAST::Op.new( :op('exception') )
                        )),
                        :jvm(QAST::Op.new( :op('null') ))
                    ),
                    QAST::WVal.new(
                        :value( $*W.find_symbol(['Nil']) ),
                    ),
                )
            );
        }
        make $past;
    }

    method blorst($/) {
        make $ ?? $.ast !! make_thunk_ref($.ast, $/);
    }

    # Statement modifiers

    method modifier_expr($/) { make $.ast; }

    method statement_mod_cond:sym($/)     {
        make QAST::Op.new( :op, $.ast, :node($/) );
    }

    method statement_mod_cond:sym($/) {
        make QAST::Op.new( :op, $.ast, :node($/) );
    }

    method statement_mod_cond:sym($/) {
        make QAST::Op.new( :op,
            QAST::Op.new( :name('ACCEPTS'), :op('callmethod'),
                          $.ast, 
                          QAST::Var.new( :name('$_'), :scope('lexical') ) ),
            :node($/)
        );
    }

    method statement_mod_loop:sym($/)  { make $.ast; }
    method statement_mod_loop:sym($/)  { make $.ast; }
    method statement_mod_loop:sym($/)    { make $.ast; }
    method statement_mod_loop:sym($/)  { make $.ast; }

    ## Terms

    method term:sym($/)           { make $.ast; }
    method term:sym($/)          { make $.ast; }
    method term:sym($/)           { make $.ast; }
    method term:sym($/) { make $.ast; }
    method term:sym($/)   { make $.ast; }
    method term:sym($/) { make $.ast; }
    method term:sym($/)   { make $.ast; }
    method term:sym($/)   { make $.ast; }
    method term:sym($/)    { make $.ast; }
    method term:sym($/)          { make $.ast; }
    method term:sym($/)   { make $.ast; }
    method term:sym($/)             { make block_closure($.ast); }
    method term:sym($/)            { make $.ast; }
    method term:sym($/) {
        make QAST::Unquote.new(:position(+@*UNQUOTE_ASTS));
        @*UNQUOTE_ASTS.push($.ast);
    }

    method name($/) { }

    method fatarrow($/) {
        make make_pair($.Str, $.ast);
    }
    
    method coloncircumfix($/) {
        make $
            ?? $.ast
            !! QAST::Var.new( :name('Nil'), :scope('lexical') );
    }

    method colonpair($/) {
        if $*key {
            if $ {
                make make_pair($*key, $.ast);
            }
            elsif $*value ~~ NQPMatch {
                my $val_ast := $*value.ast;
                if $val_ast.isa(QAST::Stmts) && +@($val_ast) == 1 {
                    $val_ast := $val_ast[0];
                }
                make make_pair($*key, $val_ast);
            }
            else {
                make make_pair($*key, QAST::Op.new(
                    :op('p6bool'),
                    QAST::IVal.new( :value($*value) ) 
                ));
            }
        }
        elsif $ {
            make $.ast;
        }
        else {
            make $*value.ast;
        }
    }
    
    method colonpair_variable($/) {
        if $ {
            make QAST::Op.new(
                :op('call'),
                :name('&postcircumfix:<{ }>'),
                QAST::Var.new(:name('$/'), :scope('lexical')),
                $*W.add_string_constant(~$)
            );
        }
        else {
            make make_variable($/, [~$/]);
        }
    }

    sub make_pair($key_str, $value) {
        my $key := $*W.add_string_constant($key_str);
        $key.named('key');
        $value.named('value');
        QAST::Op.new(
            :op('callmethod'), :name('new'), :returns($*W.find_symbol(['Pair'])),
            QAST::Var.new( :name('Pair'), :scope('lexical') ),
            $key, $value
        )
    }
    
    method desigilname($/) {
        if $ {
            make QAST::Op.new( :op('callmethod'), $.ast );
        }
    }

    method variable($/) {
        my $past;
        if $ {
            $past := QAST::Op.new(
                :op('call'),
                :name('&postcircumfix:<[ ]>'),
                QAST::Var.new(:name('$/'), :scope('lexical')),
                $*W.add_constant('Int', 'int', +$),
            );
        }
        elsif $ {
            $past := $.ast;
            $past.unshift( QAST::Var.new( :name('$/'), :scope('lexical') ) );
        }
        elsif $ {
            $past := $.ast;
            if $ eq '$' && ~$ eq '' { # for '$()'
                my $result_var := $past.unique('sm_result');
                $past := QAST::Stmt.new(
                    # Evaluate RHS and call ACCEPTS on it, passing in $_. Bind the
                    # return value to a result variable.
                    QAST::Op.new( :op('bind'),
                        QAST::Var.new( :name($result_var), :scope('local'), :decl('var') ),
                        QAST::Op.new(
                            :op('if'),
                            # condition
                            QAST::Op.new(
                                :op('callmethod'), :name('ast'),
                                QAST::Var.new( :name('$/'), :scope('lexical') )
                            ),
                            # when true
                            QAST::Op.new(
                                :op('callmethod'), :name('ast'),
                                QAST::Var.new( :name('$/'), :scope('lexical') )
                            ),
                            # when false
                            QAST::Op.new(
                                :op('callmethod'), :name('Str'),
                                QAST::Var.new( :name('$/'), :scope('lexical') )
                            )
                        )
                    ),
                    # And finally evaluate to the smart-match result.
                    QAST::Var.new( :name($result_var), :scope('local') )
                );
                $past := QAST::Op.new( :op('locallifetime'), $past, $result_var );
            }
            else {
                my $name := ~$ eq '@' ?? 'list' !!
                            ~$ eq '%' ?? 'hash' !!
                                                'item';
                # @() and %()
                $past := QAST::Var.new( :name('$/'), :scope('lexical') ) if ~$ eq '';

                $past := QAST::Op.new( :op('callmethod'), :name($name), $past );
            }
        }
        elsif $ {
            my $name := '&infix:<' ~ $.Str ~ '>';
            $past := QAST::Op.new(
                :op('ifnull'),
                QAST::Var.new( :name($name), :scope('lexical') ),
                QAST::Op.new(
                    :op('die_s'),
                    QAST::SVal.new( :value("Could not find sub $name") )
                ));
        }
        elsif $ {
            $past := $.ast;
            $past.name(~$ eq '@' ?? 'list' !!
                       ~$ eq '%' ?? 'hash' !!
                                           'item');
        }
        else {
            my $indirect;
            if $ && $ {
                my $longname := $*W.dissect_longname($);
                if $longname.contains_indirect_lookup() {
                    if $*IN_DECL {
                        $*W.throw($/, ['X', 'Syntax', 'Variable', 'IndirectDeclaration']);
                    }
                    $past := self.make_indirect_lookup($longname.components(), ~$);
                    $indirect := 1;
                }
                else {
                    $past := make_variable($/, $longname.variable_components(
                        ~$, $ ?? ~$ !! ''));
                }
            }
            else {
                $past := make_variable($/, [~$/]);
            }
        }
        if $*IN_DECL eq 'variable' {
            $past := 1;
        }
        make $past;
    }

    sub make_variable($/, @name) {
        make_variable_from_parts($/, @name, $.Str, $, ~$);
    }

    sub make_variable_from_parts($/, @name, $sigil, $twigil, $desigilname) {
        my $past := QAST::Var.new( :name(@name[+@name - 1]), :node($/));
        if $twigil eq '*' {
            $past := QAST::Op.new(
                :op('call'), :name('&DYNAMIC'),
                $*W.add_string_constant($past.name()));
        }
        elsif $twigil eq '!' {
            # In a declaration, don't produce anything here.
            if $*IN_DECL ne 'variable' {
                unless $*HAS_SELF {
                    $*W.throw($/, ['X', 'Syntax', 'NoSelf'], variable => $past.name());
                }
                my $attr := get_attribute_meta_object($/, $past.name(), $past);
                $past.returns($attr.type) if $attr;
                $past.scope('attribute');
                $past.unshift(instantiated_type(['$?CLASS'], $/));
                $past.unshift(QAST::Var.new( :name('self'), :scope('lexical') ));
            }
        }
        elsif $twigil eq '.' && $*IN_DECL ne 'variable' {
            if !$*HAS_SELF {
                $*W.throw($/, ['X', 'Syntax', 'NoSelf'], variable => $past.name());
            } elsif $*HAS_SELF eq 'partial' {
                $*W.throw($/, ['X', 'Syntax', 'VirtualCall'], call => $past.name());
            }
            # Need to transform this to a method call.
            $past := $ ?? $.ast !! QAST::Op.new();
            $past.op('callmethod');
            $past.name($desigilname);
            $past.unshift(QAST::Var.new( :name('self'), :scope('lexical') ));
            # Contextualize based on sigil.
            $past := QAST::Op.new(
                :op('callmethod'),
                :name($sigil eq '@' ?? 'list' !!
                      $sigil eq '%' ?? 'hash' !!
                      'item'),
                $past);
        }
        elsif $twigil eq '^' || $twigil eq ':' {
            $past := add_placeholder_parameter($/, $sigil, $desigilname,
                                :named($twigil eq ':'), :full_name($past.name()));
        }
        elsif $past.name() eq '@_' {
            if $*W.nearest_signatured_block_declares('@_') {
                $past.scope('lexical');
            }
            else {
                $past := add_placeholder_parameter($/, '@', '_',
                                :pos_slurpy(1), :full_name($past.name()));
            }
        }
        elsif $past.name() eq '%_' {
            if $*W.nearest_signatured_block_declares('%_') || $*METHODTYPE {
                $past.scope('lexical');
            }
            else {
                $past := add_placeholder_parameter($/, '%', '_', :named_slurpy(1),
                                :full_name($past.name()));
            }
        }
        elsif $past.name() eq '$?LINE' || $past.name eq '$?FILE' {
            if $*IN_DECL eq 'variable' {
                $*W.throw($/, 'X::Syntax::Variable::Twigil',
                        twigil  => '?',
                        scope   => $*SCOPE,
                );
            }
            if $past.name() eq '$?LINE' {
                $past := $*W.add_constant('Int', 'int',
                        HLL::Compiler.lineof($/.orig, $/.from, :cache(1)));
            }
            else {
                $past := $*W.add_string_constant(nqp::getlexdyn('$?FILES') // '');
            }
        }
        elsif +@name > 1 {
            $past := $*W.symbol_lookup(@name, $/, :lvalue(1));
        }
        elsif $*IN_DECL ne 'variable' && (my $attr_alias := $*W.is_attr_alias($past.name)) {
            $past.name($attr_alias);
            $past.scope('attribute');
            $past.unshift(instantiated_type(['$?CLASS'], $/));
            $past.unshift(QAST::Var.new( :name('self'), :scope('lexical') ));
        }
        elsif $*IN_DECL ne 'variable' {
            # Expect variable to have been declared somewhere.
            # Locate descriptor and thus type.
            $past.scope('lexical');
            try {
                my $type := $*W.find_lexical_container_type($past.name);
                $past.returns($type);
            }
            
            # If it's a late-bound sub lookup, we may not find it, so be sure
            # to handle the case where the lookup comes back null.
            if $sigil eq '&' {
                $past := QAST::Op.new(
                    :op('ifnull'), $past,
                    QAST::Var.new(:name('Nil'), :scope('lexical')));
            }
        }
        $past
    }
    
    sub get_attribute_meta_object($/, $name, $later?) {
        unless nqp::can($*PACKAGE.HOW, 'get_attribute_for_usage') {
            $/.CURSOR.panic("Cannot understand $name in this context");
        }
        my $attr;
        my int $found := 0;
        try {
            $attr := $*PACKAGE.HOW.get_attribute_for_usage($*PACKAGE, $name);
            $found := 1;
        }
        unless $found {

            # need to check later
            if $later {
                my $seen := %*ATTR_USAGES{$name};
                unless $seen {
                    %*ATTR_USAGES{$name} := $seen := nqp::list();
                    $later.node($/); # only need $/ for first error
                }
                $seen.push($later);
            }

            # now is later
            else {
                $*W.throw($/, ['X', 'Attribute', 'Undeclared'],
                  symbol       => $name,
                  package-kind => $*PKGDECL,
                  package-name => $*PACKAGE.HOW.name($*PACKAGE),
                  what         => 'attribute',
                );
            }
        }
        $attr
    }

    method package_declarator:sym($/) { make $.ast; }
    method package_declarator:sym($/)  { make $.ast; }
    method package_declarator:sym($/)   { make $.ast; }
    method package_declarator:sym($/) { make $.ast; }
    method package_declarator:sym($/)    { make $.ast; }
    method package_declarator:sym($/) { make $.ast; }
    method package_declarator:sym($/)  { make $.ast; }

    method package_declarator:sym($/) {
        $*W.apply_trait($/, '&trait_mod:', $*PACKAGE, $.ast);
    }

    method package_declarator:sym($/) {
        for $ {
            if $_.ast { ($_.ast)($*DECLARAND) }
        }
    }

    method package_def($/) {
        # Get the body block PAST.
        my $block;
        if $ {
            $block := $.ast;
        }
        else {
            $block := $*CURPAD;
            $block.push($.ast);
            $block.node($/);
        }
        $block.blocktype('immediate');

        if $*PKGDECL ne 'role' && $block {
            my $name := $block[0];
            unless $name eq '%_' || $name eq '@_' {
                $name := nqp::concat(nqp::substr($name, 0, 1),
                        nqp::concat('^', nqp::substr($name, 1)));
            }
            $*W.throw( $/, ['X', 'Placeholder', 'Block'],
                placeholder => $name,
            );
        }

        # If it's a stub, add it to the "must compose at some point" list,
        # then just evaluate to the type object. Don't need to do any more
        # just yet.
        if nqp::substr($[0], 0, 3) eq '...' {
            unless $*PKGDECL eq 'role' {
                $*W.add_stub_to_check($*PACKAGE);
            }
            $block.blocktype('declaration');
            make QAST::Stmts.new( $block, QAST::WVal.new( :value($*PACKAGE) ) );
            return 1;
        }

        # Handle parametricism for roles.
        if $*PKGDECL eq 'role' {
            # Set up signature. Needs to have $?CLASS as an implicit
            # parameter, since any mention of it is generic.
            my %sig_info := $ ?? $.ast !! hash(parameters => []);
            my @params := %sig_info;
            @params.unshift(hash(
                is_multi_invocant => 1,
                type_captures     => ['$?CLASS', '::?CLASS']
            ));
            set_default_parameter_type(@params, 'Mu');
            my $sig := create_signature_object($, %sig_info, $block);
            add_signature_binding_code($block, $sig, @params);
            $block.blocktype('declaration');

            # Need to ensure we get lexical outers fixed up properly. To
            # do this we make a list of closures, which each point to the
            # outer context. These surive serialization and thus point at
            # what has to be fixed up.
            my $throwaway_block_past := QAST::Block.new( 
                :blocktype('declaration'),
                QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') )
            );
            $throwaway_block_past := $block;
            $block[0].push($throwaway_block_past);
            my $throwaway_block := $*W.create_code_object($throwaway_block_past,
                'Block', $*W.create_signature(nqp::hash('parameters', [])));
            my $fixup := $*W.create_lexical_capture_fixup();
            $fixup.push(QAST::Op.new(
                :op('callmethod'), :name('clone'),
                QAST::Op.new(
                    :op('p6capturelex'),
                    QAST::WVal.new( :value($throwaway_block) )
                )));
            $block[1].push($fixup);

            # As its last act, it should grab the current lexpad so that
            # we have the type environment, and also return the parametric
            # role we're in (because if we land it through a multi-dispatch,
            # we won't know).
            $block[1].push(QAST::Op.new(
                :op('list'),
                QAST::WVal.new( :value($*PACKAGE) ),
                QAST::Op.new( :op('curlexpad') )));

            # Create code object and add it as the role's body block.
            my $code := $*W.create_code_object($block, 'Sub', $sig);
            $*W.pkg_set_role_body_block($/, $*PACKAGE, $code, $block);
            
            # Compose before we add the role to the group, so the group sees
            # it composed.
            $*W.pkg_compose($*PACKAGE);
            
            # Add this role to the group if needed.
            my $group := $*PACKAGE.HOW.group($*PACKAGE);
            unless $group =:= $*PACKAGE {
                $*W.pkg_add_role_group_possibility($/, $group, $*PACKAGE);
            }
        }
        else {
            # Compose.
            $*W.pkg_compose($*PACKAGE);
            
            # Make a code object for the block.
            $*W.create_code_object($block, 'Block',
                $*W.create_signature(nqp::hash('parameters', [])));
        }

        # check up any private attribute usage
        for %*ATTR_USAGES {
            my $name   := $_.key;
            my @usages := $_.value;
            for @usages {
                my $past := $_;
                my $attr := get_attribute_meta_object($past.node, $name);
                $past.returns($attr.type);
            }
        }

        # Document
        Perl6::Pod::document($/, $*PACKAGE, $*DOC);

        make QAST::Stmts.new(
            $block, QAST::WVal.new( :value($*PACKAGE) )
        );
    }

    method scope_declarator:sym($/)      { make $.ast; }
    method scope_declarator:sym($/)     { make $.ast; }
    method scope_declarator:sym($/)     { make $.ast; }
    method scope_declarator:sym($/)    { make $.ast; }
    method scope_declarator:sym($/) { make $.ast; }
    method scope_declarator:sym($/)   { make $.ast; }

    method declarator($/) {
        if    $  { make $.ast  }
        elsif $    { make $.ast    }
        elsif $     { make $.ast     }
        elsif $ {
            my $past := $.ast;
            if $ {
                my $orig_past := $past;
                if $*SCOPE eq 'has' {
                    if $ eq '=' {
                        self.install_attr_init($, $past,
                            $.ast, $*ATTR_INIT_BLOCK);
                    }
                    else {
                        $/.CURSOR.panic("Cannot use " ~ $ ~
                            " to initialize an attribute");
                    }
                }
                elsif $ eq '=' {
                    $past := assign_op($/, $past, $.ast);
                }
                elsif $ eq '.=' {
                    $past := make_dot_equals($past, $.ast);
                }
                else {
                    $past := bind_op($/, $past, $.ast,
                        $ eq '::=');
                }
                if $*SCOPE eq 'state' {
                    $past := QAST::Op.new( :op('if'),
                        QAST::Op.new( :op('p6stateinit') ),
                        $past,
                        $orig_past);
                    $past := 1;
                }
            }
            make $past;
        }
        elsif $ {
            # Go over the params and declare the variable defined
            # in them.
            my $list   := QAST::Op.new( :op('call'), :name('&infix:<,>') );
            my @params := $.ast;
            for @params {
                if $_ {
                    my $past := QAST::Var.new( :name($_) );
                    $past := declare_variable($/, $past, $_, $_,
                        $_, []);
                    unless $past.isa(QAST::Op) && $past.op eq 'null' {
                        $list.push($past);
                    }
                }
                else {
                    my %cont_info := container_type_info($/, $_ || '$', []);
                    $list.push($*W.build_container_past(
                      %cont_info,
                      $*W.create_container_descriptor(
                        %cont_info, 1, 'anon', %cont_info)));
                }
            }
            
            if $ {
                my $orig_list := $list;
                if $ eq '=' {
                    $/.CURSOR.panic("Cannot assign to a list of 'has' scoped declarations")
                        if $*SCOPE eq 'has';
                    $list := assign_op($/, $list, $.ast);
                }
                elsif $ eq '.=' {
                    $/.CURSOR.panic("Cannot use .= initializer with a list of declarations");
                }
                else {
                    my %sig_info := $.ast;
                    my @params := %sig_info;
                    set_default_parameter_type(@params, 'Mu');
                    my $signature := create_signature_object($/, %sig_info, $*W.cur_lexpad());
                    $list := QAST::Op.new(
                        :op('p6bindcaptosig'),
                        QAST::WVal.new( :value($signature) ),
                        QAST::Op.new(
                            :op('callmethod'), :name('Capture'),
                            $.ast
                        )
                    );
                }
                if $*SCOPE eq 'state' {
                    $list := QAST::Op.new( :op('if'),
                        QAST::Op.new( :op('p6stateinit') ),
                        $list, $orig_list);
                }
            }
            
            make $list;
        }
        elsif $ {
            # 'my \foo' style declaration
            if $*SCOPE ne 'my' {
                $*W.throw($/, 'X::Comp::NYI',
                    feature => "$*SCOPE scoped term definitions (only 'my' is supported at the moment)");
            }
            my $name       :=  ~$;
            my $cur_lexpad := $*W.cur_lexpad;
            if $cur_lexpad.symbol($name) {
                $*W.throw($/, ['X', 'Redeclaration'], symbol => $name);
            }
            if $*OFTYPE {
                my $type := $*OFTYPE.ast;
                $cur_lexpad[0].push(QAST::Var.new( :$name, :scope('lexical'),
                    :decl('var'), :returns($type) ));
                $cur_lexpad.symbol($name, :$type, :scope);
                make QAST::Op.new(
                    :op,
                    QAST::Var.new(:$name, :scope),
                    QAST::Op.new(
                        :op('p6bindassert'),
                        $.ast,
                        QAST::WVal.new( :value($type) ),
                    )
                );
            }
            else {
                $cur_lexpad[0].push(QAST::Var.new(:$name, :scope('lexical'), :decl('var')));
                $cur_lexpad.symbol($name, :scope('lexical'));
                make QAST::Op.new(
                    :op,
                    QAST::Var.new(:$name, :scope),
                    $.ast
                );
                }
        }
        else {
            $/.CURSOR.panic('Unknown declarator type');
        }
    }

    method multi_declarator:sym($/) { make $ ?? $.ast !! $.ast }
    method multi_declarator:sym($/) { make $ ?? $.ast !! $.ast }
    method multi_declarator:sym($/)  { make $ ?? $.ast !! $.ast }
    method multi_declarator:sym($/)  { make $.ast }

    method scoped($/) {
        make $.ast;
    }

    method variable_declarator($/) {
        my $past   := $.ast;
        my $sigil  := $;
        my $twigil := $;
        my $name   := ~$sigil ~ ~$twigil ~ ~$;
        if $ {
            my $lex := $*W.cur_lexpad();
            if $lex.symbol($name) {
                $/.CURSOR.typed_worry('X::Redeclaration', symbol => $name);
            }
            elsif $lex && $lex{$name} {
                $/.CURSOR.typed_sorry('X::Redeclaration::Outer', symbol => $name);
            }
            make declare_variable($/, $past, ~$sigil, ~$twigil, ~$, $, $);
        }
        else {
            make declare_variable($/, $past, ~$sigil, ~$twigil, ~$, $, $);
        }
    }

    sub declare_variable($/, $past, $sigil, $twigil, $desigilname, $trait_list, $shape?) {
        my $name  := $sigil ~ $twigil ~ $desigilname;
        my $BLOCK := $*W.cur_lexpad();

        if $*SCOPE eq 'has' {
            # Ensure current package can take attributes.
            unless nqp::can($*PACKAGE.HOW, 'add_attribute') {
                if $*PKGDECL {
                    $*W.throw($/, ['X', 'Attribute', 'Package'],
                        package-kind => $*PKGDECL,
                        :$name,
                    );
                } else {
                    $*W.throw($/, ['X', 'Attribute', 'NoPackage'], :$name);
                }
            }

            # Create container descriptor and decide on any default value.
            if $desigilname eq '' {
                $/.CURSOR.panic("Cannot declare an anonymous attribute");
            }
            my $attrname   := ~$sigil ~ '!' ~ $desigilname;
            my %cont_info  := container_type_info($/, $sigil, $*OFTYPE ?? [$*OFTYPE.ast] !! [], $shape);
            my $descriptor := $*W.create_container_descriptor(
              %cont_info, 1, $attrname, %cont_info);

            # Create meta-attribute and add it.
            my $metaattr := %*HOW{$*PKGDECL ~ '-attr'};
            my $attr := $*W.pkg_add_attribute($/, $*PACKAGE, $metaattr,
                hash(
                    name => $attrname,
                    has_accessor => $twigil eq '.'
                ),
                hash(
                    container_descriptor => $descriptor,
                    type => %cont_info,
                    package => $*W.find_symbol(['$?CLASS'])),
                %cont_info, $descriptor);

            # Document it
            # Perl6::Pod::document($/, $attr, $*DOC); #XXX var traits NYI

            # If no twigil, note $foo is an alias to $!foo.
            if $twigil eq '' {
                $BLOCK.symbol($name, :attr_alias($attrname));
            }

            # Apply any traits.
            for $trait_list {
                my $applier := $_.ast;
                if $applier { $applier($attr); }
            }

            # Nothing to emit here; hand back a Nil.
            $past := QAST::Var.new(:name('Nil'), :scope('lexical'));
            $past := $attr;
        }
        elsif $*SCOPE eq 'my' || $*SCOPE eq 'our' || $*SCOPE eq 'state' {
            # Some things can't be done to our vars.
            if $*SCOPE eq 'our' {
                if $*OFTYPE {
                    $/.CURSOR.panic("Cannot put a type constraint on an 'our'-scoped variable");
                }
                elsif $shape {
                    $/.CURSOR.panic("Cannot put a shape on an 'our'-scoped variable");
                }
                elsif $desigilname eq '' {
                    $/.CURSOR.panic("Cannot have an anonymous 'our'-scoped variable");
                }
            }

            # Create a container descriptor. Default to rw and set a
            # type if we have one; a trait may twiddle with that later.
            my %cont_info := container_type_info($/, $sigil, $*OFTYPE ?? [$*OFTYPE.ast] !! [], $shape);
            my $descriptor := $*W.create_container_descriptor(
              %cont_info, 1, $name, %cont_info);

            # Install the container.
            if $desigilname eq '' {
                $name := QAST::Node.unique('ANON_VAR_');
            }
            my $cont := $*W.install_lexical_container($BLOCK, $name, %cont_info, $descriptor,
                :scope($*SCOPE), :package($*PACKAGE));
            
            # Set scope and type on container, and if needed emit code to
            # reify a generic type.
            if $past.isa(QAST::Var) {
                $past.name($name);
                $past.scope('lexical');
                $past.returns(%cont_info);
                if %cont_info.HOW.archetypes.generic {
                    $past := QAST::Op.new(
                        :op('callmethod'), :name('instantiate_generic'),
                        QAST::Op.new( :op('p6var'), $past ),
                        QAST::Op.new( :op('curlexpad') ));
                }
                
                if $*SCOPE eq 'our' {
                    $BLOCK[0].push(QAST::Op.new(
                        :op('bind'),
                        $past,
                        $*W.symbol_lookup([$name], $/, :package_only(1), :lvalue(1))
                    ));
                }
            }
            
            # Twigil handling.
            if $twigil eq '.' {
                add_lexical_accessor($/, $past, $desigilname, $*W.cur_lexpad());
                $name := $sigil ~ $desigilname;
            }
            elsif $twigil eq '!' {
                $*W.throw($/, ['X', 'Syntax', 'Variable', 'Twigil'],
                    twigil => $twigil,
                    scope  => $*SCOPE,
                );
            }
            
            # Apply any traits.
            if $trait_list {
                my $Variable := $*W.find_symbol(['Variable']);
                my $varvar   := nqp::create($Variable);
                nqp::bindattr_s($varvar, $Variable, '$!name', $name);
                nqp::bindattr_s($varvar, $Variable, '$!scope', $*SCOPE);
                nqp::bindattr($varvar, $Variable, '$!var', $cont);
                nqp::bindattr($varvar, $Variable, '$!block', $*DECLARAND);
                nqp::bindattr($varvar, $Variable, '$!slash', $/);
                for $trait_list {
                    my $applier := $_.ast;
                    if $applier { $applier($varvar); }
                }
            }
        }
        else {
            $*W.throw($/, 'X::Comp::NYI',
                feature => "$*SCOPE scoped variables");
        }

        return $past;
    }
    
    sub add_lexical_accessor($/, $var_past, $meth_name, $install_in) {
        # Generate and install code block for accessor.
        my $a_past := $*W.push_lexpad($/);
        $a_past.name($meth_name);
        $a_past.push($var_past);
        $*W.pop_lexpad();
        $install_in[0].push($a_past);

        # Produce a code object and install it.
        my $invocant_type := $*W.find_symbol([$*W.is_lexical('$?CLASS') ?? '$?CLASS' !! 'Mu']);
        my %sig_info := hash(parameters => []);
        my $code := methodize_block($/, $*W.stub_code_object('Method'), 
            $a_past, %sig_info, $invocant_type);
        install_method($/, $meth_name, 'has', $code, $install_in);
    }

    method routine_declarator:sym($/) { make $.ast; }
    method routine_declarator:sym($/) { make $.ast; }
    method routine_declarator:sym($/) { make $.ast; }

    method routine_def($/) {
        my $block;

        if $ {
            $block := $.ast;
        }
        else {
            $block := $.ast;
            $block.blocktype('declaration');
            if is_clearly_returnless($block) {
                unless nqp::objprimspec($block[1].returns) {
                    $block[1] := QAST::Op.new(
                        :op('p6decontrv'),
                        QAST::WVal.new( :value($*DECLARAND) ),
                        $block[1]);
                }
                $block[1] := QAST::Op.new(
                    :op('p6typecheckrv'),
                    $block[1],
                    QAST::WVal.new( :value($*DECLARAND) ));
            }
            else {
                $block[1] := wrap_return_handler($block[1]);
            }
        }

        # Obtain parameters, create signature object and generate code to
        # call binder.
        if $block && $ {
            $*W.throw($/, ['X', 'Signature', 'Placeholder'],
                placeholder => $block[0],
            );
        }
        my %sig_info;
        if $ {
            %sig_info := $.ast;
        }
        else {
            %sig_info := $block ?? $block !!
                                                                [];
        }
        my @params := %sig_info;
        set_default_parameter_type(@params, 'Any');
        my $signature := create_signature_object($ ?? $ !! $/, %sig_info, $block);
        add_signature_binding_code($block, $signature, @params);

        # Needs a slot that can hold a (potentially unvivified) dispatcher;
        # if this is a multi then we'll need it to vivify to a MultiDispatcher.
        if $*MULTINESS eq 'multi' {
            $*W.install_lexical_symbol($block, '$*DISPATCHER', $*W.find_symbol(['MultiDispatcher']));
        }
        else {
            $block[0].push(QAST::Var.new( :name('$*DISPATCHER'), :scope('lexical'), :decl('var') ));
        }
        $block[0].push(QAST::Op.new(
            :op('takedispatcher'),
            QAST::SVal.new( :value('$*DISPATCHER') )
        ));
        
        # If it's a proto but not an onlystar, need some variables for the
        # {*} implementation to use.
        if $*MULTINESS eq 'proto' && !$ {
            $block[0].push(QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name('CURRENT_DISPATCH_CAPTURE'), :scope('lexical'), :decl('var') ),
                QAST::Op.new( :op('savecapture') )
            ));
            $block[0].push(QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name('&*CURRENT_DISPATCHER'), :scope('lexical'), :decl('var') ),
                QAST::Op.new( :op('getcodeobj'), QAST::Op.new( :op('curcode') ) )
            ));
        }

        # Set name.
        if $ {
            $block.name(~$.ast);
        }
        
        # Finish code object, associating it with the routine body.
        my $code := $*DECLARAND;
        $*W.attach_signature($code, $signature);
        $*W.finish_code_object($code, $block, $*MULTINESS eq 'proto', :yada(is_yada($/)));

        # attach return type
        if $*OFTYPE {
            my $sig := $code.signature;
            if $sig.has_returns {
                my $prev_returns := $sig.returns;
                $*W.throw($*OFTYPE, 'X::Redeclaration',
                    what    => 'return type for',
                    symbol  => $code,
                    postfix => " (previous return type was " 
                                ~ $prev_returns.HOW.name($prev_returns)
                                ~ ')',
                );
            }
            $sig.set_returns($*OFTYPE.ast);
        }

        # Document it
        Perl6::Pod::document($/, $code, $*DOC);

        # Install PAST block so that it gets capture_lex'd correctly and also
        # install it in the lexpad.
        my $outer := $*W.cur_lexpad();
        $outer[0].push(QAST::Stmt.new($block));

        # Install &?ROUTINE.
        $*W.install_lexical_symbol($block, '&?ROUTINE', $code);

        my $past;
        if $ {
            # If it's a multi, need to associate it with the surrounding
            # proto.
            # XXX Also need to auto-multi things with a proto in scope.
            my $name := '&' ~ ~$.ast;
            if $*MULTINESS eq 'multi' {
                # Do we have a proto in the current scope?
                my $proto;
                if $outer.symbol($name) {
                    $proto := $outer.symbol($name);
                }
                else {
                    unless $*SCOPE eq '' || $*SCOPE eq 'my' {
                        $*W.throw($/, 'X::Declaration::Scope::Multi',
                            scope       => $*SCOPE,
                            declaration => 'multi',
                        );
                    }
                    # None; search outer scopes.
                    my $new_proto;
                    try {
                        $proto := $*W.find_symbol([$name]);
                    }
                    if $proto && $proto.is_dispatcher {
                        # Found in outer scope. Need to derive.
                        $new_proto := $*W.derive_dispatcher($proto);
                    }
                    else {
                        $new_proto := self.autogenerate_proto($/, $block.name, $outer[0]);
                    }

                    # Install in current scope.
                    $*W.install_lexical_symbol($outer, $name, $new_proto, :clone(1));
                    $proto := $new_proto;
                }

                # Ensure it's actually a dispatcher.
                unless nqp::can($proto, 'is_dispatcher') && $proto.is_dispatcher {
                    $*W.throw($/, ['X', 'Redeclaration'],
                        what    => 'routine',
                        symbol  => ~$.ast,
                    );
                }

                # Install the candidate.
                $*W.add_dispatchee_to_proto($proto, $code);
            }
            else {
                # Install.
                if $outer.symbol($name) {
                    $*W.throw($/, ['X', 'Redeclaration'],
                            symbol => ~$.ast,
                            what   => 'routine',
                    );
                }
                if $*SCOPE eq '' || $*SCOPE eq 'my' {
                    $*W.install_lexical_symbol($outer, $name, $code, :clone(1));
                }
                elsif $*SCOPE eq 'our' {
                    # Install in lexpad and in package, and set up code to
                    # re-bind it per invocation of its outer.
                    $*W.install_lexical_symbol($outer, $name, $code, :clone(1));
                    $*W.install_package_symbol($*PACKAGE, $name, $code);
                    $outer[0].push(QAST::Op.new(
                        :op('bindkey'),
                        QAST::Op.new( :op('who'), QAST::WVal.new( :value($*PACKAGE) ) ),
                        QAST::SVal.new( :value($name) ),
                        QAST::Var.new( :name($name), :scope('lexical') )
                    ));
                }
                elsif $*SCOPE eq 'anon' {
                    # don't do anything
                }
                else {
                    $*W.throw($/, 'X::Declaration::Scope',
                            scope       => $*SCOPE,
                            declaration => 'sub',
                    );
                }
            }
        }
        elsif $*MULTINESS {
            $*W.throw($/, 'X::Anon::Multi', multiness => $*MULTINESS);
        }

        # Apply traits.
        for $ -> $t {
            if $t.ast { $*W.ex-handle($t, { ($t.ast)($code) }) }
        }
        if $ {
            # Protect with try; won't work when declaring the initial
            # trait_mod proto in CORE.setting!
            try $*W.apply_trait($/, '&trait_mod:', $*DECLARAND, :onlystar(1));
        }

        # Handle any phasers.
        $*W.add_phasers_handling_code($code, $block);

        # Add inlining information if it's inlinable; also mark soft if the
        # appropriate pragma is in effect.
        if $ {
            if $*SOFT {
                $*W.find_symbol(['&infix:'])($code, $*W.find_symbol(['SoftRoutine']));
            }
            else {
                self.add_inlining_info_if_possible($/, $code, $block, @params);
            }
        }
        
        # If it's a proto, add it to the sort-at-CHECK-time queue.
        if $*MULTINESS eq 'proto' {
            $*W.add_proto_to_sort($code);
        }

        my $closure := block_closure(reference_to_code_object($code, $past));
        $closure := QAST::Op.new( :op('null') );
        make $closure;
    }
    
    method autogenerate_proto($/, $name, $install_in) {
        my $p_past := $*W.push_lexpad($/);
        $p_past.name(~$name);
        $p_past.push(QAST::Op.new(
            :op('invokewithcapture'),
            QAST::Op.new(
                :op('ifnull'),
                QAST::Op.new(
                    :op('multicachefind'),
                    QAST::Var.new(
                        :name('$!dispatch_cache'), :scope('attribute'),
                        QAST::Op.new( :op('getcodeobj'), QAST::Op.new( :op('curcode') ) ),
                        QAST::WVal.new( :value($*W.find_symbol(['Routine'])) ),
                    ),
                    QAST::Op.new( :op('usecapture') )
                ),
                QAST::Op.new(
                    :op('callmethod'), :name('find_best_dispatchee'),
                    QAST::Op.new( :op('getcodeobj'), QAST::Op.new( :op('curcode') ) ),
                    QAST::Op.new( :op('savecapture') )
                ),
            ),
            QAST::Op.new( :op('usecapture') )
        ));
        $*W.pop_lexpad();
        $install_in.push(QAST::Stmt.new($p_past));
        my @p_params := [hash(is_capture => 1, nominal_type => $*W.find_symbol(['Mu']) )];
        my $p_sig := $*W.create_signature(nqp::hash('parameters', [$*W.create_parameter(@p_params[0])]));
        add_signature_binding_code($p_past, $p_sig, @p_params);
        my $code := $*W.create_code_object($p_past, 'Sub', $p_sig, 1);
        $*W.apply_trait($/, '&trait_mod:', $code, :onlystar(1));
        $*W.add_proto_to_sort($code);
        $code
    }
    
    method add_inlining_info_if_possible($/, $code, $past, @params) {
        # Make sure the block has the common structure we expect
        # (decls then statements).
        return 0 unless +@($past) == 2;

        # Ensure all parameters are simple and build placeholders for
        # them.
        my %arg_placeholders;
        my int $arg_num := 0;
        for @params {
            return 0 if $_ || $_ || $_ ||
                $_ || $_ || $_ ||
                $_ || $_ || $_ ||
                $_ || $_;
            %arg_placeholders{$_} :=
                QAST::InlinePlaceholder.new( :position($arg_num) );
            $arg_num := $arg_num + 1;
        }

        # Ensure nothing extra is declared.
        for @($past[0]) {
            if nqp::istype($_, QAST::Var) && $_.scope eq 'lexical' {
                my $name := $_.name;
                return 0 if $name ne '$*DISPATCHER' && $name ne '$_' &&
                    $name ne '$/' && $name ne '$!' && $name ne '&?ROUTINE' &&
                    !nqp::existskey(%arg_placeholders, $name);
            }
        }

        # If all is well, we try to build the QAST for inlining. This dies
        # if we fail.
        my $PseudoStash;
        try $PseudoStash := $*W.find_symbol(['PseudoStash']);
        sub clear_node($qast) {
            $qast.node(nqp::null());
            $qast
        }
        sub clone_qast($qast) {
            my $cloned := nqp::clone($qast);
            nqp::bindattr($cloned, QAST::Node, '@!array',
                nqp::clone(nqp::getattr($cloned, QAST::Node, '@!array')));
            $cloned
        }
        sub node_walker($node) {
            # Simple values are always fine; just return them as they are, modulo
            # removing any :node(...).
            if nqp::istype($node, QAST::IVal) || nqp::istype($node, QAST::SVal)
            || nqp::istype($node, QAST::NVal) {
                return $node.node ?? clear_node(clone_qast($node)) !! $node;
            }
            
            # WVal is OK, though special case for PseudoStash usage (which means
            # we are doing funny lookup stuff).
            elsif nqp::istype($node, QAST::WVal) {
                if $node.value =:= $PseudoStash {
                    nqp::die("Routines using pseudo-stashes are not inlinable");
                }
                else {
                    return $node.node ?? clear_node(clone_qast($node)) !! $node;
                }
            }
            
            # Operations need checking for their inlinability. If they are OK in
            # themselves, it comes down to the children.
            elsif nqp::istype($node, QAST::Op) {
                if nqp::getcomp('QAST').operations.is_inlinable('perl6', $node.op) {
                    my $replacement := clone_qast($node);
                    my int $i := 0;
                    my int $n := +@($node);
                    while $i < $n {
                        $replacement[$i] := node_walker($node[$i]);
                        $i := $i + 1;
                    }
                    return clear_node($replacement);
                }
                else {
                    nqp::die("Non-inlinable op '" ~ $node.op ~ "' encountered");
                }
            }
            
            # Variables are fine *if* they are arguments.
            elsif nqp::istype($node, QAST::Var) && ($node.scope eq 'lexical' || $node.scope eq '') {
                if nqp::existskey(%arg_placeholders, $node.name) {
                    my $replacement := %arg_placeholders{$node.name};
                    if $node.named || $node.flat {
                        $replacement := clone_qast($replacement);
                        if $node.named { $replacement.named($node.named) }
                        if $node.flat { $replacement.flat($node.flat) }
                    }
                    return $replacement;
                }
                else {
                    nqp::die("Cannot inline with non-argument variables");
                }
            }
            
            # Statements need to be cloned and then each of the nodes below them
            # visited.
            elsif nqp::istype($node, QAST::Stmt) || nqp::istype($node, QAST::Stmts) {
                my $replacement := clone_qast($node);
                my int $i := 0;
                my int $n := +@($node);
                while $i < $n {
                    $replacement[$i] := node_walker($node[$i]);
                    $i := $i + 1;
                }
                return clear_node($replacement);
            }
            
            # Want nodes need copying and every other child visiting.
            elsif nqp::istype($node, QAST::Want) {
                my $replacement := clone_qast($node);
                my int $i := 0;
                my int $n := +@($node);
                while $i < $n {
                    $replacement[$i] := node_walker($node[$i]);
                    $i := $i + 2;
                }
                return clear_node($replacement);
            }
            
            # Otherwise, we don't know what to do with it.
            else {
                nqp::die("Unhandled node type; won't inline");
            }
        };
        my $inline_info;
        try $inline_info := node_walker($past[1]);
        return 0 unless nqp::istype($inline_info, QAST::Node);

        # Attach inlining information.
        $*W.apply_trait($/, '&trait_mod:', $code, inlinable => $inline_info)
    }

    method method_def($/) {
        my $past;
        if $ {
            $past := $.ast;
        }
        else {
            $past := $.ast;
            $past.blocktype('declaration');
            if is_clearly_returnless($past) {
                $past[1] := QAST::Op.new(
                    :op('p6typecheckrv'),
                    QAST::Op.new( :op('p6decontrv'), QAST::WVal.new( :value($*DECLARAND) ), $past[1] ),
                    QAST::WVal.new( :value($*DECLARAND) ));
            }
            else {
                $past[1] := wrap_return_handler($past[1]);
            }
        }
        
        my $name;
        if $ {
            my $longname := $*W.dissect_longname($);
            $name := $longname.name(:dba('method name'),
                            :decl, :with_adverbs);
        }
        elsif $ {
            if $ eq '@'    { $name := 'postcircumfix:<[ ]>' }
            elsif $ eq '%' { $name := 'postcircumfix:<{ }>' }
            elsif $ eq '&' { $name := 'postcircumfix:<( )>' }
            else {
                $/.CURSOR.panic("Cannot use " ~ $ ~ " sigil as a method name");
            }
        }
        $past.name($name ?? $name !! '');

        # Do the various tasks to trun the block into a method code object.
        my %sig_info := $ ?? $.ast !! hash(parameters => []);
        my $inv_type  := $*W.find_symbol([
            $ && $*W.is_lexical('$?CLASS') ?? '$?CLASS' !! 'Mu']);
        my $code := methodize_block($/, $*DECLARAND, $past, %sig_info, $inv_type, :yada(is_yada($/)));

        # If it's a proto but not an onlystar, need some variables for the
        # {*} implementation to use.
        if $*MULTINESS eq 'proto' && !$ {
            # Also stash the current lexical dispatcher and capture, for the {*}
            # to resolve.
            $past[0].push(QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name('CURRENT_DISPATCH_CAPTURE'), :scope('lexical'), :decl('var') ),
                QAST::Op.new( :op('savecapture') )
            ));
            $past[0].push(QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name('&*CURRENT_DISPATCHER'), :scope('lexical'), :decl('var') ),
                QAST::Op.new( :op('getcodeobj'), QAST::Op.new( :op('curcode') ) )
            ));
        }
        
        # Document it
        Perl6::Pod::document($/, $code, $*DOC);

        # Install &?ROUTINE.
        $*W.install_lexical_symbol($past, '&?ROUTINE', $code);

        # Install PAST block so that it gets capture_lex'd correctly.
        my $outer := $*W.cur_lexpad();
        $outer[0].push($past);

        # Apply traits.
        for $ {
            if $_.ast { ($_.ast)($code) }
        }
        if $ {
            $*W.apply_trait($/, '&trait_mod:', $*DECLARAND, :onlystar(1));
        }
        $*W.add_phasers_handling_code($code, $past);

        # Install method.
        if $name {
            install_method($/, $name, $*SCOPE, $code, $outer,
                :private($ && ~$ eq '!'));
        }
        elsif $*MULTINESS {
            $*W.throw($/, 'X::Anon::Multi',
                multiness       => $*MULTINESS,
                routine-type    => 'method',
            );
        }
        
        # If it's a proto, add it to the sort-at-CHECK-time queue.
        if $*MULTINESS eq 'proto' {
            $*W.add_proto_to_sort($code);
        }

        my $closure := block_closure(reference_to_code_object($code, $past));
        $closure := QAST::Op.new( :op('null') );
        make $closure;
    }

    method macro_def($/) {
        my $block;

        $block := $.ast;
        $block.blocktype('declaration');
        if is_clearly_returnless($block) {
            $block[1] := QAST::Op.new(
                :op('p6decontrv'),
                QAST::WVal.new( :value($*DECLARAND) ),
                $block[1]);
        }
        else {
            $block[1] := wrap_return_handler($block[1]);
        }

        # Obtain parameters, create signature object and generate code to
        # call binder.
        if $block && $ {
            $*W.throw($/, 'X::Signature::Placeholder',
                placeholder => $block[0],
            );
        }
        my %sig_info;
        if $ {
            %sig_info := $.ast;
        }
        else {
            %sig_info := $block ?? $block !!
                                                                [];
        }
        my @params := %sig_info;
        set_default_parameter_type(@params, 'Any');
        my $signature := create_signature_object($ ?? $ !! $/, %sig_info, $block);
        add_signature_binding_code($block, $signature, @params);

        # Finish code object, associating it with the routine body.
        if $ {
            $block.name(~$.ast);
        }
        my $code := $*DECLARAND;
        $*W.attach_signature($code, $signature);
        $*W.finish_code_object($code, $block, $*MULTINESS eq 'proto');

        # Document it
        Perl6::Pod::document($/, $code, $*DOC);

        # Install PAST block so that it gets capture_lex'd correctly and also
        # install it in the lexpad.
        my $outer := $*W.cur_lexpad();
        $outer[0].push(QAST::Stmt.new($block));

        # Install &?ROUTINE.
        $*W.install_lexical_symbol($block, '&?ROUTINE', $code);

        my $past;
        if $ {
            my $name := '&' ~ ~$.ast;
            # Install.
            if $outer.symbol($name) {
                $/.CURSOR.panic("Illegal redeclaration of macro '" ~
                    ~$.ast ~ "'");
            }
            if $*SCOPE eq '' || $*SCOPE eq 'my' {
                $*W.install_lexical_symbol($outer, $name, $code);
            }
            elsif $*SCOPE eq 'our' {
                # Install in lexpad and in package, and set up code to
                # re-bind it per invocation of its outer.
                $*W.install_lexical_symbol($outer, $name, $code);
                $*W.install_package_symbol($*PACKAGE, $name, $code);
                $outer[0].push(QAST::Op.new(
                    :op('bind'),
                    $*W.symbol_lookup([$name], $/, :package_only(1)),
                    QAST::Var.new( :name($name), :scope('lexical') )
                ));
            }
            else {
                $/.CURSOR.panic("Cannot use '$*SCOPE' scope with a macro");
            }
        }
        elsif $*MULTINESS {
            $/.CURSOR.panic('Cannot put ' ~ $*MULTINESS ~ ' on anonymous macro');
        }

        # Apply traits.
        for $ {
            if $_.ast { ($_.ast)($code) }
        }
        $*W.add_phasers_handling_code($code, $past);

        my $closure := block_closure(reference_to_code_object($code, $past));
        $closure := QAST::Op.new( :op('null') );
        make $closure;
    }

    sub methodize_block($/, $code, $past, %sig_info, $invocant_type, :$yada) {
        # Get signature and ensure it has an invocant and *%_.
        my @params := %sig_info;
        if $past {
            $/.CURSOR.panic('Placeholder variables cannot be used in a method');
        }
        unless @params[0] {
            @params.unshift(hash(
                nominal_type => $invocant_type,
                is_invocant => 1,
                is_multi_invocant => 1
            ));
        }
        unless @params[+@params - 1] {
            unless nqp::can($*PACKAGE.HOW, 'hidden') && $*PACKAGE.HOW.hidden($*PACKAGE) {
                @params.push(hash(
                    variable_name => '%_',
                    nominal_type => $*W.find_symbol(['Mu']),
                    named_slurpy => 1,
                    is_multi_invocant => 1
                ));
                $past[0].unshift(QAST::Var.new( :name('%_'), :scope('lexical'), :decl('var') ));
                $past.symbol('%_', :scope('lexical'));
            }
        }
        set_default_parameter_type(@params, 'Any');
        my $signature := create_signature_object($/, %sig_info, $past);
        add_signature_binding_code($past, $signature, @params);

        # Place to store invocant.
        $past[0].unshift(QAST::Var.new( :name('self'), :scope('lexical'), :decl('var') ));
        $past.symbol('self', :scope('lexical'));

        # Needs a slot to hold a multi or method dispatcher.
        $*W.install_lexical_symbol($past, '$*DISPATCHER',
            $*W.find_symbol([$*MULTINESS eq 'multi' ?? 'MultiDispatcher' !! 'MethodDispatcher']));
        $past[0].push(QAST::Op.new(
            :op('takedispatcher'),
            QAST::SVal.new( :value('$*DISPATCHER') )
        ));
        
        # Finish up code object.
        $*W.attach_signature($code, $signature);
        $*W.finish_code_object($code, $past, $*MULTINESS eq 'proto', :yada($yada));
        $*W.add_phasers_handling_code($code, $past);
        return $code;
    }

    # Installs a method into the various places it needs to go.
    sub install_method($/, $name, $scope, $code, $outer, :$private) {
        # Ensure that current package supports methods, and if so
        # add the method.
        my $meta_meth;
        if $private {
            if $*MULTINESS { $/.CURSOR.panic("Private multi-methods are not supported"); }
            $meta_meth := 'add_private_method';
        }
        else {
            $meta_meth := $*MULTINESS eq 'multi' ?? 'add_multi_method' !! 'add_method';
        }
        if $scope eq '' || $scope eq 'has' {
            if nqp::can($*PACKAGE.HOW, $meta_meth) {
                $*W.pkg_add_method($/, $*PACKAGE, $meta_meth, $name, $code);
            }
            else {
                my $nocando := $*MULTINESS eq 'multi' ?? 'multi-method' !! 'method';
                nqp::printfh(nqp::getstderr(),
                    "Useless declaration of a has-scoped $nocando in " ~
                    ($*PKGDECL || "mainline") ~ " (did you mean 'my $*METHODTYPE $name'?)\n");
            }
        }

        # May also need it in lexpad and/or package.
        if $*SCOPE eq 'my' {
            $*W.install_lexical_symbol($outer, '&' ~ $name, $code, :clone(1));
        }
        elsif $*SCOPE eq 'our' {
            $*W.install_lexical_symbol($outer, '&' ~ $name, $code, :clone(1));
            $*W.install_package_symbol($*PACKAGE, '&' ~ $name, $code);
        }
    }

    sub is_clearly_returnless($block) {
        sub returnless_past($past) {
            return 0 unless
                # It's a simple operation.
                nqp::istype($past, QAST::Op)
                    && nqp::getcomp('QAST').operations.is_inlinable('perl6', $past.op) ||
                # Just a variable lookup.
                nqp::istype($past, QAST::Var) ||
                # Just a QAST::Want
                nqp::istype($past, QAST::Want) ||
                # Just a primitive or world value.
                nqp::istype($past, QAST::WVal) ||
                nqp::istype($past, QAST::IVal) ||
                nqp::istype($past, QAST::NVal) ||
                nqp::istype($past, QAST::SVal);
            for @($past) {
                if nqp::istype($_, QAST::Node) {
                    if !returnless_past($_) {
                        return 0;
                    }
                }
            }
            1;
        }
        
        # Only analyse things with a single simple statement.
        if +$block[1].list == 1 && nqp::istype($block[1][0], QAST::Stmt) && +$block[1][0].list == 1 {
            # Ensure there's no nested blocks.
            for @($block[0]) {
                if nqp::istype($_, QAST::Block) { return 0; }
                if nqp::istype($_, QAST::Stmts) {
                    for @($_) {
                        if nqp::istype($_, QAST::Block) { return 0; }
                    }
                }
            }

            # Ensure that the PAST is whitelisted things.
            returnless_past($block[1][0][0])
        }
        else {
            0
        }
    }
    
    sub is_yada($/) {
        if $ && +$ == 1 {
            my $btxt := ~$[0];
            if $btxt ~~ /^ \s* ['...'|'???'|'!!!'] \s* $/ {
                return 1;
            }
        }
        0
    }

    method onlystar($/) {
        my $BLOCK := $*CURPAD;
        $BLOCK.push(QAST::Op.new(
            :op('invokewithcapture'),
            QAST::Op.new(
                :op('ifnull'),
                QAST::Op.new(
                    :op('multicachefind'),
                    QAST::Var.new(
                        :name('$!dispatch_cache'), :scope('attribute'),
                        QAST::Op.new( :op('getcodeobj'), QAST::Op.new( :op('curcode') ) ),
                        QAST::WVal.new( :value($*W.find_symbol(['Routine'])) ),
                    ),
                    QAST::Op.new( :op('usecapture') )
                ),
                QAST::Op.new(
                    :op('callmethod'), :name('find_best_dispatchee'),
                    QAST::Op.new( :op('getcodeobj'), QAST::Op.new( :op('curcode') ) ),
                    QAST::Op.new( :op('savecapture') )
                )
            ),
            QAST::Op.new( :op('usecapture') )
        ));
        $BLOCK.node($/);
        make $BLOCK;
    }

    method regex_declarator:sym($/, $key?) {
        make $.ast;
    }

    method regex_declarator:sym($/, $key?) {
        make $.ast;
    }

    method regex_declarator:sym($/, $key?) {
        make $.ast;
    }

    method regex_def($/) {
        my $coderef;
        my $name := ~%*RX;

        my %sig_info := $ ?? $[0].ast !! hash(parameters => []);
        if $*MULTINESS eq 'proto' {
            unless $ {
                $/.CURSOR.panic("Proto regex body must be \{*\} (or <*> or <...>, which are deprecated)");
            }
            my $proto_body := QAST::Op.new(
                :op('callmethod'), :name('!protoregex'),
                QAST::Var.new( :name('self'), :scope('local') ),
                QAST::SVal.new( :value($name) ));
            $coderef := regex_coderef($/, $*DECLARAND, $proto_body, $*SCOPE, $name, %sig_info, $*CURPAD, $, :proto(1));
        } else {
            $coderef := regex_coderef($/, $*DECLARAND, $.ast, $*SCOPE, $name, %sig_info, $*CURPAD, $) if $.ast;
        }

        # Install &?ROUTINE.
        $*W.install_lexical_symbol($*CURPAD, '&?ROUTINE', $*DECLARAND);

        # Return closure if not in sink context.
        my $closure := block_closure($coderef);
        $closure := QAST::Op.new( :op('null') );
        make $closure;
    }

    sub regex_coderef($/, $code, $qast, $scope, $name, %sig_info, $block, $traits?, :$proto, :$use_outer_match) {
        # create a code reference from a regex qast tree
        my $past;
        if $proto {
            $block[1] := $qast;
            $past := $block;
        }
        else {
            $block[0].push(QAST::Var.new(:name<$¢>, :scope, :decl('var')));
            $block.symbol('$¢', :scope);
            unless $use_outer_match {
                $*W.install_lexical_magical($block, '$/');
            }
            $past := %*RX
                ?? %*LANG.qbuildsub($qast, $block, code_obj => $code)
                !! %*LANG.qbuildsub($qast, $block, code_obj => $code);
        }
        $past.name($name);
        $past.blocktype("declaration");
        
        # Install a $?REGEX (mostly for the benefit of <~~>).
        $block[0].push(QAST::Op.new(
            :op('bind'),
            QAST::Var.new(:name<$?REGEX>, :scope, :decl('var')),
            QAST::Op.new(
                :op('getcodeobj'),
                QAST::Op.new( :op('curcode') )
            )));
        $block.symbol('$?REGEX', :scope);

        # Do the various tasks to turn the block into a method code object.
        my $inv_type  := $*W.find_symbol([ # XXX Maybe Cursor below, not Mu...
            $name && $*W.is_lexical('$?CLASS') ?? '$?CLASS' !! 'Mu']);
        methodize_block($/, $code, $past, %sig_info, $inv_type);

        # Need to put self into a register for the regex engine.
        $past[0].push(QAST::Op.new(
            :op('bind'),
            QAST::Var.new( :name('self'), :scope('local'), :decl('var') ),
            QAST::Var.new( :name('self'), :scope('lexical') )));

        # Install PAST block so that it gets capture_lex'd correctly.
        my $outer := $*W.cur_lexpad();
        $outer[0].push($past);
        
        # Apply traits.
        if $traits {
            for $traits {
                if $_.ast { ($_.ast)($code) }
            }
        }
        
        # Install in needed scopes.
        install_method($/, $name, $scope, $code, $outer) if $name ne '';

        # Return a reference to the code object
        reference_to_code_object($code, $past);
    }

    method type_declarator:sym($/) {
        # If it's an anonymous enum, just call anonymous enum former
        # and we're done.
        unless $ || $ {
            make QAST::Op.new( :op('call'), :name('&ANON_ENUM'), $.ast );
            return 1;
        }

        # Get, or find, enumeration base type and create type object with
        # correct base type.
        my $longname  := $ ?? $*W.dissect_longname($) !! 0;
        my $name      := $ ?? $longname.name() !! $;

        my $type_obj;
        my sub make_type_obj($base_type) {
            $type_obj := $*W.pkg_create_mo($/, %*HOW, :$name, :$base_type);
            # Add roles (which will provide the enum-related methods).
            $*W.apply_trait($/, '&trait_mod:', $type_obj, $*W.find_symbol(['Enumeration']));
            if istype($type_obj, $*W.find_symbol(['Numeric'])) {
                $*W.apply_trait($/, '&trait_mod:', $type_obj, $*W.find_symbol(['NumericEnumeration']));
            }
            if istype($type_obj, $*W.find_symbol(['Stringy'])) {
                $*W.apply_trait($/, '&trait_mod:', $type_obj, $*W.find_symbol(['StringyEnumeration']));
            }
            # Apply traits, compose and install package.
            for $ {
                ($_.ast)($type_obj) if $_.ast;
            }
            $*W.pkg_compose($type_obj);
        }
        my $base_type;
        my int $has_base_type := 0;
        if $*OFTYPE {
            $base_type     := $*OFTYPE.ast;
            $has_base_type := 1;
            make_type_obj($base_type);
        }

        if $ {
            $*W.throw($/, 'X::Comp::NYI',
                feature => "Variable case of enums",
            );
        }

        # Get list of either values or pairs; fail if we can't.
        my $Pair := $*W.find_symbol(['Pair']);
        my @values;
        my $term_ast := $.ast;
        if $term_ast.isa(QAST::Stmts) && +@($term_ast) == 1 {
            $term_ast := $term_ast[0];
        }
        if $term_ast.isa(QAST::Op) && $term_ast.name eq '&infix:<,>' {
            for @($term_ast) {
                if istype($_.returns(), $Pair) && $_[1].has_compile_time_value {
                    @values.push($_);
                }
                elsif $_.has_compile_time_value {
                    @values.push($_);
                }
                else {
                    @values.push($*W.compile_time_evaluate($, $_));
                }
            }
        }
        elsif $term_ast.has_compile_time_value {
            @values.push($term_ast);
        }
        elsif istype($term_ast.returns, $Pair) && $term_ast[1].has_compile_time_value {
            @values.push($term_ast);
        }
        else {
            @values.push($*W.compile_time_evaluate($, $.ast));
        }

        # Now we have them, we can go about computing the value
        # for each of the keys, unless they have them supplied.
        # XXX Should not assume integers, and should use lexically
        # scoped &postfix:<++> or so.
        my $cur_value := nqp::box_i(-1, $*W.find_symbol(['Int']));
        for @values {
            # If it's a pair, take that as the value; also find
            # key.
            my $cur_key;
            if istype($_.returns(), $Pair) {
                $cur_key := $_[1].compile_time_value;
                $cur_value := $*W.compile_time_evaluate($, $_[2]);
                if $has_base_type {
                    unless istype($cur_value, $base_type) {
                        $/.CURSOR.panic("Type error in enum. Got '"
                                ~ $cur_value.HOW.name($cur_value)
                                ~ "' Expected: '"
                                ~ $base_type.HOW.name($base_type)
                                ~ "'"
                        );
                    }
                }
                else {
                    $base_type     :=  $cur_value.WHAT;
                    $has_base_type := 1;
                    make_type_obj($base_type);
                }
            }
            else {
                unless $has_base_type {
                    $base_type := $*W.find_symbol(['Int']);
                    make_type_obj($base_type);
                    $has_base_type := 1;
                }

                $cur_key := $_.compile_time_value;
                $cur_value := $cur_value.succ();
            }

            # Create and install value.
            my $val_obj := $*W.create_enum_value($type_obj, $cur_key, $cur_value);
            $*W.install_package_symbol($type_obj, nqp::unbox_s($cur_key), $val_obj);
            if $*SCOPE ne 'anon' {
                $*W.install_lexical_symbol($*W.cur_lexpad(), nqp::unbox_s($cur_key), $val_obj);
            }
            if $*SCOPE eq '' || $*SCOPE eq 'our' {
                $*W.install_package_symbol($*PACKAGE, nqp::unbox_s($cur_key), $val_obj);
            }
        }
        # create a type object even for empty enums
        make_type_obj($*W.find_symbol(['Int'])) unless $has_base_type;

        $*W.install_package($/, $longname.type_name_parts('enum name', :decl(1)),
            ($*SCOPE || 'our'), 'enum', $*PACKAGE, $*W.cur_lexpad(), $type_obj);

        # We evaluate to the enum type object.
        make QAST::WVal.new( :value($type_obj) );
    }

    method type_declarator:sym($/) {
        # We refine Any by default; "of" may override.
        my $refinee := $*W.find_symbol(['Any']);

        # If we have a refinement, make sure it's thunked if needed. If none,
        # just always true.
        my $refinement := make_where_block($ ?? $.ast !!
            QAST::Op.new( :op('p6bool'), QAST::IVal.new( :value(1) ) ));

        # Create the meta-object.
        my $longname := $ ?? $*W.dissect_longname($) !! 0;
        my $subset := $ ??
            $*W.create_subset(%*HOW, $refinee, $refinement, :name($longname.name())) !!
            $*W.create_subset(%*HOW, $refinee, $refinement);

        # Apply traits.
        for $ {
            ($_.ast)($subset) if $_.ast;
        }

        # Install it as needed.
        if $ && $longname.type_name_parts('subset name', :decl(1)) {
            $*W.install_package($/, $longname.type_name_parts('subset name', :decl(1)),
                ($*SCOPE || 'our'), 'subset', $*PACKAGE, $*W.cur_lexpad(), $subset);
        }

        # We evaluate to the refinement type object.
        make QAST::WVal.new( :value($subset) );
    }

    method type_declarator:sym($/) {
        # Get constant value.
        my $con_block := $*W.pop_lexpad();
        my $value_ast := $.ast;
        my $value;
        if $value_ast.has_compile_time_value {
            $value := $value_ast.compile_time_value;
        }
        else {
            $con_block.push($value_ast);
            my $value_thunk := $*W.create_simple_code_object($con_block, 'Block');
            $value := $value_thunk();
            $*W.add_constant_folded_result($value);
        }

        # Provided it's named, install it.
        my $name;
        if $ {
            $name := $.ast;
        }
        elsif $ {
            # Don't handle twigil'd case yet.
            if $ {
                $*W.throw($/, 'X::Comp::NYI',
                    feature => "Twigil-Variable constants"
                );
            }
            $name := ~$;
        }
        if $name {
            $*W.install_package($/, [$name], ($*SCOPE || 'our'),
                'constant', $*PACKAGE, $*W.cur_lexpad(), $value);
        }
        $*W.ex-handle($/, {
            for $ -> $t {
                ($t.ast)($value, :SYMBOL($name));
            }
        });

        # Evaluate to the constant.
        make QAST::WVal.new( :value($value) );
    }
    
    method initializer:sym<=>($/) {
        make $.ast;
    }
    method initializer:sym<:=>($/) {
        make $.ast;
    }
    method initializer:sym<::=>($/) {
        make $.ast;
    }
    method initializer:sym<.=>($/) {
        make $.ast;
    }

    method capterm($/) {
        # Construct a Parcel, and then call .Capture to coerce it to a capture.
        my $past := $ ?? $.ast !!
                    $ ?? $.ast !!
                    QAST::Op.new( :op('call'), :name('&infix:<,>') );
        unless $past.isa(QAST::Op) && $past.name eq '&infix:<,>' {
            $past := QAST::Op.new( :op('call'), :name('&infix:<,>'), $past );
        }
        make QAST::Op.new( :op('callmethod'), :name('Capture'), $past);
    }

    method capture($/) {
        make $.ast;
    }

    method multisig($/) {
        make $.ast;
    }

    method fakesignature($/) {
        my $fake_pad := $*W.pop_lexpad();
        my %sig_info := $.ast;
        my @params := %sig_info;
        set_default_parameter_type(@params, 'Mu');
        my $sig := create_signature_object($/, %sig_info, $fake_pad, :no_attr_check(1));

        $*W.cur_lexpad()[0].push($fake_pad);
        $*W.create_code_object($fake_pad, 'Block', $sig);
        
        make QAST::WVal.new( :value($sig) );
    }

    method signature($/) {
        # Fix up parameters with flags according to the separators.
        # TODO: Handle $, which contains the return type declared
        # with the --> syntax.
        my %signature;
        my @parameter_infos;
        my int $param_idx := 0;
        my int $multi_invocant := 1;
        for $ {
            my %info := $_.ast;
            %info := $multi_invocant;
            my $sep := @*seps[$param_idx];
            if ~$sep eq ':' {
                if $param_idx != 0 {
                    $*W.throw($/, 'X::Syntax::Signature::InvocantMarker')
                }
                %info := 1;
            }
            elsif ~$sep eq ';;' {
                $multi_invocant := 0;
            }
            @parameter_infos.push(%info);
            $param_idx := $param_idx + 1;
        }
        %signature := @parameter_infos;
        if $ {
            %signature := $.ast;
        }

        # Mark current block as having a signature.
        $*W.mark_cur_lexpad_signatured();

        # Result is set of parameter descriptors.
        make %signature;
    }

    method parameter($/) {
        # If it's a defterm, need to do parameter setup here.
        if $ {
            my $name := $.ast;
            %*PARAM_INFO := $name;
            %*PARAM_INFO   := $name;
            %*PARAM_INFO         := '';
            self.declare_param($/, $name);
        }
        
        # Sanity checks.
        my $quant := $;
        if $ {
            my $name := %*PARAM_INFO // '';
            if $quant eq '*' {
                $/.CURSOR.typed_sorry('X::Parameter::Default', how => 'slurpy',
                            parameter => $name);
            }
            if $quant eq '!' {
                $/.CURSOR.typed_sorry('X::Parameter::Default', how => 'required',
                            parameter => $name);
            }
            my $val := $[0].ast;
            if $val.has_compile_time_value {
                %*PARAM_INFO := $val.compile_time_value;
                %*PARAM_INFO := 1;
            }
            else {
                %*PARAM_INFO :=
                    $*W.create_thunk($[0], $val);
            }
        }

        # Set up various flags.
        %*PARAM_INFO   := $quant eq '*' && %*PARAM_INFO eq '@';
        %*PARAM_INFO      := $quant eq '**' && %*PARAM_INFO eq '@';
        %*PARAM_INFO := $quant eq '*' && %*PARAM_INFO eq '%';
        %*PARAM_INFO     := $quant eq '?' || $ || ($ && $quant ne '!');
        %*PARAM_INFO    := $quant eq '\\';
        %*PARAM_INFO   := $quant eq '|';

        # Stash any traits.
        %*PARAM_INFO := $;

        if (%*PARAM_INFO || %*PARAM_INFO) && $ {
            $/.CURSOR.sorry("Slurpy positionals with type constraints are not supported.");
        }

        # Result is the parameter info hash.
        make %*PARAM_INFO;
    }

    method param_var($/) {
        if $ {
            if nqp::existskey(%*PARAM_INFO, 'sub_signature_params') {
                $/.CURSOR.panic('Cannot have more than one sub-signature for a parameter');
            }
            %*PARAM_INFO := $.ast;
            if nqp::substr(~$/, 0, 1) eq '[' {
                %*PARAM_INFO := '@';
                %*PARAM_INFO := $*W.find_symbol(['Positional']);
            }
        }
        else {
            # Set name, if there is one.
            if $ {
                %*PARAM_INFO := ~$/;
                %*PARAM_INFO := ~$;
            }
            %*PARAM_INFO := my $sigil := ~$;

            # Depending on sigil, use appropriate role.
            my int $need_role;
            my $role_type;
            if $sigil eq '@' {
                $role_type := $*W.find_symbol(['Positional']);
                $need_role := 1;
            }
            elsif $sigil eq '%' {
                $role_type := $*W.find_symbol(['Associative']);
                $need_role := 1;
            }
            elsif $sigil eq '&' {
                $role_type := $*W.find_symbol(['Callable']);
                $need_role := 1;
            }
            if $need_role {
                if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
                    %*PARAM_INFO := $*W.parameterize_type_with_args(
                        $role_type, [%*PARAM_INFO], nqp::hash());
                }
                else {
                    %*PARAM_INFO := $role_type;
                }
            }

            # Handle twigil.
            my $twigil := $ ?? ~$ !! '';
            %*PARAM_INFO := $twigil;
            if $twigil eq '' || $twigil eq '*' {
                # Need to add the name.
                if $ {
                    self.declare_param($/, ~$/);
                }
            }
            elsif $twigil eq '!' {
                %*PARAM_INFO    := 1;
                %*PARAM_INFO := $*W.find_symbol(['$?CLASS']);
            }
            elsif $twigil eq '.' {
                %*PARAM_INFO := 1;
                if $ {
                    %*PARAM_INFO := ~$;
                }
                else {
                    $/.CURSOR.panic("Cannot declare $. parameter in signature without an accessor name");
                }
            }
            else {
                if $twigil eq ':' {
                    $/.CURSOR.typed_sorry('X::Parameter::Placeholder',
                        parameter => ~$/,
                        right     => ':' ~ $ ~ ~$,
                    );
                }
                else {
                    $/.CURSOR.typed_sorry('X::Parameter::Twigil',
                        parameter => ~$/,
                        twigil    => $twigil,
                    );
                }
            }
        }
    }

    method declare_param($/, $name) {
        my $cur_pad := $*W.cur_lexpad();
        if $cur_pad.symbol($name) {
            $*W.throw($/, ['X', 'Redeclaration'], symbol => $name);
        }
        if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
            $cur_pad[0].push(QAST::Var.new( :$name, :scope('lexical'),
                :decl('var'), :returns(%*PARAM_INFO) ));
            %*PARAM_INFO := $*W.create_container_descriptor(
                %*PARAM_INFO, 0, %*PARAM_INFO);
            $cur_pad.symbol(%*PARAM_INFO, :descriptor(%*PARAM_INFO),
                :type(%*PARAM_INFO));
        } else {
            $cur_pad[0].push(QAST::Var.new( :name($name), :scope('lexical'), :decl('var') ));
        }
        $cur_pad.symbol($name, :scope('lexical'));
    }

    method named_param($/) {
        %*PARAM_INFO := %*PARAM_INFO || [];
        if $               { %*PARAM_INFO.push(~$); }
        elsif $ { %*PARAM_INFO.push(~$); }
        else                     { %*PARAM_INFO.push(''); }
    }

    method default_value($/) {
        make $.ast;
    }

    method type_constraint($/) {
        if $ {
            if nqp::substr(~$, 0, 2) eq '::' && nqp::substr(~$, 2, 1) ne '?' {
                # Set up signature so it will find the typename.
                my $desigilname := nqp::substr(~$, 2);
                unless %*PARAM_INFO {
                    %*PARAM_INFO := []
                }
                %*PARAM_INFO.push($desigilname);

                # Install type variable in the static lexpad. Of course,
                # we'll find the real thing at runtime, but in the static
                # view it's a type variable to be reified.
                $*W.install_lexical_symbol($*W.cur_lexpad(), $desigilname,
                    $.ast);
            }
            else {
                if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
                    $*W.throw($/, ['X', 'Parameter', 'MultipleTypeConstraints'],
                        parameter => (%*PARAM_INFO // ''),
                    );
                }
                my $type := $.ast;
                if nqp::isconcrete($type) {
                    # Actual a value that parses type-ish.
                    %*PARAM_INFO := $type.WHAT;
                    unless %*PARAM_INFO {
                        %*PARAM_INFO := [];
                    }
                    %*PARAM_INFO.push($type);
                }
                elsif $type.HOW.archetypes.nominal {
                    %*PARAM_INFO := $type;
                }
                elsif $type.HOW.archetypes.generic {
                    %*PARAM_INFO := $type;
                    %*PARAM_INFO := 1;
                }
                elsif $type.HOW.archetypes.nominalizable {
                    my $nom := $type.HOW.nominalize($type);
                    %*PARAM_INFO := $nom;
                    unless %*PARAM_INFO {
                        %*PARAM_INFO := [];
                    }
                    %*PARAM_INFO.push($type);
                }
                else {
                    $/.CURSOR.panic("Type " ~ ~$ ~
                        " cannot be used as a nominal type on a parameter");
                }
                for ($ ?? $ !! $) {
                    if $_ {
                        if $_.Str eq 'D' {
                            %*PARAM_INFO := 1;
                        }
                        elsif $_.Str eq 'U' {
                            %*PARAM_INFO := 1;
                        }
                    }
                }
            }
        }
        elsif $ {
            if nqp::existskey(%*PARAM_INFO, 'nominal_type') {
                $*W.throw($/, ['X', 'Parameter', 'MultipleTypeConstraints'],
                        parameter => (%*PARAM_INFO // ''),
                );
            }
            my $ast := $.ast;
            unless $ast.has_compile_time_value {
                $/.CURSOR.panic('Cannot use a value type constraints whose value is unknown at compile time');
            }
            my $val := $ast.compile_time_value;
            %*PARAM_INFO := $val.WHAT;
            unless %*PARAM_INFO {
                %*PARAM_INFO := [];
            }
            %*PARAM_INFO.push($val);
        }
        else {
            $/.CURSOR.panic('Cannot do non-typename cases of type_constraint yet');
        }
    }

    method post_constraint($/) {
        if $ {
            if nqp::existskey(%*PARAM_INFO, 'sub_signature_params') {
                $/.CURSOR.panic('Cannot have more than one sub-signature for a parameter');
            }
            %*PARAM_INFO := $.ast;
            if nqp::substr(~$/, 0, 1) eq '[' {
                %*PARAM_INFO := '@';
            }
        }
        else {
            unless %*PARAM_INFO {
                %*PARAM_INFO := [];
            }
            %*PARAM_INFO.push(make_where_block($.ast));
        }
    }

    # Sets the default parameter type for a signature.
    sub set_default_parameter_type(@parameter_infos, $type_name) {
        my $type := $*W.find_symbol([$type_name]);
        for @parameter_infos {
            unless nqp::existskey($_, 'nominal_type') {
                $_ := $type;
            }
            if nqp::existskey($_, 'sub_signature_params') {
                set_default_parameter_type($_, $type_name);
            }
        }
    }

    # Create Parameter objects, along with container descriptors
    # if needed. Parameters will be bound into the specified
    # lexpad.
    sub create_signature_object($/, %signature_info, $lexpad, :$no_attr_check) {
        my @parameters;
        my %seen_names;
        for %signature_info {
            # Check we don't have duplicated named parameter names.
            if $_ {
                for $_ {
                    if %seen_names{$_} {
                        $*W.throw($/, ['X', 'Signature', 'NameClash'],
                            name => $_
                        );
                    }
                    %seen_names{$_} := 1;
                }
            }
            
            # If it's !-twigil'd, ensure the attribute it mentions exists unless
            # we're in a context where we should not do that.
            if $_ && !$no_attr_check {
                get_attribute_meta_object($/, $_, QAST::Var.new);
            }
            
            # If we have a sub-signature, create that.
            if nqp::existskey($_, 'sub_signature_params') {
                $_ := create_signature_object($/, $_, $lexpad);
            }
            
            # Add variable as needed.
            if $_ {
                my %sym := $lexpad.symbol($_);
                if +%sym && !nqp::existskey(%sym, 'descriptor') {
                    $_ := $*W.create_container_descriptor(
                        $_, $_ ?? 1 !! 0, $_);
                    $lexpad.symbol($_, :descriptor($_));
                }
            }

            # Create parameter object and apply any traits.
            my $param_obj := $*W.create_parameter($_);
            if $_ {
                for $_ {
                    ($_.ast)($param_obj) if $_.ast;
                }
            }

            # Add it to the signature.
            @parameters.push($param_obj);
        }
        %signature_info := @parameters;
        $*W.create_signature(%signature_info)
    }

    method trait($/) {
        make $ ?? $.ast !! $.ast;
    }

    method trait_mod:sym($/) {
        # Handle is repr specially.
        if ~$ eq 'repr' {
            if $ {
                $*REPR := compile_time_value_str($[0].ast[0], "is repr(...) trait", $/);
            }
            else {
                $/.CURSOR.panic("is repr(...) trait needs a parameter");
            }
        }
        else
        {
            # If we have an argument, get its compile time value or
            # evaluate it to get that.
            my @trait_arg;
            if $ {
                my $arg := $[0].ast[0];
                @trait_arg[0] := $arg.has_compile_time_value ??
                    $arg.compile_time_value !!
                    $*W.create_thunk($/, $[0].ast)();
            }
        
            # If we have a type name then we need to dispatch with that type; otherwise
            # we need to dispatch with it as a named argument.
            my @name := $*W.dissect_longname($).components();
            if $*W.is_name(@name) {
                my $trait := $*W.find_symbol(@name);
                make -> $declarand {
                    $*W.apply_trait($/, '&trait_mod:', $declarand, $trait, |@trait_arg);
                };
            }
            else {
                my %arg;
                %arg{~$} := @trait_arg ?? @trait_arg[0] !!
                    $*W.find_symbol(['Bool', 'True']);
                make -> $declarand, *%additional {
                    $*W.apply_trait($/, '&trait_mod:', $declarand, |%arg, |%additional);
                };
            }
        }
    }

    method trait_mod:sym($/) {
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand, $.ast);
        };
    }

    method trait_mod:sym($/) {
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand, $.ast);
        };
    }

    method trait_mod:sym($/) {
        my %arg;
        %arg{~$} := ($*W.add_constant('Int', 'int', 1)).compile_time_value;
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand,
                ($.ast), |%arg);
        };
    }

    method trait_mod:sym($/) {
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand, $.ast);
        };
    }

    method trait_mod:sym($/) {
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand, $.ast);
        };
    }

    method trait_mod:sym($/) {
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand, $.ast);
        };
    }

    method trait_mod:sym($/) {
        # The term may be fairly complex. Thus we make it into a thunk
        # which the trait handler can use to get the term and work with
        # it.
        my $thunk := $*W.create_thunk($/, $.ast);
        make -> $declarand {
            $*W.apply_trait($/, '&trait_mod:', $declarand, $thunk);
        };
    }

    method postop($/) {
        if $ {
            make $.ast
                 || QAST::Op.new( :name('&postfix:<' ~ $.Str ~ '>'), :op )
        } else {
            make $.ast
                 || QAST::Op.new( :name('&postcircumfix:<' ~ $.Str ~ '>'), :op );
        }
    }

    method dotty:sym<.>($/) { make $.ast; }

    method dotty:sym<.*>($/) {
        my $past := $.ast;
        unless $past.isa(QAST::Op) && $past.op() eq 'callmethod' {
            $/.CURSOR.panic("Cannot use " ~ $.Str ~ " on a non-identifier method call");
        }
        $past.unshift($*W.add_string_constant($past.name))
            if $past.name ne '';
        $past.name('dispatch:<' ~ ~$ ~ '>');
        make $past;
    }

    method dottyop($/) {
        if $ {
            make $.ast;
        }
        elsif $ {
            make $.ast;
        }
        else {
            make $.ast;
        }
    }

    method privop($/) {
        # Compiling private method calls is somewhat interesting. If it's
        # in any way qualified, we need to ensure that the current package
        # is trusted by the target class. Otherwise we assume that the call
        # is to a private method in the current (non-virtual) package.
        # XXX Optimize the case where the method is declared up front - but
        # maybe this is for the optimizer, not for here.
        # XXX Attribute accesses? Again, maybe for the optimizer, since it
        # runs after CHECK time.
        my $past := $.ast;
        if $ {
            my @parts   := $*W.dissect_longname($).components();
            my $name    := @parts.pop;
            if @parts {
                my $methpkg := $*W.find_symbol(@parts);
                unless nqp::can($methpkg.HOW, 'is_trusted') && $methpkg.HOW.is_trusted($methpkg, $*PACKAGE) {
                    $*W.throw($/, ['X', 'Method', 'Private', 'Permission'],
                        :method(         $name),
                        :source-package( $methpkg.HOW.name($methpkg)),
                        :calling-package( $*PACKAGE.HOW.name($*PACKAGE)),
                    );
                }
                $past[1].returns($methpkg);
            }
            else {
                unless nqp::can($*PACKAGE.HOW, 'find_private_method') {
                    $*W.throw($/, ['X', 'Method', 'Private', 'Unqualified'],
                        :method($name),
                    );
                }
                $past.unshift(QAST::WVal.new( :value($*PACKAGE) ));
                $past[0].returns($*PACKAGE);
                $past.unshift($*W.add_string_constant($name));
            }
            $past.name('dispatch:');
        }
        elsif $ {
            my $name := $past.shift;
            $past.unshift(QAST::WVal.new( :value($*PACKAGE) ));
            $past.unshift($name);
            $past.name('dispatch:');
        }
        else {
            $/.CURSOR.panic("Cannot use this form of method call with a private method");
        }
        make $past;
    }

    method methodop($/) {
        my $past := $ ?? $.ast !! QAST::Op.new( :node($/) );
        $past.op('callmethod');
        if $ {
            # May just be .foo, but could also be .Foo::bar. Also handle the
            # macro-ish cases.
            my @parts := $*W.dissect_longname($).components();
            my $name := @parts.pop;
            if +@parts {
                $past.unshift($*W.symbol_lookup(@parts, $/));
                $past.unshift($*W.add_string_constant($name));
                $past.name('dispatch:<::>');
            }
            elsif $name eq 'WHAT' {
                whine_if_args($/, $past, $name);
                $past.op('what');
            }
            elsif $name eq 'HOW' {
                whine_if_args($/, $past, $name);
                $past.op('how');
            }
            elsif $name eq 'WHO' {
                whine_if_args($/, $past, $name);
                $past.op('who');
            }
            elsif $name eq 'VAR' {
                whine_if_args($/, $past, $name);
                $past.op('p6var');
            }
            elsif $name eq 'REPR' {
                whine_if_args($/, $past, $name);
                $past.op('p6reprname');
            }
            elsif $name eq 'DEFINITE' {
                whine_if_args($/, $past, $name);
                $past.op('p6definite');
            }
            else {
                $past.name( $name );
            }
        }
        elsif $ {
            $past.unshift(
                QAST::Op.new(
                    :op,
                    $.ast
                )
            );
        }
        elsif $ {
            $past.unshift($.ast);
            $past.name('dispatch:');
        }
        make $past;
    }
    
    sub whine_if_args($/, $past, $name) {
        if +@($past) > 0 {
           $*W.throw($/, ['X', 'Syntax', 'Argument', 'MOPMacro'], macro => $name);
        }
    }
    
    method term:sym<::?IDENT>($/) {
        make instantiated_type([~$/], $/);
    }

    method term:sym($/) {
        make QAST::Var.new( :name('self'), :scope('lexical'), :returns($*PACKAGE), :node($/) );
    }

    method term:sym($/) {
        make QAST::Op.new( :op('call'), :name('&term:'), :node($/) );
    }

    method term:sym($/) { make nqp::chr(7) }
    method backslash:sym($/) { make "\b" }
    method backslash:sym($/) { make $.ast }
    method backslash:sym($/) { make "\c[27]" }
    method backslash:sym($/) { make "\c[12]" }
    method backslash:sym($/) { make "\n" }
    method backslash:sym($/) { make self.ints_to_string( $ ?? $ !! $ ) }
    method backslash:sym($/) { make "\r" }
    method backslash:sym($/) { make "\t" }
    method backslash:sym($/) { make self.ints_to_string( $ ?? $ !! $ ) }
    method backslash:sym<0>($/) { make "\c[0]" }

    method escape:sym<{ }>($/) {
        make QAST::Op.new(
            :op('callmethod'), :name('Stringy'),
            QAST::Op.new(
                :op('call'),
                QAST::Op.new( :op('p6capturelex'), $.ast ),
                :node($/)));
    }
    
    method escape:sym<$>($/) { make $.ast; }
    method escape:sym<@>($/) { make $.ast; }
    method escape:sym<%>($/) { make $.ast; }
    method escape:sym<&>($/) { make $.ast; }

    method escape:sym<' '>($/) { make mark_ww_atom($.ast); }
    method escape:sym<" ">($/) { make mark_ww_atom($.ast); }
    method escape:sym($/) { make mark_ww_atom($.ast); }
    sub mark_ww_atom($ast) {
        $ast := 1;
        $ast;
    }
}

class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {

    method metachar:sym<:my>($/) {
        my $past := $.ast;
        make QAST::Regex.new( $past, :rxtype('qastnode'), :subtype('declarative') );
    }

    method metachar:sym<{ }>($/) {
        make QAST::Regex.new( $.ast,
                              :rxtype, :node($/) );
    }
    
    method metachar:sym($/) {
        my $qast := QAST::Regex.new( :rxtype, :node($/) );
        my $nib  := $.ast[0];
        my @nibs := +@($nib) ?? @($nib) !! [$nib];
        for @nibs {
            unless $_.has_compile_time_value {
                $/.CURSOR.panic("Quote words construct too complex to use in a regex");
            }
            $qast.push(%*RX
                ?? QAST::Regex.new( $_.compile_time_value, :rxtype, :subtype )
                !! QAST::Regex.new( $_.compile_time_value, :rxtype ));
        }
        make $qast;
    }
    
    method metachar:sym<'>($/) { self.rxquote($/) }
    method metachar:sym<">($/) { self.rxquote($/) }
    method rxquote($/) {
        my $quote := $.ast;
        if $quote.has_compile_time_value {
            my $qast := QAST::Regex.new( :rxtype, nqp::unbox_s($quote.compile_time_value) );
            $qast.subtype('ignorecase') if %*RX;
            make $qast;
        }
        else {
            make QAST::Regex.new( QAST::Node.new(
                                        QAST::SVal.new( :value('!LITERAL') ),
                                        $quote,
                                        QAST::IVal.new( :value(%*RX ?? 1 !! 0) ) ),
                                :rxtype, :subtype, :node($/));
        }
    }
    
    method metachar:sym($/) {
        make QAST::Regex.new( QAST::Node.new(
                                    QAST::SVal.new( :value('INTERPOLATE') ),
                                    $.ast,
                                    QAST::IVal.new( :value(%*RX ?? 1 !! 0) ),
                                    QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ) ),
                              :rxtype, :subtype, :node($/));
    }

    method assertion:sym<{ }>($/) {
        make QAST::Regex.new( 
                 QAST::Node.new(
                    QAST::SVal.new( :value('INTERPOLATE') ),
                    $.ast,
                    QAST::IVal.new( :value(%*RX ?? 1 !! 0) ),
                    QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
                    QAST::IVal.new( :value(1) ) ),
                 :rxtype, :subtype, :node($/));
    }

    method assertion:sym($/) {
        make QAST::Regex.new( $.ast,
                              :subtype, :negate( $ eq '!' ),
                              :rxtype, :node($/) );
    }

    method assertion:sym($/) {
        make QAST::Regex.new( QAST::Node.new(
                                    QAST::SVal.new( :value('INTERPOLATE') ),
                                    $.ast,
                                    QAST::IVal.new( :value(%*RX ?? 1 !! 0) ),
                                    QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
                                    QAST::IVal.new( :value(1) ) ),
                              :rxtype, :subtype, :node($/));
    }
    
    method assertion:sym($/) {
        my @parts := $*W.dissect_longname($).components();
        my $name  := @parts.pop();
        my $qast;
        if $ {
            if +@parts {
                $/.CURSOR.panic("Can only alias to a short name (without '::')");
            }
            $qast := $.ast;
            self.subrule_alias($qast, $name);
        }
        elsif !@parts && $name eq 'sym' {
            my str $fullrxname := %*RX;
            my int $loc := nqp::index($fullrxname, ':sym<');
            $loc := nqp::index($fullrxname, ':sym«')
                if $loc < 0;
            my str $rxname := nqp::substr($fullrxname, $loc + 5, nqp::chars($fullrxname) - $loc - 6);
            $qast := QAST::Regex.new(:name('sym'), :rxtype, :node($/),
                QAST::Regex.new(:rxtype, $rxname, :node($/)));
        }
        else {
            if +@parts {
                my $gref := QAST::WVal.new( :value($*W.find_symbol(@parts)) );
                $qast := QAST::Regex.new(:rxtype, :subtype,
                                         :node($/), QAST::Node.new(
                                            QAST::SVal.new( :value('OTHERGRAMMAR') ), 
                                            $gref, QAST::SVal.new( :value($name) )),
                                         :name(~$) );
            } elsif $*W.regex_in_scope('&' ~ $name) {
                $qast := QAST::Regex.new(:rxtype, :subtype,
                                         :node($/), QAST::Node.new(
                                            QAST::SVal.new( :value('INTERPOLATE') ),
                                            QAST::Var.new( :name('&' ~ $name), :scope('lexical') ) ), 
                                         :name($name) );
            }
            else {
                $qast := QAST::Regex.new(:rxtype, :subtype,
                                         :node($/), QAST::Node.new(QAST::SVal.new( :value($name) )), 
                                         :name($name) );
            }
            if $ {
                for $.ast.list { $qast[0].push($_) }
            }
            elsif $ {
                my $nibbled := $name eq 'after'
                    ?? self.flip_ast($.ast)
                    !! $.ast;
                my $sub := %*LANG.qbuildsub($nibbled, :anon(1), :addself(1));
                $qast[0].push($sub);
            }
        }
        make $qast;
    }
    
    method assertion:sym<~~>($/) {
        if $ {
            $/.CURSOR.panic('Sorry, ~~ regex assertion with a capture is not yet implemented');
        }
        elsif $ {
            $/.CURSOR.panic('Sorry, ~~ regex assertion with a capture is not yet implemented');
        }
        else {
            make QAST::Regex.new( :rxtype, :subtype,
                QAST::Node.new(QAST::SVal.new( :value('RECURSE') )), :node($/) );
        }
    }
    
    method codeblock($/) {
        my $blockref := $.ast;
        my $past :=
            QAST::Stmts.new(
                QAST::Op.new(
                    :op('p6store'),
                    QAST::Var.new( :name('$/'), :scope ),
                    QAST::Op.new(
                        QAST::Var.new( :name('$¢'), :scope ),
                        :name('MATCH'),
                        :op('callmethod')
                    )
                ),
                QAST::Op.new(:op, $blockref)
            );
        make $past;
    }

    method arglist($/) {
        my $arglist := $.ast;
        make $arglist;
    }

    method create_regex_code_object($block) {
        $*W.create_code_object($block, 'Regex',
            $*W.create_signature(nqp::hash('parameters', [])))
    }

    method store_regex_nfa($code_obj, $block, $nfa) {
        $code_obj.SET_NFA($nfa.save);
    }
}

class Perl6::P5RegexActions is QRegex::P5Regex::Actions does STDActions {
    method create_regex_code_object($block) {
        $*W.create_code_object($block, 'Regex',
            $*W.create_signature(nqp::hash('parameters', [])))
    }

    method p5metachar:sym<(?{ })>($/) {
        make QAST::Regex.new( $.ast,
                              :rxtype, :node($/) );
    }

    method p5metachar:sym<(??{ })>($/) {
        make QAST::Regex.new( 
                 QAST::Node.new(
                    QAST::SVal.new( :value('INTERPOLATE') ),
                    $.ast,
                    QAST::IVal.new( :value(%*RX ?? 1 !! 0) ),
                    QAST::IVal.new( :value(1) ),
                    QAST::IVal.new( :value(1) ) ),
                 :rxtype, :subtype, :node($/));
    }

    method p5metachar:sym($/) {
        if $*INTERPOLATE {
            make QAST::Regex.new( QAST::Node.new(
                                        QAST::SVal.new( :value('INTERPOLATE') ),
                                        $.ast,
                                        QAST::IVal.new( :value(%*RX ?? 1 !! 0) ),
                                        QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
                                        QAST::IVal.new( :value(1) ) ),
                                  :rxtype, :subtype, :node($/));
        }
        else {
            make QAST::Regex.new( QAST::Node.new(
                                        QAST::SVal.new( :value('!LITERAL') ),
                                        $.ast,
                                        QAST::IVal.new( :value(%*RX ?? 1 !! 0) ) ),
                                :rxtype, :subtype, :node($/));
        }
    }

    method codeblock($/) {
        my $blockref := $.ast;
        my $past :=
            QAST::Stmts.new(
                QAST::Op.new(
                    :op('p6store'),
                    QAST::Var.new( :name('$/'), :scope ),
                    QAST::Op.new(
                        QAST::Var.new( :name('$¢'), :scope ),
                        :name('MATCH'),
                        :op('callmethod')
                    )
                ),
                QAST::Op.new(:op, $blockref)
            );
        make $past;
    }

    method store_regex_nfa($code_obj, $block, $nfa) {
        $code_obj.SET_NFA($nfa.save);
    }
}

# vim: ft=perl6
rakudo-2013.12/src/Perl6/Compiler.nqp0000664000175000017500000000632512224263172016663 0ustar  moritzmoritzuse NQPP6QRegex;
use QRegex;
use Perl6::Optimizer;

class Perl6::Compiler is HLL::Compiler {
    method command_eval(*@args, *%options) {
        if nqp::existskey(%options, 'doc') && !%options {
            %options := 'Text';
        }

        my $argiter := nqp::iterator(@args);
        nqp::shift($argiter) if $argiter && !nqp::defined(%options);
        nqp::bindhllsym('perl6', '$!ARGITER', $argiter);
        my $super := nqp::findmethod(HLL::Compiler, 'command_eval');
        my %*COMPILING;
        %*COMPILING<%?OPTIONS> := %options;
        $super(self, |@args, |%options);
    }

    method optimize($past, *%adverbs) {
        %adverbs eq 'off' ??
            $past !!
            Perl6::Optimizer.new.optimize($past, |%adverbs)
    }

    method syntaxcheck($past, *%adverbs) {
        if %adverbs {
            say("Syntax OK");
            nqp::exit(0);
        }
        $past;
    }
    
    method interactive_result($value) {
        CATCH { nqp::say($_) }
        if nqp::can($value, 'gist') {
            nqp::say(nqp::unbox_s($value.gist));
        } else {
            nqp::say(~$value);
        }
    }
    
    method interactive_exception($ex) {
        my $payload := nqp::getpayload($ex);
        if nqp::can($payload, 'gist') {
            nqp::say(nqp::unbox_s($payload.gist));
        }
        else {
            nqp::say(~$ex)
        }
        CATCH { nqp::say(~$ex) }
    }
    
    method usage($name?) {
        say(($name ?? $name !! "") ~ " [switches] [--] [programfile] [arguments]
 
        With no arguments, enters a REPL. With a \"[programfile]\" or the
        \"-e\" option, compiles the given program and by default also
        executes the compiled code.
 
          -c                   check syntax only (runs BEGIN and CHECK blocks)
          --doc                extract documentation and print it as text
          -e program           one line of program
          -h, --help           display this help text
          -n                   run program once for each line of input
          -p                   same as -n, but also print \$_ at the end of lines
          -I path              adds the path to the module search path
          -M module            loads the module prior to running the program
          --target=[stage]     specify compilation stage to emit
          --optimize=[level]   use the given level of optimization (0..3)
          -t, --trace=[flags]  enable trace flags, see 'parrot --help-debug'
          --encoding=[mode]    specify string encoding mode
          -o, --output=[name]  specify name of output file
          -v, --version        display version information
          --stagestats         display time spent in the compilation stages
          --ll-exception       display a low level backtrace on errors
          --profile            print profile information to standard error


        Note that only boolean single-letter options may be bundled.

        Output from --profile can be visualized by kcachegrind.


        To modify the include path, you can set the PERL6LIB environment variable:
        
        PERL6LIB=\"lib\" perl6 example.pl
        
        For more information, see the perl6(1) man page.\n"); 
        nqp::exit(0);
    }
}
rakudo-2013.12/src/Perl6/Grammar.nqp0000664000175000017500000043707512255230276016514 0ustar  moritzmoritzuse QRegex;
use NQPP6QRegex;
use NQPP5QRegex;
use Perl6::Actions;
use Perl6::World;
use Perl6::Pod;

role startstop[$start, $stop] {
    token starter { $start }
    token stopper { $stop }
}

role stop[$stop] {
    token starter {  }
    token stopper { $stop }
}

# This role captures things that STD factors out from any individual grammar,
# but that don't make sense to go in HLL::Grammar.
role STD {
    token opener {
        <[
        \x0028 \x003C \x005B \x007B \x00AB \x0F3A \x0F3C \x169B \x2018 \x201A \x201B
        \x201C \x201E \x201F \x2039 \x2045 \x207D \x208D \x2208 \x2209 \x220A \x2215
        \x223C \x2243 \x2252 \x2254 \x2264 \x2266 \x2268 \x226A \x226E \x2270 \x2272
        \x2274 \x2276 \x2278 \x227A \x227C \x227E \x2280 \x2282 \x2284 \x2286 \x2288
        \x228A \x228F \x2291 \x2298 \x22A2 \x22A6 \x22A8 \x22A9 \x22AB \x22B0 \x22B2
        \x22B4 \x22B6 \x22C9 \x22CB \x22D0 \x22D6 \x22D8 \x22DA \x22DC \x22DE \x22E0
        \x22E2 \x22E4 \x22E6 \x22E8 \x22EA \x22EC \x22F0 \x22F2 \x22F3 \x22F4 \x22F6
        \x22F7 \x2308 \x230A \x2329 \x23B4 \x2768 \x276A \x276C \x276E \x2770 \x2772
        \x2774 \x27C3 \x27C5 \x27D5 \x27DD \x27E2 \x27E4 \x27E6 \x27E8 \x27EA \x2983
        \x2985 \x2987 \x2989 \x298B \x298D \x298F \x2991 \x2993 \x2995 \x2997 \x29C0
        \x29C4 \x29CF \x29D1 \x29D4 \x29D8 \x29DA \x29F8 \x29FC \x2A2B \x2A2D \x2A34
        \x2A3C \x2A64 \x2A79 \x2A7D \x2A7F \x2A81 \x2A83 \x2A8B \x2A91 \x2A93 \x2A95
        \x2A97 \x2A99 \x2A9B \x2AA1 \x2AA6 \x2AA8 \x2AAA \x2AAC \x2AAF \x2AB3 \x2ABB
        \x2ABD \x2ABF \x2AC1 \x2AC3 \x2AC5 \x2ACD \x2ACF \x2AD1 \x2AD3 \x2AD5 \x2AEC
        \x2AF7 \x2AF9 \x2E02 \x2E04 \x2E09 \x2E0C \x2E1C \x2E20 \x3008 \x300A \x300C
        \x300E \x3010 \x3014 \x3016 \x3018 \x301A \x301D \xFD3E \xFE17 \xFE35 \xFE37
        \xFE39 \xFE3B \xFE3D \xFE3F \xFE41 \xFE43 \xFE47 \xFE59 \xFE5B \xFE5D \xFF08
        \xFF1C \xFF3B \xFF5B \xFF5F \xFF62
        ]>
    }
    
    method balanced($start, $stop) {
        self.HOW.mixin(self, startstop.HOW.curry(startstop, $start, $stop));
    }
    method unbalanced($stop) {
        self.HOW.mixin(self, stop.HOW.curry(stop, $stop));
    }
    
    token starter {  }
    token stopper {  }
    
    my %quote_lang_cache;
    method quote_lang($l, $start, $stop, @base_tweaks?, @extra_tweaks?) {
        sub lang_key() {
            my @keybits := [$l.HOW.name($l), $start, $stop];
            for @base_tweaks {
                @keybits.push($_);
            }
            for @extra_tweaks {
                if $_[0] eq 'to' {
                    return 'NOCACHE';
                }
                @keybits.push($_[0] ~ '=' ~ $_[1]);
            }
            nqp::join("\0", @keybits)
        }
        sub con_lang() {
            my $lang := $l;
            for @base_tweaks {
                $lang := $lang."tweak_$_"(1);
            }
            for @extra_tweaks {
                my $t := $_[0];
                if nqp::can($lang, "tweak_$t") {
                    $lang := $lang."tweak_$t"($_[1]);
                }
                else {
                    self.sorry("Unrecognized adverb: :$t");
                }
            }
            $start ne $stop ?? $lang.balanced($start, $stop)
                            !! $lang.unbalanced($stop);
        }

        # Get language from cache or derive it.
        my $key := lang_key();
        nqp::ifnull(%quote_lang_cache, %quote_lang_cache := nqp::hash());
        nqp::existskey(%quote_lang_cache, $key) && $key ne 'NOCACHE'
            ?? %quote_lang_cache{$key}
            !! (%quote_lang_cache{$key} := con_lang());
    }
    
    token babble($l, @base_tweaks?) {
        :my @extra_tweaks;

        <.ws>
        [  <.ws>
            {
                my $kv := $[-1].ast;
                my $k  := $kv.named;
                if nqp::istype($kv, QAST::Stmts) || nqp::istype($kv, QAST::Stmt) && +@($kv) == 1 {
                    $kv := $kv[0];
                }
                my $v := nqp::istype($kv, QAST::IVal)
                    ?? $kv.value
                    !! $kv.has_compile_time_value
                        ?? $kv.compile_time_value
                        !! self.panic("Invalid adverb value for " ~ $[-1].Str);
                nqp::push(@extra_tweaks, [$k, $v]);
            }
        ]*

        $=[]
        {
            # Work out the delimeters.
            my $c := $/.CURSOR;
            my @delims := $c.peek_delimiters($c.target, $c.pos);
            my $start := @delims[0];
            my $stop  := @delims[1];
            
            # Get the language.
            my $lang := self.quote_lang($l, $start, $stop, @base_tweaks, @extra_tweaks);
            $.'!make'([$lang, $start, $stop]);
        }
    }
    
    my @herestub_queue;

    my class Herestub {
        has $!delim;
        has $!orignode;
        has $!lang;
        method delim() { $!delim }
        method orignode() { $!orignode }
        method lang() { $!lang }
    }

    role herestop {
        token stopper { ^^ {} $=(\h*) $*DELIM \h* $$ \v? }
    }

    method heredoc () {
        if @herestub_queue {
            my $here := self.'!cursor_start_cur'();
            $here.'!cursor_pos'(self.pos);
            while @herestub_queue {
                my $herestub := nqp::shift(@herestub_queue);
                my $*DELIM := $herestub.delim;
                my $lang := $herestub.lang.HOW.mixin($herestub.lang, herestop);
                my $doc := $here.nibble($lang);
                if $doc {
                    # Match stopper.
                    my $stop := $lang.'!cursor_init'(self.orig(), :p($doc.pos), :shared(self.'!shared'())).stopper();
                    unless $stop {
                        self.panic("Ending delimiter $*DELIM not found");
                    }
                    $here.'!cursor_pos'($stop.pos);
                    
                    # Get it trimmed and AST updated.
                    $*ACTIONS.trim_heredoc($doc, $stop, $herestub.orignode.MATCH.ast);
                }
                else {
                    self.panic("Ending delimiter $*DELIM not found");
                }
            }
            $here.'!cursor_pass'($here.pos);
            $here
        }
        else {
            self
        }
    }

    method queue_heredoc($delim, $lang) {
        nqp::ifnull(@herestub_queue, @herestub_queue := []);
        nqp::push(@herestub_queue, Herestub.new(:$delim, :$lang, :orignode(self)));
        return self;
    }

    token quibble($l, *@base_tweaks) {
        :my $lang;
        :my $start;
        :my $stop;
        
        { my $B := $.ast; $lang := $B[0]; $start := $B[1]; $stop := $B[2]; }

        $start  [ $stop || { $/.CURSOR.panic("Couldn't find terminator $stop") } ]

        {
            nqp::can($lang, 'herelang') && self.queue_heredoc(
                $*W.nibble_to_str($/, $.ast[1], -> { "Stopper '" ~ $ ~ "' too complex for heredoc" }),
                $lang.herelang)
        }
    }

    method nibble($lang) {
        my $lang_cursor := $lang.'!cursor_init'(self.orig(), :p(self.pos()), :shared(self.'!shared'()));
        my $*ACTIONS;
        for %*LANG {
            if nqp::istype($lang, $_.value) {
                $*ACTIONS := %*LANG{$_.key ~ '-actions'};
                last;
            }
        }
        $lang_cursor.nibbler();
    }
    
    method panic(*@args) {
        self.typed_panic('X::Comp::AdHoc', payload => nqp::join('', @args))
    }
    method sorry(*@args) {
        self.typed_sorry('X::Comp::AdHoc', payload => nqp::join('', @args))
    }
    method worry(*@args) {
        self.typed_worry('X::Comp::AdHoc', payload => nqp::join('', @args))
    }

    method typed_panic($type_str, *%opts) {
        $*W.throw(self.MATCH(), nqp::split('::', $type_str), |%opts);
    }
    method typed_sorry($type_str, *%opts) {
        if +@*SORROWS + 1 == $*SORRY_LIMIT {
            $*W.throw(self.MATCH(), nqp::split('::', $type_str), |%opts);
        }
        else {
            @*SORROWS.push($*W.typed_exception(self.MATCH(), nqp::split('::', $type_str), |%opts));
        }
        self
    }
    method typed_worry($type_str, *%opts) {
        @*WORRIES.push($*W.typed_exception(self.MATCH(), nqp::split('::', $type_str), |%opts));
        self
    }
    
    method malformed($what) {
        self.typed_panic('X::Syntax::Malformed', :$what);
    }
    method missing($what) {
        self.typed_panic('X::Syntax::Missing', :$what);
    }
    method NYI($feature) {
        self.typed_panic('X::Comp::NYI', :$feature)
    }

    method EXPR_nonassoc($cur, $left, $right) {
        self.typed_panic('X::Syntax::NonAssociative', :left(~$left), :right(~$right));
    }

    # "when" arg assumes more things will become obsolete after Perl 6 comes out...
    method obs($old, $new, $when = 'in Perl 6') {
        $*W.throw(self.MATCH(), ['X', 'Obsolete'],
            old         => $old,
            replacement => $new,
            when        => $when,
        );
    }
    method sorryobs($old, $new, $when = ' in Perl 6') {
        $*W.throw(self.MATCH(), ['X', 'Obsolete'],
            old         => $old,
            replacement => $new,
            when        => $when,
        );
    }
    method worryobs($old, $new, $when = ' in Perl 6') {
        $*W.throw(self.MATCH(), ['X', 'Obsolete'],
            old         => $old,
            replacement => $new,
            when        => $when,
        );
    }
    
    method check_variable($var) {
        my $varast := $var.ast;
        if nqp::istype($varast, QAST::Op) && $varast.op eq 'ifnull' {
            $varast := $varast[0];
        }
        if !$*IN_DECL && nqp::istype($varast, QAST::Var) && $varast.scope eq 'lexical' {
            my $name := $varast.name;
            if $name ne '%_' && $name ne '@_' && !$*W.is_lexical($name) {
                if $var ne '&' {
                    my @suggestions := $*W.suggest_lexicals($name);
                    $*W.throw($var, ['X', 'Undeclared'], symbol => $varast.name(), suggestions => @suggestions);
                }
                else {
                    $var.CURSOR.add_mystery($varast.name, $var.to, 'var');
                }
            }
            else {
                my $lex := $*W.cur_lexpad();
                my %sym := $lex.symbol($name);
                if %sym {
                    %sym := 1;
                }
                else {
                    # Add mention-only record (used to poison outer
                    # usages and disambiguate hashes/blocks by use of
                    # $_ when $*IMPLICIT is in force).
                    $lex := {} unless $lex;
                    $lex{$name} := 1;
                }
            }
        }
        self
    }
}

grammar Perl6::Grammar is HLL::Grammar does STD {
    my $sc_id := 0;
    method TOP() {
        # Language braid.
        my %*LANG;
        %*LANG           := Perl6::RegexGrammar;
        %*LANG   := Perl6::RegexActions;
        %*LANG         := Perl6::P5RegexGrammar;
        %*LANG := Perl6::P5RegexActions;
        %*LANG               := Perl6::QGrammar;
        %*LANG       := Perl6::QActions;
        %*LANG
            := Perl6::Grammar;
        %*LANG    := Perl6::Actions;
        
        # Package declarator to meta-package mapping. Starts pretty much empty;
        # we get the mappings either imported or supplied by the setting. One
        # issue is that we may have no setting to provide them, e.g. when we
        # compile the setting, but it still wants some kinda package. We just
        # fudge in knowhow for that.
        my %*HOW;
        %*HOW := nqp::knowhow();
        %*HOW := nqp::knowhow();
        
        # Symbol table and serialization context builder - keeps track of
        # objects that cross the compile-time/run-time boundary that are
        # associated with this compilation unit.
        my $file := nqp::getlexdyn('$?FILES');
        my $source_id := nqp::sha1(
            nqp::defined(%*COMPILING<%?OPTIONS>)
                ?? self.target() ~ $sc_id++
                !! self.target());
        my $*W := nqp::isnull($file) ??
            Perl6::World.new(:handle($source_id)) !!
            Perl6::World.new(:handle($source_id), :description($file));
        $*W.add_initializations();

        my $cursor := self.comp_unit;
        $*W.pop_lexpad(); # UNIT
        $*W.pop_lexpad(); # UNIT_OUTER
        $cursor;
    }

    ## Lexer stuff

    token apostrophe {
        <[ ' \- ]>
    }

    token identifier {
        <.ident> [ <.apostrophe> <.ident> ]*
    }

    token name {
        [
        |  *
        | +
        ]
    }

    token morename {
        :my $*QSIGIL := '';
        '::'
        [
        ||   >
            [
            | 
            | :dba('indirect name') '(' ~ ')' 
            ]
        ||  <.typed_panic: "X::Syntax::Name::Null">
        ]?
    }

    token longname {
         {} [ >  ]*
    }

    token deflongname {
        :dba('new name to be defined')
         *
    }

    token defterm {     # XXX this is probably too general
        :dba('new term to be defined')
        
        [
        | +
            {
                if $[0] -> $cf {
                    my $category := $.Str;
                    my $opname := $cf
                        ?? $*W.colonpair_nibble_to_str($/, $cf)
                        !! '';
                    my $canname  := $category ~ ":sym<" ~ $opname ~ ">";
                    my $termname := $category ~ ":<" ~ $opname ~ ">";
                    $/.CURSOR.add_categorical($category, $opname, $canname, $termname);
                }
            }
        | 
        ]
    }

    token module_name {
        
        [  :dba('generic role') '[' ~ ']'  ]?
    }

    token end_keyword {
         || \h* '=>'> »
    }
    token spacey {  }

    token ENDSTMT {
        [
        | \h* $$ <.ws> 
        | <.unv>? $$ <.ws> 
        ]?
    }

    # ws is highly performance sensitive. So, we check if we already marked it
    # at this point with a simple method, and only if that is not the case do
    # we bother doing any pattern matching.
    method ws() {
        if self.MARKED('ws') {
            self
        }
        else {
            self._ws()
        }
    }
    token _ws {
        :my $old_highexpect := self.'!fresh_highexpect'();
        :dba('whitespace')
        
        [
        | <.vws> <.heredoc>
        | <.unv>
        ]*
        
        :my $stub := self.'!set_highexpect'($old_highexpect);
    }
    
    token unsp {
        \\ 
        :dba('unspace')
        [
        | <.vws>
        | <.unv>
        ]*
    }
    
    token vws {
        :dba('vertical whitespace')
        [
            [
            | \v
            | '<<<<<<<' {} >>>>>>' > <.sorry: 'Found a version control conflict marker'> \V* \v
            | '=======' {} .*? \v '>>>>>>>' \V* \v   # ignore second half
            ]
        ]+
    }

    token unv {
        :dba('horizontal whitespace')
        [
        | \h+
        | \h* <.comment>
        |  ^^ <.pod_content_toplevel>
        ]
    }

    proto token comment { <...> }

    token comment:sym<#> {
       '#' {} \N*
    }

    token comment:sym<#`(...)> {
        '#`'  {}
        [ <.quibble(%*LANG)> || <.typed_panic: 'X::Syntax::Comment::Embedded'> ]
    }

    token comment:sym<#=(...)> {
        '#='  )>
    }

    token comment:sym<#=> {
        '#=' \h+ $=[\N*]
        { $*DECLARATOR_DOCS := $ }
    }

    method attach_docs() {
        if ~$*DOC ne '' {
            my $cont  := Perl6::Pod::serialize_aos(
                [Perl6::Pod::formatted_text(~$*DOC)]
            ).compile_time_value;
            my $block := $*W.add_constant(
                'Pod::Block::Declarator', 'type_new',
                :nocache, :content($cont),
            );
            $*DOCEE := $block.compile_time_value;
            $*POD_BLOCKS.push($*DOCEE);
        }
        self
    }

    token pod_content_toplevel {
        
    }

    proto token pod_content { <...> }

    token pod_content:sym {
        *
        
        *
    }

    # any number of paragraphs of text
    token pod_content:sym {
        *
        + % +
        *
    }

    # not a block, just a directive
    token pod_content:sym {
        *
        ^^ \h* '=config' \h+ $=\S+ 
        +
    }

    proto token pod_textcontent { <...> }

    # text not being code
    token pod_textcontent:sym {
        $=[ \h* ]
         .to - $.from) <= $*VMARGIN }>

        $ = [
            \h*   
        ] +
    }

    token pod_textcontent:sym {
        $=[ \h* ]
        .to - $.from) > $*VMARGIN }>
        $ = [
            [ \N+]+ % [ $]
        ]
    }

    token pod_formatting_code {
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        :my $*POD_IN_FORMATTINGCODE := nqp::getlexdyn('$*POD_IN_FORMATTINGCODE');
        :my $*POD_ANGLE_COUNT := nqp::getlexdyn('$*POD_ANGLE_COUNT');
        

        :my $endtag;
        $=<[A..Z]>
        $=['<'+  | '«'] { $*POD_IN_FORMATTINGCODE := 1 }
        .Str) - nqp::ord("A");
            if !($*POD_ALLOW_FCODES +& (2 ** $codenum)) {
                0
            } elsif ~$ eq '«' {
              $endtag := "»";
              $*POD_ANGLE_COUNT := -1;
              1
            } else {
              my $ct := nqp::chars($);
              $endtag := nqp::x(">", $ct);
              my $rv := $*POD_ANGLE_COUNT == 0 || $*POD_ANGLE_COUNT >= $ct;
              $*POD_ANGLE_COUNT := $ct;
              $rv;
            }
        }>
        {
            if $.Str eq "V" || $.Str eq "C" {
                $*POD_ALLOW_FCODES := 0;
            }
        }
        $=[  ]+?
        $endtag
    }

    token pod_balanced_braces {
        
        :my $endtag;
        [
            $=[
                      || '<'+ 
                      || '>'+ ]>
                      ]
            ) < $*POD_ANGLE_COUNT || $*POD_ANGLE_COUNT < 0 }>
          ||
            = 1 }>
            $=['<'+] 
            ) == $*POD_ANGLE_COUNT || $*POD_ANGLE_COUNT < 0 }>
            {
                $endtag := nqp::x(">", nqp::chars($));
            }
            $=[ *?]
            '> $=[$endtag]
        ]
    }

    token pod_string {
        +
    }

    token pod_string_character {
         ||  || $=[ \N || [
             \n 
            ]
        ]
    }

    proto token pod_block { <...> }

    token pod_configuration($spaces = '') {
        [ [\n $spaces '=']? \h+  ]*
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=begin' \h+ $=[ 'code' | 'comment' ] {}
        )> +
        [
         $ = [ .*? ]
         ^^ $ '=end' \h+ $ 
         ||  <.typed_panic: 'X::Syntax::Pod::BeginWithoutEnd'>
        ]
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=begin'
        [ 
          <.typed_panic('X::Syntax::Pod::BeginWithoutIdentifier')>
        ]?
        \h+ 
        {
            $*VMARGIN    := $.to - $.from;
        }
        :my $*ALLOW_CODE := 0;
        $ = [
             { $*ALLOW_CODE := 1 }
            || 
        ]
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        )> +
        [
          *
         ^^ $ '=end' \h+ $ 
         ||  <.typed_panic: 'X::Syntax::Pod::BeginWithoutEnd'>
        ]
    }


    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=begin' \h+ 'table'
            :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
            )> +
        [
         *
         ^^ \h* '=end' \h+ 'table' 
         ||  <.typed_panic: 'X::Syntax::Pod::BeginWithoutEnd'>
        ]
    }

    token table_row {
        \h*  \N* \n
    }

    token pod_block:sym {
        ^^ \h*
        [
            | '=begin' \h+ 'END' 
            | '=for'   \h+ 'END' 
            | '=END' 
        ]
        .*
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=for' \h+ 
        {
            $*VMARGIN := $.to - $.from;
        }
        :my $*ALLOW_CODE := 0;
        $ = [
             { $*ALLOW_CODE := 1 }
            || 
        ]
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        )> 
        **0..1
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=for' \h+ $=[ 'code' | 'comment' ]
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        )> 
        $ = [ \h*  \N+ \n ]+
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=for' \h+ 'table'
            :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
            )> 
        [  ]*
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=' 
        {
            $*VMARGIN := $.to - $.from;
        }
        :my $*ALLOW_CODE := 0;
        $ = [
             { $*ALLOW_CODE := 1 }
            || 
        ]
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        )>
        [\r\n|\s]
        **0..1
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        '=' $=[ 'code' | 'comment' ]
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        )> [\r\n|\s]
        $ = [ \h*  \N+ \n ]*
    }

    token pod_block:sym {
        ^^
        $ = [ \h* ]
        :my $*POD_ALLOW_FCODES := nqp::getlexdyn('$*POD_ALLOW_FCODES');
        '=table' )> 
        [  ]*
    }

    token pod_newline {
        \h* \n
    }

    token pod_code_parent {
        [
        || 'pod'
        || 'output'
        || 'item' \d*
        ]
        
        # TODO: Also Semantic blocks one day
    }

    token install_doc_phaser {  }

    token vnum {
        \d+ | '*'
    }

    token version {
        'v'  {} $=[+ % '.' '+'?]
         # cheat because of LTM fail
    }

    ## Top-level rules

    token comp_unit {
        # From STD.pm.
        :my $*LEFTSIGIL;                           # sigil of LHS for item vs list assignment
        :my $*SCOPE := '';                         # which scope declarator we're under
        :my $*MULTINESS := '';                     # which multi declarator we're under
        :my $*QSIGIL := '';                        # sigil of current interpolation
        :my $*IN_META := '';                       # parsing a metaoperator like [..]
        :my $*IN_REDUCE := 0;                      # attempting to parse an [op] construct
        :my $*IN_DECL;                             # what declaration we're in
        :my $*HAS_SELF := '';                      # is 'self' available? (for $.foo style calls)
        :my $*MONKEY_TYPING := 0;                  # whether augment/supersede are allowed
        :my $*begin_compunit := 1;                 # whether we're at start of a compilation unit
        :my $*DECLARAND;                           # the current thingy we're declaring, and subject of traits
        :my $*METHODTYPE;                          # the current type of method we're in, if any
        :my $*PKGDECL;                             # what type of package we're in, if any
        :my %*MYSTERY;                             # names we assume may be post-declared functions
        :my $*CCSTATE := '';
        
        # Error related. There are three levels: worry (just a warning), sorry
        # (fatal but not immediately so) and panic (immediately deadly). There
        # is a limit on the number of sorrows also. Unlike STD, which emits the
        # textual messages as it goes, we keep track of the exception objects
        # and, if needed, make a compositite exception group.
        :my @*WORRIES;                             # exception objects resulting from worry
        :my @*SORROWS;                             # exception objects resulting from sorry
        :my $*SORRY_LIMIT := 10;                   # when sorrow turns to panic

        # Extras.
        :my %*METAOPGEN;                           # hash of generated metaops
        :my %*HANDLERS;                            # block exception handlers
        :my $*IMPLICIT;                            # whether we allow an implicit param
        :my $*FORBID_PIR := 0;                     # whether pir::op and Q:PIR { } are disallowed
        :my $*HAS_YOU_ARE_HERE := 0;               # whether {YOU_ARE_HERE} has shown up
        :my $*OFTYPE;
        :my $*VMARGIN    := 0;                     # pod stuff
        :my $*ALLOW_CODE := 0;                     # pod stuff
        :my $*POD_IN_FORMATTINGCODE := 0;          # pod stuff
        :my $*POD_ALLOW_FCODES := 0b11111111111111111111111111; # allow which fcodes?
        :my $*POD_ANGLE_COUNT := 0;                # pod stuff
        :my $*IN_REGEX_ASSERTION := 0;
        :my $*SOFT := 0;                           # is the soft pragma in effect
        :my $*IN_PROTO := 0;                       # are we inside a proto?
        
        # Various interesting scopes we'd like to keep to hand.
        :my $*GLOBALish;
        :my $*PACKAGE;
        :my $*SETTING;
        :my $*UNIT;
        :my $*UNIT_OUTER;
        :my $*EXPORT;
        # stack of packages, which the 'is export' needs
        :my @*PACKAGES := [];

        # A place for Pod
        :my $*POD_BLOCKS := [];
        :my $*POD_BLOCKS_SEEN := {};
        :my $*POD_PAST;
        :my $*DECLARATOR_DOCS;
        
        # Quasis and unquotes
        :my $*IN_QUASI := 0;                       # whether we're currently in a quasi block

        # Setting loading and symbol setup.
        {
            # Create unit outer (where we assemble any lexicals accumulated
            # from e.g. REPL) and the real UNIT.
            $*UNIT_OUTER := $*W.push_lexpad($/);
            $*UNIT := $*W.push_lexpad($/);
            
            # If we already have a specified outer context, then that's
            # our setting. Otherwise, load one.
            my $have_outer := nqp::defined(%*COMPILING<%?OPTIONS>);
            if $have_outer {
                $*UNIT := 'eval';
            }
            else {
                $*SETTING := $*W.load_setting($/, %*COMPILING<%?OPTIONS> // 'CORE');
                $*UNIT := 'mainline';
            }
            $/.CURSOR.unitstart();
            try {
                my $EXPORTHOW := $*W.find_symbol(['EXPORTHOW']);
                for $*W.stash_hash($EXPORTHOW) {
                    %*HOW{$_.key} := $_.value;
                }
            }
            
            # Create GLOBAL(ish), unless we were given one.
            if nqp::existskey(%*COMPILING<%?OPTIONS>, 'global') {
                $*GLOBALish := %*COMPILING<%?OPTIONS>;
            }
            elsif $have_outer && $*UNIT_OUTER.symbol('GLOBALish') {
                $*GLOBALish := $*UNIT_OUTER.symbol('GLOBALish');
            }
            else {
                $*GLOBALish := $*W.pkg_create_mo($/, %*HOW, :name('GLOBAL'));
                $*W.pkg_compose($*GLOBALish);
            }
                
            # Create or pull in existing EXPORT.
            if $have_outer && $*UNIT_OUTER.symbol('EXPORT') {
                $*EXPORT := $*UNIT_OUTER.symbol('EXPORT');
            }
            else {
                $*EXPORT := $*W.pkg_create_mo($/, %*HOW, :name('EXPORT'));
                $*W.pkg_compose($*EXPORT);
            }
            
            # If there's a self in scope, set $*HAS_SELF.
            if $have_outer && $*UNIT_OUTER.symbol('self') {
                $*HAS_SELF := 'complete';
            }
                
            # Take current package from outer context if any, otherwise for a
            # fresh compilation unit we start in GLOBAL.
            if $have_outer && $*UNIT_OUTER.symbol('$?PACKAGE') {
                $*PACKAGE := $*UNIT_OUTER.symbol('$?PACKAGE');
            }
            else {
                $*PACKAGE := $*GLOBALish;
            }
            
            # If we're eval'ing in the context of a %?LANG, set up our own
            # %*LANG based on it.
            if $have_outer && $*UNIT_OUTER.symbol('%?LANG') {
                for $*UNIT_OUTER.symbol('%?LANG').FLATTENABLE_HASH() {
                    %*LANG{$_.key} := $_.value;
                }
            }
            
            # Install unless we've no setting, in which case we've likely no
            # static lexpad class yet either. Also, UNIT needs a code object.
            unless %*COMPILING<%?OPTIONS> eq 'NULL' {
                $*W.install_lexical_symbol($*UNIT, 'GLOBALish', $*GLOBALish);
                $*W.install_lexical_symbol($*UNIT, 'EXPORT', $*EXPORT);
                $*W.install_lexical_symbol($*UNIT, '$?PACKAGE', $*PACKAGE);
                $*W.install_lexical_symbol($*UNIT, '::?PACKAGE', $*PACKAGE);
                $*DECLARAND := $*W.stub_code_object('Block');
            }
            my $M := %*COMPILING<%?OPTIONS>;
            if nqp::defined($M) {
                for nqp::islist($M) ?? $M !! [$M] -> $longname {
                    my $module := $*W.load_module($/, $longname, {}, $*GLOBALish);
                    do_import($/, $module, $longname);
                    $/.CURSOR.import_EXPORTHOW($module);
                }
            }
        }
        
        <.finishpad>
        <.bom>?
        

        <.install_doc_phaser>
        
        [ $ || <.typed_panic: 'X::Syntax::Confused'> ]
        
        {
            # Emit any errors/worries.
            self.explain_mystery();
            if @*SORROWS {
                if +@*SORROWS == 1 && !@*WORRIES {
                    @*SORROWS[0].throw()
                }
                else {
                    $*W.group_exception(@*SORROWS.pop).throw();
                }
            }
            if @*WORRIES {
                nqp::printfh(nqp::getstderr(), $*W.group_exception().gist());
            }
        
            # Install POD-related variables.
            $*POD_PAST := $*W.add_constant(
                'Array', 'type_new', |$*POD_BLOCKS
            );
            $*W.install_lexical_symbol(
                $*UNIT, '$=pod', $*POD_PAST.compile_time_value
            );
            
            # Tag UNIT with a magical lexical. Also if we're compiling CORE,
            # give it such a tag too.
            if %*COMPILING<%?OPTIONS> eq 'NULL' {
                my $marker := $*W.pkg_create_mo($/, %*HOW, :name('!CORE_MARKER'));
                $marker.HOW.compose($marker);
                $*W.install_lexical_symbol($*UNIT, '!CORE_MARKER', $marker);
            }
            else {
                my $marker := $*W.pkg_create_mo($/, %*HOW, :name('!UNIT_MARKER'));
                $marker.HOW.compose($marker);
                $*W.install_lexical_symbol($*UNIT, '!UNIT_MARKER', $marker);
            }
        }
        
        # CHECK time.
        { $*W.CHECK(); }
    }
    
    method import_EXPORTHOW($UNIT) {    
        # See if we've exported any HOWs.
        if nqp::existskey($UNIT, 'EXPORTHOW') {
            for $*W.stash_hash($UNIT) {
                %*HOW{$_.key} := nqp::decont($_.value);
            }
        }
    }

    rule statementlist {
        :my %*LANG := self.shallow_copy(nqp::getlexdyn('%*LANG'));
        :my %*HOW  := self.shallow_copy(nqp::getlexdyn('%*HOW'));
        :dba('statement list')
        ''
        [
        | $
        | >
        | [  <.eat_terminator> ]*
        ]
    }

    method shallow_copy(%hash) {
        my %result;
        for %hash {
            %result{$_.key} := $_.value;
        }
        %result
    }

    rule semilist {
        :dba('semicolon list')
        ''
        [
        |  >
        | [<.eat_terminator> ]*
        ]
    }

    token label {
        :my $label;
         ':'  <.ws>
    }

    token statement {
        :my $*QSIGIL := '';
        :my $*SCOPE := '';
        :my $*ACTIONS := %*LANG;
         | $ >
        
        ) }>
        [
        | 
   {   }
    token statement_prefix:sym  {   }
    
    token statement_prefix:sym  {   }
    token statement_prefix:sym   {   }
    token statement_prefix:sym{   }
    token statement_prefix:sym  {   }
    token statement_prefix:sym    {   }
    token statement_prefix:sym   {
         \s <.ws> $=['BEGIN' || 'CHECK' || 'INIT']
        
    }

    token blorst {
        \s <.ws> [   |   || <.missing: 'block or statement'> ]
    }

    ## Statement modifiers

    proto rule statement_mod_cond { <...> }

    token modifier_expr {  }

    rule statement_mod_cond:sym     {   }
    rule statement_mod_cond:sym {   }
    rule statement_mod_cond:sym   {   }

    proto rule statement_mod_loop { <...> }

    rule statement_mod_loop:sym {   }
    rule statement_mod_loop:sym {   }
    rule statement_mod_loop:sym   {   }
    rule statement_mod_loop:sym {   }

    ## Terms

    token term:sym           {  }
    token term:sym          {  }
    token term:sym           {  { $*VAR := $ } }
    token term:sym {  }
    token term:sym   {  }
    token term:sym {  }
    token term:sym   {   }
    token term:sym   {  }
    token term:sym          {  }
    token term:sym   {  }
    token term:sym<**>                 {  <.NYI('HyperWhatever (**)')> }
    token term:sym<*>                  {  }
    token term:sym             {   }
    token term:sym    {  }
    token term:sym              {  }
    token term:sym            { '{{{'   '}}}' }

    token term:sym<::?IDENT> {
        $ = [ '::?'  ] »
    }
    
    token infix:sym {
        ' >  {
            my $needparens := 0;
            my $pos := $/.from;
            my $line := HLL::Compiler.lineof($/.orig, $/.from, :cache(1));
            my $lex := $*W.cur_lexpad();
            for 'if', 'unless', 'while', 'until', 'for', 'given', 'when', 'loop', 'sub', 'method' {
                $needparens++ if $_ eq 'loop';
                my $m := %*MYSTERY{$_ ~ '-' ~ $lex.cuid};
                next unless $m;
                my $m_pos  := $m[nqp::elems($m) - 1];
                my $m_line := HLL::Compiler.lineof($/.orig, $m_pos, :cache(1));
                if $line - $m_line < 5 {
                    if $m eq '(' {
                        $/.CURSOR.'!clear_highwater'();
                        $/.CURSOR.'!cursor_pos'($m_pos);
                        $/.CURSOR.typed_sorry('X::Syntax::KeywordAsFunction',
                                word => $_,
                                :$needparens,
                        );
                        $/.CURSOR.'!cursor_pos'($pos);
                        $/.CURSOR.panic("Unexpected block in infix position (two terms in a row)");
                    }
                    else {
                        $/.CURSOR.'!clear_highwater'();
                        $/.CURSOR.'!cursor_pos'($m_pos);
                        $/.CURSOR.sorry("Word '$_' interpreted as a listop; please use 'do $_' to introduce the statement control word");
                        $/.CURSOR.'!cursor_pos'($pos);
                        $/.CURSOR.panic("Unexpected block in infix position (two terms in a row)");
                    }
                }
            }
        }
        [
        ||  {
            $/.CURSOR.panic("Unexpected block in infix position (two terms in a row, or previous statement missing semicolon?)");
        }
        || 
        ]
    }
    
    token term:sym {
         >> {}
        [ 
            <.obs('$/ variable as input record separator',
                 "the filehandle's .slurp method")>
        ]?
        [ ?\w ] >
            <.obs('undef as a verb', 'undefine function or assignment of Nil')>
        ]?
        <.obs('undef as a value', "something more specific:\n\tAny (the \"whatever\" type object),\n\tan undefined type object such as Int,\n\t:!defined as a matcher,\n\tAny:U as a type constraint,\n\tNil as the absence of a value\n\tor fail() as a failure return\n\t   ")>
    }

    token term:sym {
        'new' \h+  \h*  <.obs("C++ constructor syntax", "method call syntax")>
    }

    token fatarrow {
         \h* '=>' <.ws> 
    }
    
    token coloncircumfix($front) {
        [
        | '<>' <.worry("Pair with <> really means an empty list, not null string; use :$front" ~ "('') to represent the null string,\n  or :$front" ~ "() to represent the empty list more accurately")>
        | 
        ]
    }

    token colonpair {
        :my $*key;
        :my $*value;

        ':'
        :dba('colon pair')
        [
        | '!' [  || <.panic: "Malformed False pair; expected identifier"> ]
            [ <[ \[ \( \< \{ ]> {
            $/.CURSOR.typed_panic('X::Syntax::NegatedPair', key => ~$) } ]?
            { $*key := $.Str; $*value := 0; }
        | 
            { $*key := $.Str; }
            [
            || <.unsp>? :dba('pair value')  { $*value := $; }
            || { $*value := 1; }
            ]
        | :dba('signature') '(' ~ ')' 
        | 
            { $*key := ""; $*value := $; }
        | 
            { $*key := $.Str; $*value := $; self.check_variable($*value); }
        ]
    }
    
    token colonpair_variable {
         {}
        [
        | ? 
        | $='<'  '>'
        ]
    }

    proto token special_variable { <...> }

    token special_variable:sym<$!{ }> {
        '$!{' .*? '}'
        <.obs('${ ... } or %! variable', 'smart match against $!')>
    }

    token special_variable:sym<$~> {
          >
        <.obs('$~ variable', 'Form module')>
    }

    token special_variable:sym<$`> {
           >
        <.obs('$` variable', 'explicit pattern before <(')>
    }

    token special_variable:sym<$@> {
          >
        <.obs('$@ variable as eval error', '$!')>
    }

    # TODO: use actual variable in error message
    token special_variable:sym<$#> {
        
        [
        || \w+ <.obs('$#variable', '@variable.end')>
        || <.obs('$# variable', '.fmt')>
        ]
    }

    token special_variable:sym<$$> {
           >
        <.obs('$$ variable', '$*PID')>
    }
    token special_variable:sym<$%> {
          >
        <.obs('$% variable', 'Form module')>
    }

    # TODO: $^X and other "caret" variables

    token special_variable:sym<$^> {
          >
        <.obs('$^ variable', 'Form module')>
    }

    token special_variable:sym<$&> {
          >
        <.obs('$& variable', '$/ or $()')>
    }

    token special_variable:sym<$*> {
          >
        <.obs('$* variable', '^^ and $$')>
    }

    token special_variable:sym<$)> {
           >
        <.obs('$) variable', '$*EGID')>
    }

    token special_variable:sym<$-> {
          >
        <.obs('$- variable', 'Form module')>
    }

    token special_variable:sym<$=> {
          >
        <.obs('$= variable', 'Form module')>
    }

    token special_variable:sym<@+> {
          >
        <.obs('@+ variable', '.to method')>
    }

    token special_variable:sym<%+> {
          >
        <.obs('%+ variable', '.to method')>
    }

    token special_variable:sym<$+[ ]> {
        '$+['
        <.obs('@+ variable', '.to method')>
    }

    token special_variable:sym<@+[ ]> {
        '@+['
        <.obs('@+ variable', '.to method')>
    }

    token special_variable:sym<@+{ }> {
        '@+{'
        <.obs('%+ variable', '.to method')>
    }

    token special_variable:sym<@-> {
          >
        <.obs('@- variable', '.from method')>
    }

    token special_variable:sym<%-> {
          >
        <.obs('%- variable', '.from method')>
    }

    token special_variable:sym<$-[ ]> {
        '$-['
        <.obs('@- variable', '.from method')>
    }

    token special_variable:sym<@-[ ]> {
        '@-['
        <.obs('@- variable', '.from method')>
    }

    token special_variable:sym<%-{ }> {
        '@-{'
        <.obs('%- variable', '.from method')>
    }

    token special_variable:sym<$+> {
          >
        <.obs('$+ variable', 'Form module')>
    }

    token special_variable:sym<$[> {
          >
        <.obs('$[ variable', 'user-defined array indices')>
    }

    token special_variable:sym<$]> {
          >
        <.obs('$] variable', '$*PERL_VERSION')>
    }

    token special_variable:sym<$\\> {
        '$\\'  >
        <.obs('$\\ variable', "the filehandle's :ors attribute")>
    }

    token special_variable:sym<$|> {
          >
        <.obs('$| variable', ':autoflush on open')>
    }

    token special_variable:sym<$:> {
         
        <.obs('$: variable', 'Form module')>
    }

    token special_variable:sym<$;> {
          >
        <.obs('$; variable', 'real multidimensional hashes')>
    }

    token special_variable:sym<$'> { #'
          >
        <.obs('$' ~ "'" ~ 'variable', "explicit pattern after )\x3E")>
    }

    # TODO: $"

    token special_variable:sym<$,> {
          >
        <.obs('$, variable', ".join() method")>
    }

    token special_variable:sym['$<'] {
          '> >
        <.obs('$< variable', '$*UID')>
    }

    token special_variable:sym«\$>» {
         {}  >
        <.obs('$> variable', '$*EUID')>
    }

    token special_variable:sym<$.> {
         {}  >
        <.obs('$. variable', "the filehandle's .line method")>
    }

    token special_variable:sym<$?> {
         {}  >
        <.obs('$? variable as child error', '$!')>
    }
    
    regex special_variable:sym<${ }> {
         '{' {} $=[.*?] '}'
        .Str;
            my $text := $.Str;
            my $bad := $sigil ~ '{' ~ $text ~ '}';
            $text := $text - 1 if $text ~~ /^\d+$/ && $text > 0;
            if !($text ~~ /^(\w|\:)+$/) {
                if $*QSIGIL {
                    0
                }
                else {
                    $/.CURSOR.obs($bad, $sigil ~ '(' ~ $text ~ ')');
                }
            }
            elsif $*QSIGIL {
                $/.CURSOR.obs($bad, '{' ~ $sigil ~ $text ~ '}');
            }
            else {
                $/.CURSOR.obs($bad, $sigil ~ $text);
            }
        }>
    }

    token desigilname {
        [
        |  <.sigil> > 
        | 
            [  <.typed_panic: 'X::Syntax::Variable::IndirectDeclaration'> ]?
             {
                $*VAR := $;
                self.check_variable($*VAR);
            }
        | 
        ]
    }

    token variable {
        :my $*IN_META := '';
         {
            unless $*LEFTSIGIL {
                $*LEFTSIGIL := $.Str;
            }
        }> {}
        [
        || '&'
            [
            | :dba('infix noun') '[' ~ ']' 
            ]
        ||  [
            |  ? 
            | 
            |  $=[\d+] [  <.typed_panic: "X::Syntax::Variable::Numeric">]?
            |   [  <.typed_panic('X::Syntax::Variable::Match')>]?  
            | :dba('contextualizer')  '(' ~ ')'  [ <.panic: "Cannot declare a contextualizer">]?
            | $=['$'] $=[<[/_!]>]
            |  
            |  {
                $/.CURSOR.typed_panic( 'X::Syntax::Perl5Var',
                  name => nqp::substr(~$/.orig, $/.to - 1, 3 ) )
              }
            ]
        ]
        [  && $ eq '.' }>
            [ <.unsp> | '\\' |  ]  
        ]?
    }

    token sigil { <[$@%&]> }

    proto token twigil { <...> }
    token twigil:sym<.> {   }
    token twigil:sym {   }
    token twigil:sym<^> {   }
    token twigil:sym<:> {   }
    token twigil:sym<*> {   }
    token twigil:sym {   }
    token twigil:sym<=> {   }

    proto token package_declarator { <...> }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'package';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'module';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'class';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'grammar';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'role';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'knowhow';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'native';
         <.end_keyword> 
    }
    token package_declarator:sym {
        :my $*OUTERPACKAGE := $*PACKAGE;
        :my $*PKGDECL := 'slang';
         <.end_keyword> 
    }
    token package_declarator:sym {
         <.ws> 
    }
    rule package_declarator:sym {
        
        [ + || <.panic: "No valid trait found after also"> ]
    }

    rule package_def {
        :my $longname;
        :my $outer := $*W.cur_lexpad();
        :my $*IMPLICIT := 0;
        :my $*DECLARAND;
        :my $*IN_DECL := 'package';
        :my $*HAS_SELF := '';
        :my $*CURPAD;
        :my $*DOC := $*DECLARATOR_DOCS;
        :my $*DOCEE;
        <.attach_docs>
        
        # Type-object will live in here; also set default REPR (a trait
        # may override this, e.g. is repr('...')).
        :my $*PACKAGE;
        :my %*ATTR_USAGES;
        :my $*REPR;
        
        # Default to our scoped.
        { unless $*SCOPE { $*SCOPE := 'our'; } }
        
        [
            [  { $longname := $*W.dissect_longname($); } ]?
            <.newpad>
            
            [ :dba('generic role')
            
            { $*PACKAGE := $*OUTERPACKAGE } # in case signature tries to declare a package
            '[' ~ ']' 
            { $*IN_DECL := ''; }
            ]?
            
            *
            
            {
                # Unless we're augmenting...
                if $*SCOPE ne 'augment' {
                    # Locate any existing symbol. Note that it's only a match
                    # with "my" if we already have a declaration in this scope.
                    my $exists := 0;
                    my @name := $longname ??
                        $longname.type_name_parts('package name', :decl(1)) !!
                        [];
                    if @name && $*SCOPE ne 'anon' {
                        if @name && $*W.already_declared($*SCOPE, $*OUTERPACKAGE, $outer, @name) {
                            $*PACKAGE := $*W.find_symbol(@name);
                            $exists := 1;
                        }
                    }

                    # If it exists already, then it's either uncomposed (in which
                    # case we just stubbed it), a role (in which case multiple
                    # variants are OK) or else an illegal redecl.
                    if $exists && ($*PKGDECL ne 'role' || !nqp::can($*PACKAGE.HOW, 'configure_punning')) {
                        if $*PKGDECL eq 'role' || $*PACKAGE.HOW.is_composed($*PACKAGE) {
                            $*W.throw($/, ['X', 'Redeclaration'],
                                symbol => $longname.name(),
                            );
                        }
                    }
                    
                    # If it's not a role, or it is a role but one with no name,
                    # then just needs meta-object construction and installation.
                    elsif $*PKGDECL ne 'role' || !@name {
                        # Construct meta-object for this package.
                        my %args;
                        if @name {
                            %args := $longname.name();
                        }
                        if $*REPR ne '' {
                            %args := $*REPR;
                        }
                        $*PACKAGE := $*W.pkg_create_mo($/, %*HOW{$*PKGDECL}, |%args);
                        
                        # Install it in the symbol table if needed.
                        if @name {
                            $*W.install_package($/, @name, $*SCOPE, $*PKGDECL, $*OUTERPACKAGE, $outer, $*PACKAGE);
                        }
                    }
                    
                    # If it's a named role, a little trickier. We need to make
                    # a parametric role group for it (unless we got one), and
                    # then install it in that.
                    else {
                        # If the group doesn't exist, create it.
                        my $group;
                        if $exists {
                            $group := $*PACKAGE;
                        }
                        else {
                            $group := $*W.pkg_create_mo($/, %*HOW{'role-group'}, :name($longname.name()), :repr($*REPR));
                            $*W.install_package($/, @name, $*SCOPE, $*PKGDECL, $*OUTERPACKAGE, $outer, $group);
                        }

                        # Construct role meta-object with group.
                        sub needs_args($s) {
                            return 0 if !$s;
                            my @params := $s.ast;
                            return 0 if nqp::elems(@params) == 0;
                            return nqp::elems(@params) > 1 || !@params[0];
                        }
                        $*PACKAGE := $*W.pkg_create_mo($/, %*HOW{$*PKGDECL}, :name($longname.name()),
                            :repr($*REPR), :group($group), :signatured(needs_args($)));
                    }
                }
                else {
                    # Augment. Ensure we can.
                    if !$*MONKEY_TYPING && $longname.text ne 'Cool' {
                        $/.CURSOR.typed_panic('X::Syntax::Augment::WithoutMonkeyTyping');
                    }
                    elsif !$longname {
                        $*W.throw($/, 'X::Anon::Augment', package-kind => $*PKGDECL);
                    }

                    # Locate type.
                    my @name := 
                      $longname.type_name_parts('package name', :decl(1));
                    my $found;
                    try { $*PACKAGE := $*W.find_symbol(@name); $found := 1 }
                    unless $found {
                        $*W.throw($/, 'X::Augment::NoSuchType',
                            package-kind => $*PKGDECL,
                            package      => $longname.text(),
                        );
                    }
                    unless $*PACKAGE.HOW.archetypes.augmentable {
                        $/.CURSOR.typed_panic('X::Syntax::Augment::Illegal',
                            package      => $longname.text);
                    }
                }
                
                # Install $?PACKAGE, $?ROLE, $?CLASS, and :: variants as needed.
                my $curpad := $*W.cur_lexpad();
                unless $curpad.symbol('$?PACKAGE') {
                    $*W.install_lexical_symbol($curpad, '$?PACKAGE', $*PACKAGE);
                    $*W.install_lexical_symbol($curpad, '::?PACKAGE', $*PACKAGE);
                    if $*PKGDECL eq 'class' || $*PKGDECL eq 'grammar' {
                        $*W.install_lexical_symbol($curpad, '$?CLASS', $*PACKAGE);
                        $*W.install_lexical_symbol($curpad, '::?CLASS', $*PACKAGE);
                    }
                    elsif $*PKGDECL eq 'role' {
                        $*W.install_lexical_symbol($curpad, '$?ROLE', $*PACKAGE);
                        $*W.install_lexical_symbol($curpad, '::?ROLE', $*PACKAGE);
                        $*W.install_lexical_symbol($curpad, '$?CLASS',
                            $*W.pkg_create_mo($/, %*HOW, :name('$?CLASS')));
                        $*W.install_lexical_symbol($curpad, '::?CLASS',
                            $*W.pkg_create_mo($/, %*HOW, :name('::?CLASS')));
                    }
                }
                
                # Set declarand as the package.
                $*DECLARAND := $*PACKAGE;
                
                # Apply any traits.
                for $ {
                    my $applier := $_.ast;
                    if $applier {
                        $applier($*DECLARAND);
                    }
                }
            }
            
            { nqp::push(@*PACKAGES, $*PACKAGE); }
            [
            ||  
                [
                {
                    $*IN_DECL := '';
                    $*begin_compunit := 0;
                }
                
                ]
            
            || ';'
                [
                || 
                    {
                        unless $longname {
                            $/.CURSOR.panic("Compilation unit cannot be anonymous");
                        }
                        unless $outer =:= $*UNIT {
                            $/.CURSOR.panic("Semicolon form of " ~ $*PKGDECL ~ " definition not allowed in subscope;\n  please use block form");
                        }
                        if $*PKGDECL eq 'package' {
                            $/.CURSOR.panic('This appears to be Perl 5 code. If you intended it to be Perl 6 code, please use a Perl 6 style package block like "package Foo { ... }", or "module Foo; ...".');
                        }
                        $*begin_compunit := 0;
                    }
                    { $*IN_DECL := ''; }
                    <.finishpad>
                         # whole rest of file, presumably
                    { $*CURPAD := $*W.pop_lexpad() }
                || <.panic("Too late for semicolon form of $*PKGDECL definition")>
                ]
            || <.panic("Unable to parse $*PKGDECL definition")>
            ]
            { nqp::pop(@*PACKAGES); }
        ] || { $/.CURSOR.malformed($*PKGDECL) }
    }

    token declarator {
        [
        # STD.pm6 uses  here, but we need different 
        # action methods
        | '\\'  <.ws>
            [  || <.sorry("Term definition requires an initializer")> ]
        | 
          [
          ||  <.newpad> ? { $*ATTR_INIT_BLOCK := $*W.pop_lexpad() }
          || ?
          ]
        | '(' ~ ')'  * <.ws> ?
        | 
        | 
        | 
        ]
    }

    rule term:sym { <.end_keyword>  }
    rule term:sym{ <.end_keyword>  }
    rule statement_control:sym   { <.end_keyword>  }
    rule statement_control:sym   { <.end_keyword>  }
    rule statement_control:sym   { <.end_keyword>  }
    rule statement_control:sym   { <.end_keyword>  }

    proto token multi_declarator { <...> }
    token multi_declarator:sym {
         :my $*MULTINESS := 'multi'; <.end_keyword>
        <.ws> [  ||  || <.malformed('multi')> ]
    }
    token multi_declarator:sym {
         :my $*MULTINESS := 'proto'; :my $*IN_PROTO := 1; <.end_keyword>
        <.ws> [  ||  || <.malformed('proto')> ]
    }
    token multi_declarator:sym {
         :my $*MULTINESS := 'only'; <.end_keyword>
        <.ws> [  ||  || <.malformed('only')>]
    }
    token multi_declarator:sym {
        :my $*MULTINESS := '';
        
    }

    proto token scope_declarator { <...> }
    token scope_declarator:sym        {   }
    token scope_declarator:sym       {   }
    token scope_declarator:sym       {
        
        :my $*HAS_SELF := 'partial';
        :my $*ATTR_INIT_BLOCK;
        
    }
    token scope_declarator:sym   {   }
    token scope_declarator:sym      {   }
    token scope_declarator:sym     {   }
    token scope_declarator:sym {
          <.NYI('"supersede"')>
    }

    token scoped($*SCOPE) {
        <.end_keyword>
        :dba('scoped declarator')
        [
        :my $*DOC := $*DECLARATOR_DOCS;
        :my $*DOCEE;
        <.attach_docs>
        <.ws>
        [
        | 
        | 
        | 
        | [<.ws>]+
          {
            if +$ > 1 {
                $/.CURSOR.NYI('Multiple prefix constraints');
            }
            $*OFTYPE := $[0];
          }
          
        | 
        ] <.ws>
        || <.ws> 
        || <.malformed($*SCOPE)>
        ]
    }

    token variable_declarator {
        :my $*IN_DECL := 'variable';
        :my $var;
        
        {
            $var := $.Str;
            $/.CURSOR.add_variable($var);
            $*IN_DECL := '';
        }
        [
            <.unsp>?
            $=[
            | '(' ~ ')' 
                {
                    my $sigil := nqp::substr($var, 0, 1);
                    if $sigil eq '&' {
                        self.typed_sorry('X::Syntax::Reserved',
                            reserved => '() shape syntax in routine declarations',
                            instead => ' (maybe use :() to declare a longname?)'
                        );
                    }
                    elsif $sigil eq '@' {
                        self.typed_sorry('X::Syntax::Reserved',
                            reserved => '() shape syntax in array declarations');
                    }
                    elsif $sigil eq '%' {
                        self.typed_sorry('X::Syntax::Reserved',
                            reserved => '() shape syntax in hash declarations');
                    }
                    else {
                        self.typed_sorry('X::Syntax::Reserved',
                            reserved => '() shape syntax in variable declarations');
                    }
                }
            | :dba('shape definition') '[' ~ ']'  <.NYI: "Shaped variable declarations">
            | :dba('shape definition') '{' ~ '}' 
            |   <.NYI: "Shaped variable declarations">
            ]+
        ]?
        <.ws>
        
        *
        *
    }

    proto token routine_declarator { <...> }
    token routine_declarator:sym
        {  <.end_keyword>  }
    token routine_declarator:sym
        {  <.end_keyword>  }
    token routine_declarator:sym
        {  <.end_keyword>  }
    token routine_declarator:sym
        {  <.end_keyword>  }

    rule routine_def($d) {
        :my $*IN_DECL := $d;
        :my $*METHODTYPE;
        :my $*IMPLICIT := 0;
        :my $*DOC := $*DECLARATOR_DOCS;
        :my $*DOCEE;
        :my $*DECLARAND := $*W.stub_code_object('Sub');
        <.attach_docs>
        ?
        {
            if $ && $[0] -> $cf {
                # It's an (potentially new) operator, circumfix, etc. that we
                # need to tweak into the grammar.
                my $category := $.Str;
                my $opname := $cf
                    ?? $*W.colonpair_nibble_to_str($/, $cf)
                    !! '';
                my $canname := $category ~ ":sym<" ~ $opname ~ ">";
                $/.CURSOR.add_categorical($category, $opname, $canname, $.ast, $*DECLARAND);
            }
        }
        <.newpad>
        [ '('  ')' ]?
        *
        { $*IN_DECL := ''; }
        [
        || 
        || 
        ]
    }

    rule method_def($d) {
        :my $*IN_DECL := $d;
        :my $*METHODTYPE := $d;
        :my $*HAS_SELF := $d eq 'submethod' ?? 'partial' !! 'complete';
        :my $*DOC := $*DECLARATOR_DOCS;
        :my $*DOCEE;
        :my $*DECLARAND := $*W.stub_code_object($d eq 'submethod' ?? 'Submethod' !! 'Method');
        <.attach_docs>
        [
            <.newpad>
            [
            | $=[<[ ! ^ ]>?] [ '('  ')' ]? *
            | '('  ')' *
            | '.':!s
                :dba('subscript signature')
                [
                | '(' ~ ')' 
                | '[' ~ ']' 
                | '{' ~ '}' 
                ]:s
                *
            | 
            ]
            { $*IN_DECL := ''; }
            [
            || 
            || 
            ]
        ] || <.malformed('method')>
    }

    rule macro_def() {
        :my $*IN_DECL := 'macro';
        :my $*IMPLICIT := 0;
        :my $*DOC := $*DECLARATOR_DOCS;
        :my $*DOCEE;
        :my $*DECLARAND := $*W.stub_code_object('Macro');
        <.attach_docs>
        ?
        {
            if $ && $[0] -> $cf {
                # It's an (potentially new) operator, circumfix, etc. that we
                # need to tweak into the grammar.
                my $category := $.Str;
                my $opname := $cf
                    ?? $*W.colonpair_nibble_to_str($/, $cf)
                    !! '';
                my $canname := $category ~ ":sym<" ~ $opname ~ ">";
                $/.CURSOR.add_categorical($category, $opname, $canname, $.ast, $*DECLARAND);
            }
        }
        <.newpad>
        [ '('  ')' ]?
        *
        { $*IN_DECL := ''; }
        [
        || 
        || 
        ]
    }
    
    token onlystar {
        :my $*CURPAD;
        
        '{' <.ws> '*' <.ws> '}'
        
        <.finishpad>
        { $*CURPAD := $*W.pop_lexpad() }
    }

    ###########################
    # Captures and Signatures #
    ###########################

    token capterm {
        '\\'
        [
        | '(' ? ')'
        |  
        | {} <.panic: "You can't backslash that">
        ]
    }

    rule capture {
        
    }

    rule param_sep {
        '' $=[','|':'|';;'|';'] { @*seps.push($) }
    }

    # XXX Not really implemented yet.
    token multisig {
        :my $*SCOPE := 'my';
        
    }

    token fakesignature {
        <.newpad>
        
    }

    token signature {
        :my $*IN_DECL := 'sig';
        :my $*zone := 'posreq';
        :my @*seps := nqp::list();
        <.ws>
        [
        | ' | ')' | ']' | '{' | ':'\s | ';;' >
        | [  || <.malformed('parameter')> ]
        ]+ % 
        <.ws>
        { $*IN_DECL := ''; }
        [ '-->' <.ws>  || '-->' <.ws>  ]?
        { $*LEFTSIGIL := '@'; }
    }

    token parameter {
        # We'll collect parameter information into a hash, then use it to
        # build up the parameter object in the action method
        :my %*PARAM_INFO;
        [
        | +
            [
            | $=['**'|'*'] 
            | $=['\\'|'|']  { nqp::printfh(nqp::getstderr(), "Obsolete use of | or \\ with sigil on param { $ }\n") }
            | $=['\\'|'|'] ?

            | [  |  ] $=['?'|'!'|]
            | 
            ]
        | $=['**'|'*'] 
        | $=['\\'|'|']  { nqp::printfh(nqp::getstderr, "Obsolete use of | or \\ with sigil on param { $ }\n") }
        | $=['\\'|'|'] ?
        | [  |  ] $=['?'|'!'|]
        | 
            {
                my $name := $*W.dissect_longname($);
                $*W.throw($/, ['X', 'Parameter', 'InvalidType'],
                    :typename($name.name),
                    :suggestions($*W.suggest_typename($name.name)));
            }
        ]
        <.ws>
        *
        *
        **0..1

        # enforce zone constraints
        {
            my $kind :=
                $                      ?? '*' !!
                $ eq '?' || $ ?? '?' !!
                $ eq '!'                     ?? '!' !!
                $ ne '' && $ ne '\\'  ?? '*' !!
                                                       '!';
            my $name := %*PARAM_INFO // '';
            if $kind eq '!' {
                if $*zone eq 'posopt' {
                    $/.CURSOR.typed_panic('X::Parameter::WrongOrder', misplaced => 'required', after => 'optional', parameter => $name);
                }
                elsif $*zone eq 'var' {
                    $/.CURSOR.typed_panic('X::Parameter::WrongOrder', misplaced => 'required', after => 'variadic', parameter => $name);
                }
            }
            elsif $kind eq '?' {
                if $*zone  eq 'posreq' {
                        $*zone := 'posopt';
                }
                elsif $*zone eq  'var' {
                    $/.CURSOR.typed_panic('X::Parameter::WrongOrder', misplaced => 'optional positional', after => 'variadic', parameter => $name);
                }
            }
            elsif $kind eq '*' {
                $*zone := 'var';
            }
        }
    }

    token param_var {
        :dba('formal parameter')
        [
        | '[' ~ ']' 
        | '(' ~ ')' 
        |  ?
          [
          || 
          ||  { $*W.throw($/, 'X::Syntax::Variable::Numeric', what => 'parameter') }
          || $=[<[/!]>]
          ]?
        ]
    }

    token named_param {
        :my $*GOAL := ')';
        :dba('named parameter')
        ':'
        [
        |  '(' <.ws>
            [  |  <.ws> ]
            [ ')' || <.panic: 'Unable to parse named parameter; couldnt find right parenthesis'> ]
        | 
        ]
    }

    rule default_value {
        :my $*IN_DECL := '';
        '=' 
    }

    token type_constraint {
        :my $*IN_DECL := '';
        [
        | 
        | 
        | where <.ws> 
        ]
        <.ws>
    }

    rule post_constraint {
        :my $*IN_DECL := '';
        :dba('constraint')
        [
        | '[' ~ ']' 
        | '(' ~ ')' 
        | where 
        ]
    }

    proto token regex_declarator { <...> }
    token regex_declarator:sym {
        
        :my %*RX;
        :my $*INTERPOLATE := 1;
        :my $*METHODTYPE := 'rule';
        :my $*IN_DECL    := 'rule';
        {
            %*RX := 1;
            %*RX := 1;
        }
        
    }
    token regex_declarator:sym {
        
        :my %*RX;
        :my $*INTERPOLATE := 1;
        :my $*METHODTYPE := 'token';
        :my $*IN_DECL    := 'token';
        {
            %*RX := 1;
        }
        
    }
    token regex_declarator:sym {
        
        :my %*RX;
        :my $*INTERPOLATE := 1;
        :my $*METHODTYPE := 'regex';
        :my $*IN_DECL    := 'regex';
        
    }

    rule regex_def {
        <.end_keyword>
        :my $*CURPAD;
        :my $*HAS_SELF := 'complete';
        :my $*DECLARAND := $*W.stub_code_object('Regex');
        [
          ?
          { if $ { %*RX := ~$.ast } }
          { $*IN_DECL := '' }
           <.newpad>
          [ [ ':'?'('  ')' ] |  ]*
          '{'
          [
          | ['*'|'<...>'|'<*>']  $={1}
          |  ?? %*LANG !! %*LANG, '{', '}'))>
          ]
          '}'
          { $*CURPAD := $*W.pop_lexpad() }
        ] || <.malformed('regex')>
    }

    proto token type_declarator { <...> }

    token type_declarator:sym {
        :my $*IN_DECL := 'enum';
        :my $*DECLARAND;
          <.end_keyword> <.ws>
        [
        | 
            {
                my $longname := $*W.dissect_longname($);
                my @name := $longname.type_name_parts('enum name', :decl(1));
                if $*W.already_declared($*SCOPE, $*PACKAGE, $*W.cur_lexpad(), @name) {
                    $*W.throw($/, ['X', 'Redeclaration'],
                        symbol => $longname.name(),
                    );
                }
            }
        | 
        | 
        ]
        { $*IN_DECL := ''; }
        <.ws>
        *
          <.ws>
    }

    rule type_declarator:sym {
        <.end_keyword> :my $*IN_DECL := 'subset';
        [
            [
                [
                    
                    {
                        my $longname := $*W.dissect_longname($);
                        my @name := $longname.type_name_parts('subset name', :decl(1));
                        if $*W.already_declared($*SCOPE, $*PACKAGE, $*W.cur_lexpad(), @name) {
                            $*W.throw($/, ['X', 'Redeclaration'],
                                symbol => $longname.name(),
                            );
                        }
                    }
                ]?
                { $*IN_DECL := '' }
                *
                [ where  ]?
            ]
            || <.malformed('subset')>
        ]
    }

    token type_declarator:sym {
        :my $*IN_DECL := 'constant';
         <.end_keyword> <.ws>

        [
        | '\\'? 
        | 
        | 
        ]
        { $*IN_DECL := ''; }
        <.ws>

        *

        { $*W.push_lexpad($/) }
        [
        || 
        || <.missing: "initializer on constant declaration">
        ]
    }

    proto token initializer { <...> }
    token initializer:sym<=> {
        
        [
            <.ws>
            [
            ||  
            || 
            ]
            || <.malformed: 'initializer'>
        ]
    }
    token initializer:sym<:=> {
         [ <.ws>  || <.malformed: 'binding'> ]
    }
    token initializer:sym<::=> {
         [ <.ws>  || <.malformed: 'binding'> ]
    }
    token initializer:sym<.=> {
         [ <.ws>  || <.malformed: 'mutator method call'> ]
    }

    rule trait {
        :my $*IN_DECL := '';
        [
        | 
        | 
        ]
    }

    proto rule trait_mod { <...> }
    rule trait_mod:sym      {  **0..1 }
    rule trait_mod:sym   {   }
    rule trait_mod:sym    {   }
    rule trait_mod:sym    {    }
    rule trait_mod:sym      {   }
    rule trait_mod:sym      {   }
    rule trait_mod:sym {   }
    rule trait_mod:sym {   }


    ## Terms

    proto token term { <...> }

    token term:sym {
         <.end_keyword>
        {
            $*HAS_SELF || self.typed_sorry('X::Syntax::Self::WithoutObject')
        }
    }

    token term:sym {  <.end_keyword> }

    token term:sym
  {  >>  }
    token infix:sym  {  >>  }
    token infix:sym  {  >>  }
    token infix:sym<%>    {    }
    token infix:sym  {  >>  }
    token infix:sym<%%>   {   ')> }
    token infix:sym<+&>   {    }
    token infix:sym<~&>   {    }
    token infix:sym   {    }
    token infix:sym«+<»   {  [  ||  ||  ]  }
    token infix:sym«+>»   {  [  || >'> || ]> ]  }
    token infix:sym«~<»   {  [  ||  ||  ]  }
    token infix:sym«~>»   {  [  || >'> || ]> ]  }

    token infix:sym«<<» {    <.sorryobs('<< to do left shift', '+< or ~<')>  }

    token infix:sym«>>» {    <.sorryobs('>> to do right shift', '+> or ~>')>  }

    token infix:sym<+>    {    }
    token infix:sym<->    {
       # We want to match in '$a >>->> $b' but not 'if $a -> { ... }'.
         [>'> || ]>]
        
    }
    token infix:sym<+|>   {    }
    token infix:sym<+^>   {    }
    token infix:sym<~|>   {    }
    token infix:sym<~^>   {    }
    token infix:sym   {    }
    token infix:sym   {    }

    token infix:sym    {  >>  }
    token infix:sym    {  >>  }

    token infix:sym<~>    {    }
    token infix:sym<.>    {  <[\]\)\},:\s\$"']>  <.obs('. to concatenate strings', '~')> }

    token infix:sym<&>   {                               }
    token infix:sym<(&)> {   >   }
    token infix:sym«∩»   {   >   }
    token infix:sym<(.)> {   >   }
    token infix:sym«⊍»   {   >   }

    token infix:sym<|>    {   }
    token infix:sym<^>    {   }
    token infix:sym<(|)>  {   >   }
    token infix:sym«∪»    {   >   }
    token infix:sym<(^)>  {   >   }
    token infix:sym«⊖»    {   >   }
    token infix:sym<(+)>  {   >   }
    token infix:sym«⊎»    {   >   }
    token infix:sym<(-)>  {   >   }
    token infix:sym«∖»    {   >   }

    token prefix:sym  {  \s+ '>  { $*W.give_cur_block_let($/) } }
    token prefix:sym {  \s+ '>  { $*W.give_cur_block_temp($/) } }

    token infix:sym«==»   {    }
    token infix:sym«!=»   {    }
    token infix:sym«<=»   {    }
    token infix:sym«>=»   {    }
    token infix:sym«<»    {    }
    token infix:sym«>»    {    }
    token infix:sym«eq»   {  >>  }
    token infix:sym«ne»   {  >>  }
    token infix:sym«le»   {  >>  }
    token infix:sym«ge»   {  >>  }
    token infix:sym«lt»   {  >>  }
    token infix:sym«gt»   {  >>  }
    token infix:sym«=:=»  {    }
    token infix:sym<===>  {    }
    token infix:sym    {  >>  }
    token infix:sym {  >>  }
    token infix:sym  {  >>  }
    token infix:sym<~~>   {    }
    token infix:sym  {    }
    token infix:sym<(elem)> {   }
    token infix:sym«∈»      {   }
    token infix:sym«∉»      {   }
    token infix:sym<(cont)> {   }
    token infix:sym«∋»      {   }
    token infix:sym«∌»      {   }
    token infix:sym«(<)»    {   }
    token infix:sym«⊂»      {   }
    token infix:sym«⊄»      {   }
    token infix:sym«(>)»    {   }
    token infix:sym«⊃»      {   }
    token infix:sym«⊅»      {   }
    token infix:sym«(<=)»   {   }
    token infix:sym«⊆»      {   }
    token infix:sym«⊈»      {   }
    token infix:sym«(>=)»   {   }
    token infix:sym«⊇»      {   }
    token infix:sym«⊉»      {   }
    token infix:sym«(<+)»   {   }
    token infix:sym«≼»      {   }
    token infix:sym«(>+)»   {   }
    token infix:sym«≽»      {   }

    token dumbsmart {
        # should be
        # 'Bool::'? True && <.longname>
        # once && in regexes is implemented
        |  ] >  <.worry("Smartmatch against True always matches; if you mean to test the topic for truthiness, use :so or *.so or ?* instead")>
        |  ] > <.worry("Smartmatch against False always fails; if you mean to test the topic for truthiness, use :!so or *.not or !* instead")>
    }

    token infix:sym<&&>   {   ')> }

    token infix:sym<||>   {   , :pasttype')> }
    token infix:sym<^^>   {   ')> }
    token infix:sym   {   , :pasttype')> }
    token infix:sym  {  >>  }
    token infix:sym  {  >>  }

    token infix:sym {
        :my $*GOAL := '!!';
        '??'
        <.ws>
        
        [ '!!'
        || > <.panic: "Please use !! rather than ::">
        || > <.panic: "Please use !! rather than :">
        ||  '!!' <.sorry("Bogus code found before the !!")> <.panic("Confused")>
        || <.sorry("Found ?? but no !!")> <.panic("Confused")>
        ]
        , :pasttype')>
    }

    token infix_prefix_meta_operator:sym {
          {} [  || <.panic: "Negation metaoperator not followed by valid infix"> ]
        [
        || .Str eq '=' }> 
        ||  }> )>
        || <.panic("Cannot negate " ~ $.Str ~ " because it is not iffy enough")>
        ]
    }
    token infix_prefix_meta_operator:sym {   {} )> }
    token infix_prefix_meta_operator:sym {   {} )> }
    token infix_prefix_meta_operator:sym {    }
    token infix_prefix_meta_operator:sym {    }
    token infix:sym {  >>  }

    token infix:sym<:=> {
          
    }

    token infix:sym<::=> {
          
    }

    token infix:sym<.=> {  ')> }

    # Should probably have  to agree w/spec, but after NYI.
    # Modified infix != below instead to prevent misparse
    token infix_postfix_meta_operator:sym<=> { '='  }

    token infix:sym«=>» {   }

    token prefix:sym {  >>  }
    token prefix:sym  {  >>  }

    token infix:sym<,>    {
          ')>
        # TODO: should be <.worry>, not <.panic>
        [  <.panic: "Comma found before apparent series operator; please remove comma (or put parens\n    around the ... listop, or use 'fail' instead of ...)"> ]?
    }

    token infix:sym    {   >    }
    token infix:sym    {   >    }

    token infix:sym<...>  {    }
    token infix:sym<...^> {    }
    # token term:sym<...>   {  **0..1  }

    token infix:sym    {  {}  *?':'> <.obs('?: for the conditional operator', '??!!')>  }

    token infix:sym {   }
    token infix:sym<^ff> {   }
    token infix:sym {   }
    token infix:sym<^ff^> {   }
    
    token infix:sym {   }
    token infix:sym<^fff> {   }
    token infix:sym {   }
    token infix:sym<^fff^> {   }

    token infix:sym<=> {
        
        [
        ||  
        || 
        ]
    }

    token infix:sym  {  >> ')> }
    token infix:sym {  >> ')> }

    token infix:sym   {  >> , :pasttype')> }
    token infix:sym  {  >> ')> }
    token infix:sym {  >> , :pasttype')> }

    token infix:sym«<==»  {   }
    token infix:sym«==>»  {   }
    token infix:sym«<<==» {   }
    token infix:sym«==>>» {   }

    token infix:sym<..>   {  [  <.panic: "Please use ..* for indefinite range">]?  }
    token infix:sym<^..>  {   }
    token infix:sym<..^>  {   }
    token infix:sym<^..^> {   }

    token infix:sym  {  >>  }
    token infix:sym  {  >>  }
    token infix:sym«<=>»  {   }

    token infix:sym  {  >>  }
    token infix:sym {  >>  }

    token infix:sym {  \s <.obs('!~ to do negated pattern matching', '!~~')>  }
    token infix:sym<=~> {  <.obs('=~ to do pattern matching', '~~')>  }

    method add_mystery($token, $pos, $ctx) {
        my $name := ~$token;
        unless $name eq '' || $*W.is_lexical('&' ~ $name) || $*W.is_lexical($name) {
            my $lex := $*W.cur_lexpad();
            my $key := $name ~ '-' ~ $lex.cuid;
            if nqp::existskey(%*MYSTERY, $key) {
                nqp::push(%*MYSTERY{$key}, $pos);
            }
            else {
                %*MYSTERY{$key} := nqp::hash(
                    'lex', $lex,
                    'name', $name,
                    'ctx', $ctx,
                    'pos', [$pos]);
            }
        }
        self;
    }
    
    method explain_mystery() {
        my %post_types;
        my %unk_types;
        my %unk_routines;
        
        sub push_lines(@target, @pos) {
            for @pos {
                nqp::push(@target, HLL::Compiler.lineof(self.orig, $_, :cache(1)));
            }
        }
        
        my %routine_suggestion := hash();
        my %type_suggestion := hash();
        
        for %*MYSTERY {
            my %sym  := $_.value;
            my $name := %sym;
            my $decl := $*W.is_lexically_visible($name, %sym);
            if $decl == 2 {
                # types may not be post-declared
                %post_types{$name} := [] unless %post_types{$name};
                push_lines(%post_types{$name}, %sym);
                next;
            }

            next if $decl == 1;
            next if $*W.is_lexically_visible('&' ~ $name, %sym);

            # just a guess, but good enough to improve error reporting
            if $_ lt 'a' {
                %unk_types{$name} := [] unless %unk_types{$name};
                my @suggs := $*W.suggest_typename($name);
                %type_suggestion{$name} := @suggs;
                push_lines(%unk_types{$name}, %sym);
            }
            else {
                %unk_routines{$name} := [] unless %unk_routines{$name};
                my @suggs := $*W.suggest_routines($name);
                %routine_suggestion{$name} := @suggs;
                push_lines(%unk_routines{$name}, %sym);
            }
        }
        
        if %post_types || %unk_types || %unk_routines {
            self.typed_sorry('X::Undeclared::Symbols',
                :%post_types, :%unk_types, :%unk_routines,
                :%routine_suggestion, :%type_suggestion);
        }
        
        self;        
    }
    
    method add_variable($name) {
        my $categorical := $name ~~ /^'&'((\w+)':<'\s*(\S+?)\s*'>')$/;
        if $categorical {
            self.add_categorical(~$categorical[0][0], ~$categorical[0][1], ~$categorical[0], $name);
        }
    }

    # Called when we add a new choice to an existing syntactic category, for
    # example new infix operators add to the infix category. Augments the
    # grammar as needed.
    method add_categorical($category, $opname, $canname, $subname, $declarand?) {
        my $self := self;
        
        # Ensure it's not a null name.
        if $opname eq '' {
            self.typed_panic('X::Syntax::Extension::Null');
        }
        
        # If we already have the required operator in the grammar, just return.
        if nqp::can(self, $canname) {
            return 1;
        }

        # Work out what default precedence we want, or if it's more special than
        # just an operator.
        my $prec;
        my $is_oper;
        my $is_term := 0;
        if $category eq 'infix' {
            $prec := '%additive';
            $is_oper := 1;
        }
        elsif $category eq 'prefix' {
            $prec := '%symbolic_unary';
            $is_oper := 1;
        }
        elsif $category eq 'postfix' {
            $prec := '%autoincrement';
            $is_oper := 1;
        }
        elsif $category eq 'circumfix' {
            $is_oper := 0;
        }
        elsif $category eq 'trait_mod' {
            return 0;
        }
        elsif $category eq 'term' {
            $is_term := 1;
        }
        elsif $category eq 'METAOP_TEST_ASSIGN' {
            return 0;
        }
        else {
            self.typed_panic('X::Syntax::Extension::Category', :$category);
        }

        if $is_term {
            my role Term[$meth_name, $op] {
                token ::($meth_name) { $=[$op] }
            }
            self.HOW.mixin(self, Term.HOW.curry(Term, $canname, $opname));
        }
        # Mix an appropraite role into the grammar for parsing the new op.
        elsif $is_oper {
            my role Oper[$meth_name, $op, $precedence, $declarand] {
                token ::($meth_name) { $=[$op]  }
            }
            self.HOW.mixin(self, Oper.HOW.curry(Oper, $canname, $opname, $prec, $declarand));
        }
        else {
            # Find opener and closer and parse an EXPR between them.
            # XXX One day semilist would be nice, but right now that
            # runs us into fun with terminators.
            my @parts := nqp::split(' ', $opname);
            if +@parts != 2 {
                nqp::die("Unable to find starter and stopper from '$opname'");
            }
            my role Circumfix[$meth_name, $starter, $stopper] {
                token ::($meth_name) {
                    :my $*GOAL := $stopper;
                    :my $stub := %*LANG
 := nqp::getlex('$¢').unbalanced($stopper);
                    $starter ~ $stopper 
                }
            }
            self.HOW.mixin(self, Circumfix.HOW.curry(Circumfix, $canname, @parts[0], @parts[1]));
        }

        # This also becomes the current MAIN. Also place it in %?LANG.
        %*LANG
 := self.WHAT;
        $*W.install_lexical_symbol($*W.cur_lexpad(), '%?LANG', $*W.p6ize_recursive(%*LANG));
        
        # Declarand should get precedence traits.
        if $is_oper && nqp::isconcrete($declarand) {
            my $base_prec := self.O($prec).MATCH;
            $*W.apply_trait(self.MATCH, '&trait_mod:', $declarand,
                :prec(nqp::hash('prec', $base_prec)));
        }

        # May also need to add to the actions.
        if $category eq 'circumfix' {
            my role CircumfixAction[$meth, $subname] {
                method ::($meth)($/) {
                    make QAST::Op.new(
                        :op('call'), :name('&' ~ $subname),
                        $.ast
                    );
                }
            };
            %*LANG := $*ACTIONS.HOW.mixin($*ACTIONS,
                CircumfixAction.HOW.curry(CircumfixAction, $canname, $subname));
        }
        elsif $is_term {
            my role TermAction[$meth, $subname] {
                method ::($meth)($/) {
                    make QAST::Op.new(
                        :op('call'), :name('&' ~ $subname),
                    );
                }
            };
            my role TermActionConstant[$meth, $name] {
                method ::($meth)($/) {
                    make QAST::Var.new( :$name, :scope('lexical') );
                }
            };
            %*LANG := $*ACTIONS.HOW.mixin($*ACTIONS,
                $*IN_DECL eq 'constant'
                    ?? TermAction.HOW.curry(TermActionConstant, $canname, $subname)
                    !! TermAction.HOW.curry(TermAction, $canname, $subname));
        }

        return 1;
    }
    
    method genO($default, $declarand) {
        my $desc := $default;
        if nqp::can($declarand, 'prec') {
            my %extras := $declarand.prec.FLATTENABLE_HASH;
            for %extras {
                $desc := "$desc, :" ~ $_.key ~ "<" ~ $_.value ~ ">";
            }
        }
        self.O($desc)
    }
}

grammar Perl6::QGrammar is HLL::Grammar does STD {

    method throw_unrecog_backslash_seq ($sequence) {
        self.typed_sorry('X::Backslash::UnrecognizedSequence', :$sequence);
    }

    proto token escape {*}
    proto token backslash {*}

    role b1 {
        token escape:sym<\\> {  {}  }
        token backslash:sym {   }
        token backslash:sym<\\> {  }
        token backslash:sym {  }
        token backslash:sym {  }
        token backslash:sym {  }
        token backslash:sym {   }
        token backslash:sym {  }
        token backslash:sym {  }
        token backslash:sym {  }
        token backslash:sym { :dba('octal character')  [  | '[' ~ ']'  ] }
        token backslash:sym {  }
        token backslash:sym {  }
        token backslash:sym { :dba('hex character')  [  | '[' ~ ']'  ] }
        token backslash:sym<0> {  }
    }

    role b0 {
        token escape:sym<\\> {  }
    }

    role c1 {
        token escape:sym<{ }> {   }
    }

    role c0 {
        token escape:sym<{ }> {  }
    }

    role s1 {
        token escape:sym<$> {
            :my $*QSIGIL := '$';
            
            [  {  }
    }

    role a1 {
        token escape:sym<@> {
            :my $*QSIGIL := '@';
            
            
            
             {
             
        }
        token escape:sym<" "> {
             
        }
        token escape:sym {
             
        }
    }

    role ww0 {
        method postprocessor () { 'null' }
    }

    role x1 {
        method postprocessor () { 'run' }
    }

    role x0 {
        method postprocessor () { 'null' }
    }
    
    role to[$herelang] {
        method herelang() { $herelang }
        method postprocessor () { 'heredoc' }
    }

    role q {
        token stopper { \' }

        token escape:sym<\\> {   }

        token backslash:sym {   }
        token backslash:sym<\\> {  }
        token backslash:sym {  }

        token backslash:sym { {} . }

        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 { {} (\w) { self.throw_unrecog_backslash_seq: $/[0].Str } }
        token backslash:sym { \W }

        method tweak_q($v) { self.panic("Too late for :q") }
        method tweak_qq($v) { self.panic("Too late for :qq") }
    }
    
    token nibbler {
        :my @*nibbles;
        <.do_nibbling>
    }
    
    token do_nibbling {
        :my $from := self.pos;
        :my $to   := $from;
        [
            
            [
            ||   
                {
                    my $c := $/.CURSOR;
                    $to   := $[-1].from;
                    if $from != $to {
                        nqp::push(@*nibbles, nqp::substr($c.orig, $from, $to - $from));
                    }

                    nqp::push(@*nibbles, $[-1].Str);
                    nqp::push(@*nibbles, $[-1]);
                    nqp::push(@*nibbles, $[-1].Str);

                    $from := $to := $c.pos;
                }
            || 
                {
                    my $c := $/.CURSOR;
                    $to   := $[-1].from;
                    if $from != $to {
                        nqp::push(@*nibbles, nqp::substr($c.orig, $from, $to - $from));
                    }

                    nqp::push(@*nibbles, $[-1]);

                    $from := $to := $c.pos;
                }
            || .
            ]
        ]*
        {
            my $c := $/.CURSOR;
            $to   := $c.pos;
            if $from != $to || !@*nibbles {
                nqp::push(@*nibbles, nqp::substr($c.orig, $from, $to - $from));
            }
        }
    }
    
    role cc {
        token stopper { \' }

        method ccstate ($s) {
            if $*CCSTATE eq '..' {
                $*CCSTATE := '';
            }
            else {
                $*CCSTATE := $s;
            }
            self;
        }

        # (must not allow anything to match . in nibbler or we'll lose track of state)
        token escape:ws { \s+ [  <.ws> ]? }
        token escape:sym<#> { '#' <.panic: "Please backslash # for literal char or put whitespace in front for comment"> }
        token escape:sym<\\> {   <.ccstate('\\' ~ $.Str)> }
        token escape:sym<..> { 
            [
            ||  <.sorry("Range missing start character on the left")>
            ||   \S >
            || <.sorry("Range missing stop character on the right")>
            ]
            { $*CCSTATE := '..'; }
        }

        token escape:sym<-> {
            '-'  \s*  \S 
            <.obs('- as character range','.. (or \\- if you mean a literal hyphen)')>
        }
        token escape:ch { $ = [\S] <.ccstate($.Str)> }

        token backslash:stopper {  }
        token backslash:a { :i  }
        token backslash:b { :i  }
        token backslash:c { :i   }
        token backslash:d { :i  { $*CCSTATE := '' } }
        token backslash:e { :i  }
        token backslash:f { :i  }
        token backslash:h { :i  { $*CCSTATE := '' } }
        token backslash:n { :i  }
        token backslash:o { :i :dba('octal character')  [  | '[' ~ ']'  ] }
        token backslash:r { :i  }
        token backslash:s { :i  { $*CCSTATE := '' } }
        token backslash:t { :i  }
        token backslash:v { :i  { $*CCSTATE := '' } }
        token backslash:w { :i  { $*CCSTATE := '' } }
        token backslash:x { :i :dba('hex character')  [  | '[' ~ ']'  ] }
        token backslash:sym<0> {  }

        # keep random backslashes like qq does
        token backslash:misc { {}
            [
            | $=(\W)
            | $=(\w) <.sorry("Unrecognized backslash sequence: '\\" ~ $ ~ "'")>
            ] 
        }
        multi method tweak_q($v) { self.panic("Too late for :q") }
        multi method tweak_qq($v) { self.panic("Too late for :qq") }
        multi method tweak_cc($v) { self.panic("Too late for :cc") }
    }

    method truly($bool, $opt) {
        self.sorry("Cannot negate $opt adverb") unless $bool;
        self;
    }
    
    method tweak_q($v)          { self.truly($v, ':q'); self.HOW.mixin(self, Perl6::QGrammar::q) }
    method tweak_single($v)     { self.tweak_q($v) }
    method tweak_qq($v)         { self.truly($v, ':qq'); self.HOW.mixin(self, Perl6::QGrammar::qq); }
    method tweak_double($v)     { self.tweak_qq($v) }

    method tweak_b($v)          { self.HOW.mixin(self, $v ?? b1 !! b0) }
    method tweak_backslash($v)  { self.tweak_b($v) }
    method tweak_s($v)          { self.HOW.mixin(self, $v ?? s1 !! s0) }
    method tweak_scalar($v)     { self.tweak_s($v) }
    method tweak_a($v)          { self.HOW.mixin(self, $v ?? a1 !! a0) }
    method tweak_array($v)      { self.tweak_a($v) }
    method tweak_h($v)          { self.HOW.mixin(self, $v ?? h1 !! h0) }
    method tweak_hash($v)       { self.tweak_h($v) }
    method tweak_f($v)          { self.HOW.mixin(self, $v ?? f1 !! f0) }
    method tweak_function($v)   { self.tweak_f($v) }
    method tweak_c($v)          { self.HOW.mixin(self, $v ?? c1 !! c0) }
    method tweak_closure($v)    { self.tweak_c($v) }

    method tweak_x($v)          { self.HOW.mixin(self, $v ?? x1 !! x0) }
    method tweak_exec($v)       { self.tweak_x($v) }
    method tweak_w($v)          { self.HOW.mixin(self, $v ?? w1 !! w0) }
    method tweak_words($v)      { self.tweak_w($v) }
    method tweak_ww($v)         { self.HOW.mixin(self, $v ?? ww1 !! ww0) }
    method tweak_quotewords($v) { self.tweak_ww($v) }

    method tweak_cc($v)         { self.truly($v, ':cc'); self.HOW.mixin(self, cc); }

    method tweak_to($v) {
        self.truly($v, ':to');
        %*LANG.HOW.mixin(%*LANG, to.HOW.curry(to, self))
    }
    method tweak_heredoc($v)    { self.tweak_to($v) }

    method tweak_regex($v) {
        self.truly($v, ':regex');
        return %*LANG;
    }
}

grammar Perl6::RegexGrammar is QRegex::P6Regex::Grammar does STD {
    method throw_unrecognized_metachar ($metachar) {
        self.typed_sorry('X::Syntax::Regex::UnrecognizedMetachar', :$metachar);
    }
    method throw_null_pattern() {
        self.typed_sorry('X::Syntax::Regex::NullRegex');
    }

    token normspace {  <.LANG('MAIN', 'ws')> }

    token rxstopper {  }

    token metachar:sym<:my> {
        ':'   <.ws> ';'
    }

    token metachar:sym<{ }> {
         
    }

    token metachar:sym {
         $=[ | \W | '(']>
        
        [
        || $ = ( \s* '=' \s*  )
           { self.check_variable($) unless $ eq '<' }
        || { self.check_variable($) }
           [ > <.worry: "Apparent subscript will be treated as regex"> ]?
        ]
        <.SIGOK>
    }

    token metachar:sym {
          # (note required whitespace)
        '<' , "<", ">", ['q', 'w']))> '>'
        <.SIGOK>
    }
    
    token metachar:sym<'> {   <.SIGOK> }

    token metachar:sym<"> {   <.SIGOK> }
    
    token assertion:sym<{ }> {
         
    }

    token assertion:sym {
        $=[ <[?!]>  ] 
    }

    token assertion:sym {
         ')>
    }
    
    token assertion:sym<~~> {
        
        [ ]> | $=[\d+] |  ]
    }

    token codeblock {
        
    }

    token arglist {
        :my $*IN_REGEX_ASSERTION := 1;
        
    }
    
    token assertion:sym {
        
            [
            | ]>
            | '=' 
            | ':' 
            | '('  ')'
            | <.normspace> 
            ]?
    }
}

grammar Perl6::P5RegexGrammar is QRegex::P5Regex::Grammar does STD {
    token rxstopper {  }
    
    token p5metachar:sym<(?{ })> {
        '(?'   ')'
    }
    
    token p5metachar:sym<(??{ })> {
        '(??'   ')'
    }

    token p5metachar:sym {
         
    }

    token codeblock {
        
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Archetypes.nqp0000664000175000017500000000405712224263172021127 0ustar  moritzmoritzuse Perl6::Ops;

# Provides various properties of the type of type a given meta-object
# implements. This are used in various ways by the compiler and meta-model
# to do correct code generation or to detect illegal use of types in
# contexts with certain requirements.
class Perl6::Metamodel::Archetypes {
    # Can this serve as a nominal type? Implies memoizability
    # amongst other things.
    has $!nominal;
    
    # If it's not nominal, does it know how to provide a nominal
    # type part of itself?
    has $!nominalizable;
    
    # Can this be inherited from?
    has $!inheritable;
    
    # If it's not inheritable, does it know how to produce something
    # that is?
    has $!inheritalizable;
    
    # Can this be composed (either with flattening composition, or used
    # as a mixin)?
    has $!composable;
    
    # If it's not composable, does it know how to produce something
    # that is?
    has $!composalizable;
    
    # Is it generic, in the sense of "we don't know what type this is
    # yet"? Note that a parametric type would not be generic - even if
    # it has missing parts, it defines a type. A type variable is generic,
    # however. This tends to cause various kinds of late (or at least
    # delayed) reification. In some contexts, an unresolved generic is
    # fatal.
    has $!generic;
    
    # Is it a parametric type - that is, it has missing bits that need
    # to be filled out before it can be used? Unlike generic, something
    # that is parametric does define a type - though we may need the gaps
    # filled it before it's useful in some way.
    has $!parametric;
    
    # Are we allowed to augment the type?
    has $!augmentable;
    
    method nominal() { $!nominal }
    method nominalizable() { $!nominalizable }
    method inheritable() { $!inheritable }
    method inheritalizable() { $!inheritalizable }
    method composable() { $!composable }
    method composalizable() { $!composalizable }
    method generic() { $!generic }
    method parametric() { $!parametric }
    method augmentable() { $!augmentable }
}
rakudo-2013.12/src/Perl6/Metamodel/ArrayType.nqp0000664000175000017500000000072712224263172020740 0ustar  moritzmoritz# Handles type declarations that really map down to array types of some kind,
# and thus should be composed as an array-ish representation.
role Perl6::Metamodel::ArrayType {
    has int $!is_array_type;
    has $!array_type;
    
    method is_array_type($obj) {
        $!is_array_type
    }
    
    method array_type($obj) {
        $!array_type
    }
    
    method set_array_type($obj, $type) {
        $!is_array_type := 1;
        $!array_type := $type;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/AttributeContainer.nqp0000664000175000017500000000462012224263172022622 0ustar  moritzmoritzrole Perl6::Metamodel::AttributeContainer {
    # Attributes list.
    has @!attributes;
    has %!attribute_lookup;
    
    # Do we default them to rw?
    has $!attr_rw_by_default;

    # Adds an attribute.
    method add_attribute($obj, $meta_attr) {
        my $name := $meta_attr.name;
        if nqp::existskey(%!attribute_lookup, $name) {
            nqp::die("Package '" ~ self.name($obj) ~
                "' already has an attribute named '$name'");
        }
        @!attributes[+@!attributes] := $meta_attr;
        %!attribute_lookup{$name}   := $meta_attr;
    }
    
    # Composes all attributes.
    method compose_attributes($obj) {
        my %seen_with_accessor;
        my %meths := self.method_table($obj);
        my %orig_meths;
        for %meths {
            %orig_meths{$_.key} := 1;
        }
        for @!attributes {
            if $!attr_rw_by_default { $_.default_to_rw() }
            if $_.has_accessor() {
                my $acc_name := nqp::substr($_.name, 2);
                nqp::die("Two or more attributes declared that both want an accessor method '$acc_name'")
                    if %seen_with_accessor{$acc_name} && !nqp::existskey(%orig_meths, $acc_name);
                %seen_with_accessor{$acc_name} := 1;
            }
            $_.compose($obj);
        }
    }
    
    # Makes setting the type represented by the meta-object rw mean that its
    # attributes are rw by default.
    method set_rw($obj) {
        $!attr_rw_by_default := 1;
    }
    
    # Is this type's attributes rw by default?
    method rw($obj) {
        $!attr_rw_by_default
    }
    
    # Gets the attribute meta-object for an attribute if it exists.
    # This is called by the parser so it should only return attributes
    # that are visible inside the current package.
    method get_attribute_for_usage($obj, $name) {
        unless nqp::existskey(%!attribute_lookup, $name) {
            nqp::die("No $name attribute in " ~ self.name($obj))
        }
        %!attribute_lookup{$name}
    }

    # Introspect attributes.
    method attributes($obj, :$local, :$excl, :$all) {
        my @attrs;

        for @!attributes {
            @attrs.push($_);
        }

        unless $local {
            for self.parents($obj, :excl($excl), :all($all)) {
                for $_.HOW.attributes($_, :local(1)) {
                    @attrs.push($_);
                }
            }
        }

        @attrs
    }
}
rakudo-2013.12/src/Perl6/Metamodel/BaseType.nqp0000664000175000017500000000177212224263172020535 0ustar  moritzmoritz# Implemented by meta-objects that don't do inheritance per se,
# but want to base themselves on another type and mostly behave
# like they support it.
role Perl6::Metamodel::BaseType {
    has $!base_type;
    has $!base_type_set;
    has @!mro;
    
    method set_base_type($obj, $base_type) {
        if $!base_type_set {
            nqp::die("Base type has already been set for " ~ self.name($obj));
        }
        $!base_type := $base_type;
        $!base_type_set := 1;
    }
    
    # Our MRO is just that of base type.
    method mro($obj) {
        unless @!mro {
            @!mro[0] := $obj;
            for $!base_type.HOW.mro($!base_type) {
                @!mro.push($_);
            }
        }
        @!mro
    }
    
    method parents($obj, :$local, :$excl, :$all) {
        my @parents := [$!base_type];
        unless $local {
            for $!base_type.HOW.parents($!base_type, :excl($excl), :all($all)) {
                @parents.push($_);
            }
        }
        @parents
    }
}
rakudo-2013.12/src/Perl6/Metamodel/BoolificationProtocol.nqp0000664000175000017500000000144112224263172023315 0ustar  moritzmoritzrole Perl6::Metamodel::BoolificationProtocol {
    has $!boolification_mode;
    
    method get_boolification_mode($obj) {
        $!boolification_mode
    }
    
    method set_boolification_mode($obj, $mode) {
        $!boolification_mode := $mode;
    }
    
    method publish_boolification_spec($obj) {
        if $!boolification_mode == 0 {
            my $meth := self.find_method($obj, 'Bool', :no_fallback(1));
            if nqp::defined($meth) {
                nqp::setboolspec($obj, 0, $meth)
            }
            else {
                # Default to "not a type object" if we've no available method.
                nqp::setboolspec($obj, 5, nqp::null())
            }
        }
        else {
            nqp::setboolspec($obj, $!boolification_mode, nqp::null())
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/BOOTSTRAP.nqp0000664000175000017500000026325712255230273020406 0ustar  moritzmoritzuse Perl6::Metamodel;
use QRegex;

# Here we start to piece together the top of the object model hierarchy.
# We can't just declare these bits in CORE.setting with normal Perl 6
# syntax due to circularity issues. Note that we don't compose any of
# these - which is equivalent to a { ... } body.
#
# One particular circularity we break here is that you can't have
# inheritance in Perl 6 without traits, but that needs multiple
# dispatch, which can't function without some a type hierarchy in
# place. It also needs us to be able to declare a signature with
# parameters and a code objects with dispatchees, which in turn need
# attributes. So, we set up quite a few bits in here, though the aim
# is to keep it "lagom". :-)

# Bootstrapping Attribute class that we eventually replace with the real
# one.
my class BOOTSTRAPATTR {
    has $!name;
    has $!type;
    has $!box_target;
    has $!package;
    method name() { $!name }
    method type() { $!type }
    method box_target() { $!box_target }
    method package() { $!package }
    method has_accessor() { 0 }
    method has-accessor() { 0 }
    method positional_delegate() { 0 }
    method associative_delegate() { 0 }
    method build() { }
    method is_generic() { $!type.HOW.archetypes.generic }
    method instantiate_generic($type_environment) {
        my $ins := $!type.HOW.instantiate_generic($!type, $type_environment);
        self.new(:name($!name), :box_target($!box_target), :type($ins))
    }
    method compose($obj) { }
}

# Stub all types.
my stub Mu metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Any metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Nil metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Cool metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Attribute metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Scalar metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Proxy metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Signature metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Parameter metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Code metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Block metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Routine metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Sub metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Method metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Submethod metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Regex metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Str metaclass Perl6::Metamodel::ClassHOW { ... };
my knowhow bigint is repr('P6bigint') { }
my stub Int metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Num metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Parcel metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Iterable metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Iterator metaclass Perl6::Metamodel::ClassHOW { ... };
my stub ListIter metaclass Perl6::Metamodel::ClassHOW { ... };
my stub List metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Array metaclass Perl6::Metamodel::ClassHOW { ... };
my stub LoL metaclass Perl6::Metamodel::ClassHOW { ... };
my stub EnumMap metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Hash metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Capture metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Bool metaclass Perl6::Metamodel::ClassHOW { ... };
my stub ObjAt metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Stash metaclass Perl6::Metamodel::ClassHOW { ... };
my stub PROCESS metaclass Perl6::Metamodel::ModuleHOW { ... };
my stub Grammar metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Junction metaclass Perl6::Metamodel::ClassHOW { ... };
my stub Metamodel metaclass Perl6::Metamodel::PackageHOW { ... };
my stub ForeignCode metaclass Perl6::Metamodel::ClassHOW { ... };

# We stick all the declarative bits inside of a BEGIN, so they get
# serialized.
BEGIN {
    # Ensure Rakudo runtime support is initialized.
    nqp::p6init();

    # class Mu { ... }
#?if parrot
    Mu.HOW.add_parrot_vtable_mapping(Mu, 'get_integer',
        nqp::getstaticcode(sub ($self) {
            nqp::unbox_i($self.Int())
        }));
    Mu.HOW.add_parrot_vtable_mapping(Mu, 'get_number',
        nqp::getstaticcode(sub ($self) {
            nqp::unbox_n($self.Num())
        }));
    Mu.HOW.add_parrot_vtable_mapping(Mu, 'get_string',
        nqp::getstaticcode(sub ($self) {
            nqp::unbox_s($self.Str())
        }));
    Mu.HOW.add_parrot_vtable_mapping(Mu, 'defined',
        nqp::getstaticcode(sub ($self) { nqp::istrue($self.defined()) }));
#?endif
    Mu.HOW.compose_repr(Mu);

    # class Any is Mu { ... }
    Any.HOW.add_parent(Any, Mu);
    Any.HOW.compose_repr(Any);

    # class Cool is Any { ... }
    Cool.HOW.add_parent(Cool, Any);
    Cool.HOW.compose_repr(Cool);

    # class Attribute is Any {
    #     has str $!name;
    #     has int $!rw;
    #     has int $!has_accessor;
    #     has Mu $!type;
    #     has Mu $!container_descriptor;
    #     has Mu $!auto_viv_container;
    #     has Mu $!build_closure;
    #     has Mu $!package;
    #     has int $!positional_delegate;
    #     has int $!associative_delegate;
    Attribute.HOW.add_parent(Attribute, Any);
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!name>, :type(str), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!rw>, :type(int), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!ro>, :type(int), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!has_accessor>, :type(int), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!type>, :type(Mu), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!container_descriptor>, :type(Mu), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!auto_viv_container>, :type(Mu), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!build_closure>, :type(Mu), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!package>, :type(Mu), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!box_target>, :type(int), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!positional_delegate>, :type(int), :package(Attribute)));
    Attribute.HOW.add_attribute(Attribute, BOOTSTRAPATTR.new(:name<$!associative_delegate>, :type(int), :package(Attribute)));

    # Need new and accessor methods for Attribute in here for now.
    Attribute.HOW.add_method(Attribute, 'new',
        nqp::getstaticcode(sub ($self, :$name!, :$type!, :$package!, :$has_accessor,
                :$positional_delegate = 0, :$associative_delegate = 0, *%other) {
            my $attr := nqp::create($self);
            nqp::bindattr_s($attr, Attribute, '$!name', $name);
            nqp::bindattr($attr, Attribute, '$!type', nqp::decont($type));
            nqp::bindattr_i($attr, Attribute, '$!has_accessor', $has_accessor);
            nqp::bindattr($attr, Attribute, '$!package', $package);
            if nqp::existskey(%other, 'container_descriptor') {
                nqp::bindattr($attr, Attribute, '$!container_descriptor', %other);
                if nqp::existskey(%other, 'auto_viv_container') {
                    nqp::bindattr($attr, Attribute, '$!auto_viv_container',
                        %other);
                }
            }
            else {
                my $cd := Perl6::Metamodel::ContainerDescriptor.new(
                    :of($type), :rw(1), :name($name));
                my $scalar := nqp::create(Scalar);
                nqp::bindattr($scalar, Scalar, '$!descriptor', $cd);
                nqp::bindattr($scalar, Scalar, '$!value', $type);
                nqp::bindattr($attr, Attribute, '$!container_descriptor', $cd);
                nqp::bindattr($attr, Attribute, '$!auto_viv_container', $scalar);
            }
            nqp::bindattr_i($attr, Attribute, '$!positional_delegate', $positional_delegate);
            nqp::bindattr_i($attr, Attribute, '$!associative_delegate', $associative_delegate);
            $attr
        }));
    Attribute.HOW.add_method(Attribute, 'name', nqp::getstaticcode(sub ($self) {
            nqp::getattr_s(nqp::decont($self),
                Attribute, '$!name');
        }));
    Attribute.HOW.add_method(Attribute, 'type', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self),
                Attribute, '$!type');
        }));
    Attribute.HOW.add_method(Attribute, 'container_descriptor', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self),
                Attribute, '$!container_descriptor');
        }));
    Attribute.HOW.add_method(Attribute, 'auto_viv_container', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self),
                Attribute, '$!auto_viv_container');
        }));
    Attribute.HOW.add_method(Attribute, 'has_accessor', nqp::getstaticcode(sub ($self) {
            nqp::p6bool(nqp::getattr_i(nqp::decont($self),
                Attribute, '$!has_accessor'));
        }));
    Attribute.HOW.add_method(Attribute, 'rw', nqp::getstaticcode(sub ($self) {
            nqp::p6bool(nqp::getattr_i(nqp::decont($self),
                Attribute, '$!rw'));
        }));
    Attribute.HOW.add_method(Attribute, 'set_rw', nqp::getstaticcode(sub ($self) {
            nqp::bindattr_i(nqp::decont($self),
                Attribute, '$!rw', 1);
            nqp::p6bool(1)
        }));
    Attribute.HOW.add_method(Attribute, 'set_readonly', nqp::getstaticcode(sub ($self) {
            nqp::bindattr_i(nqp::decont($self),
                Attribute, '$!ro', 1);
            nqp::p6bool(1)
        }));
    Attribute.HOW.add_method(Attribute, 'default_to_rw', nqp::getstaticcode(sub ($self) {
            my $dcself := nqp::decont($self);
            unless nqp::getattr_i($dcself, Attribute, '$!ro') {
                nqp::bindattr_i($dcself, Attribute, '$!rw', 1);
            }
            nqp::p6bool(1)
        }));
    Attribute.HOW.add_method(Attribute, 'set_build', nqp::getstaticcode(sub ($self, $closure) {
            nqp::bindattr(nqp::decont($self), Attribute, '$!build_closure', $closure);
            $self
        }));
    Attribute.HOW.add_method(Attribute, 'build', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self),
                Attribute, '$!build_closure');
        }));
    Attribute.HOW.add_method(Attribute, 'set_box_target', nqp::getstaticcode(sub ($self) {
            nqp::bindattr_i(nqp::decont($self),
                Attribute, '$!box_target', 1);
            nqp::p6bool(1)
        }));
    Attribute.HOW.add_method(Attribute, 'box_target', nqp::getstaticcode(sub ($self) {
            nqp::getattr_i(nqp::decont($self),
                Attribute, '$!box_target')
        }));
    Attribute.HOW.add_method(Attribute, 'positional_delegate', nqp::getstaticcode(sub ($self) {
            nqp::getattr_i(nqp::decont($self), Attribute, '$!positional_delegate');
        }));
    Attribute.HOW.add_method(Attribute, 'associative_delegate', nqp::getstaticcode(sub ($self) {
            nqp::getattr_i(nqp::decont($self), Attribute, '$!associative_delegate')
        }));
    Attribute.HOW.add_method(Attribute, 'is_generic', nqp::getstaticcode(sub ($self) {
            my $dcself   := nqp::decont($self);
            my $type := nqp::getattr(nqp::decont($dcself),
                Attribute, '$!type');
            my $package := nqp::getattr(nqp::decont($dcself),
                Attribute, '$!package');
            my $build := nqp::getattr(nqp::decont($dcself),
                Attribute, '$!build_closure');
            nqp::p6bool($type.HOW.archetypes.generic || $package.HOW.archetypes.generic || nqp::defined($build));
        }));
    Attribute.HOW.add_method(Attribute, 'instantiate_generic', nqp::getstaticcode(sub ($self, $type_environment) {
            my $dcself   := nqp::decont($self);
            my $type     := nqp::getattr($dcself, Attribute, '$!type');
            my $cd       := nqp::getattr($dcself, Attribute, '$!container_descriptor');
            my $pkg      := nqp::getattr($dcself, Attribute, '$!package');
            my $avc      := nqp::getattr($dcself, Attribute, '$!auto_viv_container');
            my $bc       := nqp::getattr($dcself, Attribute, '$!build_closure');
            my $ins      := nqp::clone($dcself);
            if $type.HOW.archetypes.generic {
                nqp::bindattr($ins, Attribute, '$!type',
                    $type.HOW.instantiate_generic($type, $type_environment));
                my $cd_ins := $cd.instantiate_generic($type_environment);
                nqp::bindattr($ins, Attribute, '$!container_descriptor', $cd_ins);
                my $avc_var  := nqp::p6var($avc);
                my $avc_copy := nqp::clone($avc_var);
                my @avc_mro  := $avc_var.HOW.mro($avc_var);
                my $i := 0;
                $i := $i + 1 while @avc_mro[$i].HOW.is_mixin(@avc_mro[$i]);
                nqp::bindattr($avc_copy, @avc_mro[$i], '$!descriptor', $cd_ins);
                nqp::bindattr($ins, Attribute, '$!auto_viv_container', $avc_copy);
            }
            if $pkg.HOW.archetypes.generic {
                nqp::bindattr($ins, Attribute, '$!package',
                    $pkg.HOW.instantiate_generic($pkg, $type_environment));
            }
            if nqp::defined($bc) {
                nqp::bindattr($ins, Attribute, '$!build_closure', $bc.clone());
            }
            $ins
        }));
    Attribute.HOW.compose_repr(Attribute);
    
    # class Scalar is Any {
    #     has Mu $!descriptor;
    #     has Mu $!value;
    #     has Mu $!whence;
    Scalar.HOW.add_parent(Scalar, Any);
    Scalar.HOW.add_attribute(Scalar, BOOTSTRAPATTR.new(:name<$!descriptor>, :type(Mu), :package(Scalar)));
    Scalar.HOW.add_attribute(Scalar, BOOTSTRAPATTR.new(:name<$!value>, :type(Mu), :package(Scalar)));
    Scalar.HOW.add_attribute(Scalar, BOOTSTRAPATTR.new(:name<$!whence>, :type(Mu), :package(Scalar)));
    Scalar.HOW.add_method(Scalar, 'is_generic', nqp::getstaticcode(sub ($self) {
        my $dcself := nqp::decont($self);
        nqp::getattr($dcself, Scalar, '$!descriptor').is_generic()
    }));
    Scalar.HOW.add_method(Scalar, 'instantiate_generic', nqp::getstaticcode(sub ($self, $type_environment) {
        my $dcself := nqp::decont($self);
        nqp::bindattr($dcself, Scalar, '$!descriptor',
            nqp::getattr($dcself, Scalar, '$!descriptor').instantiate_generic(
                $type_environment));
        my $val := nqp::getattr($dcself, Scalar, '$!value');
        if $val.HOW.archetypes.generic {
            nqp::bindattr($dcself, Scalar, '$!value',
                $val.HOW.instantiate_generic($val, $type_environment));
        }
        $self
    }));
    Scalar.HOW.compose_repr(Scalar);

    # Scalar needs to be registered as a container type.
    nqp::setcontspec(Scalar, 'rakudo_scalar', nqp::null());

    # class Proxy is Any {
    #    has Mu &!FETCH;
    #    has Mu &!STORE;
    my $PROXY_FETCH;
    my $PROXY_STORE;
    Proxy.HOW.add_parent(Proxy, Any);
    Proxy.HOW.add_attribute(Proxy, BOOTSTRAPATTR.new(:name<&!FETCH>, :type(Mu), :package(Proxy)));
    Proxy.HOW.add_attribute(Proxy, BOOTSTRAPATTR.new(:name<&!STORE>, :type(Mu), :package(Proxy)));
    Proxy.HOW.add_method(Proxy, 'FETCH', ($PROXY_FETCH := nqp::getstaticcode(sub ($cont) {
        nqp::decont(
            nqp::getattr($cont, Proxy, '&!FETCH')(nqp::p6var($cont)))
    })));
    Proxy.HOW.add_method(Proxy, 'STORE', ($PROXY_STORE := nqp::getstaticcode(sub ($cont, $val) {
        nqp::getattr($cont, Proxy, '&!STORE')(nqp::p6var($cont), $val)
    })));
    Proxy.HOW.add_method(Proxy, 'new', nqp::getstaticcode(sub ($type, :$FETCH, :$STORE) {
        my $cont := nqp::create(Proxy);
        nqp::bindattr($cont, Proxy, '&!FETCH', $FETCH);
        nqp::bindattr($cont, Proxy, '&!STORE', $STORE);
        $cont
    }));
    Proxy.HOW.compose(Proxy);
    nqp::setcontspec(Proxy, 'code_pair', nqp::hash(
        'fetch', $PROXY_FETCH,
        'store', $PROXY_STORE
    ));
    Proxy.HOW.compose_repr(Proxy);

    # Helper for creating a scalar attribute. Sets it up as a real Perl 6
    # Attribute instance, complete with container desciptor and auto-viv
    # container.
    sub scalar_attr($name, $type, $package, :$associative_delegate) {
        my $cd := Perl6::Metamodel::ContainerDescriptor.new(
            :of($type), :rw(1), :name($name));
        my $scalar := nqp::create(Scalar);
        nqp::bindattr($scalar, Scalar, '$!descriptor', $cd);
        nqp::bindattr($scalar, Scalar, '$!value', $type);
        return Attribute.new( :name($name), :type($type), :package($package),
            :container_descriptor($cd), :auto_viv_container($scalar),
            :$associative_delegate);
    }
        
    # class Signature is Any{
    #    has Mu $!params;
    #    has Mu $!returns;
    #    has Mu $!arity;
    #    has Mu $!count;
    #    has Mu $!code;
    Signature.HOW.add_parent(Signature, Any);
    Signature.HOW.add_attribute(Signature, BOOTSTRAPATTR.new(:name<$!params>, :type(Mu), :package(Signature)));
    Signature.HOW.add_attribute(Signature, BOOTSTRAPATTR.new(:name<$!returns>, :type(Mu), :package(Signature)));
    Signature.HOW.add_attribute(Signature, BOOTSTRAPATTR.new(:name<$!arity>, :type(Mu), :package(Signature)));
    Signature.HOW.add_attribute(Signature, BOOTSTRAPATTR.new(:name<$!count>, :type(Mu), :package(Signature)));
    Signature.HOW.add_attribute(Signature, BOOTSTRAPATTR.new(:name<$!code>, :type(Mu), :package(Signature)));
    Signature.HOW.add_method(Signature, 'is_generic', nqp::getstaticcode(sub ($self) {
            # If any parameter is generic, so are we.
            my @params := nqp::getattr($self, Signature, '$!params');
            for @params {
                my $is_generic := $_.is_generic();
                if $is_generic { return $is_generic }
            }
            return nqp::p6bool(0);
        }));
    Signature.HOW.add_method(Signature, 'instantiate_generic', nqp::getstaticcode(sub ($self, $type_environment) {
            # Go through parameters, builidng new list. If any
            # are generic, instantiate them. Otherwise leave them
            # as they are.
            my $ins    := nqp::clone($self);
            my @params := nqp::getattr($self, Signature, '$!params');
            my @ins_params;
            for @params {
                if $_.is_generic() {
                    @ins_params.push($_.instantiate_generic($type_environment))
                }
                else {
                    @ins_params.push($_);
                }
            }
            nqp::bindattr($ins, Signature, '$!params', @ins_params);
            $ins
        }));
    Signature.HOW.add_method(Signature, 'set_returns', nqp::getstaticcode(sub ($self, $type) {
            nqp::bindattr(nqp::decont($self),
                Signature, '$!returns', nqp::decont($type));
        }));
    Signature.HOW.add_method(Signature, 'has_returns', nqp::getstaticcode(sub ($self) {
            nqp::p6bool(
                nqp::not_i(
                    nqp::isnull(
                        nqp::getattr(nqp::decont($self),
                            Signature, '$!returns')
                    )
                )
            );
        }));
    Signature.HOW.compose_repr(Signature);
        
    # class Parameter is Any {
    #     has str $!variable_name
    #     has Mu $!named_names
    #     has Mu $!type_captures
    #     has int $!flags
    #     has Mu $!nominal_type
    #     has Mu $!post_constraints
    #     has Mu $!coerce_type
    #     has str $!coerce_method
    #     has Mu $!sub_signature
    #     has Mu $!default_value
    #     has Mu $!container_descriptor;
    #     has Mu $!attr_package;
    Parameter.HOW.add_parent(Parameter, Any);
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!variable_name>, :type(str), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!named_names>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!type_captures>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!flags>, :type(int), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!nominal_type>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!post_constraints>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!coerce_type>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!coerce_method>, :type(str), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!sub_signature>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!default_value>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!container_descriptor>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_attribute(Parameter, BOOTSTRAPATTR.new(:name<$!attr_package>, :type(Mu), :package(Parameter)));
    Parameter.HOW.add_method(Parameter, 'is_generic', nqp::getstaticcode(sub ($self) {
            # If nonimnal type or attr_package is generic, so are we.
            my $type := nqp::getattr($self, Parameter, '$!nominal_type');
            my $ap   := nqp::getattr($self, Parameter, '$!attr_package');
            nqp::p6bool($type.HOW.archetypes.generic ||
                (!nqp::isnull($ap) && $ap.HOW.archetypes.generic))
        }));
    Parameter.HOW.add_method(Parameter, 'instantiate_generic', nqp::getstaticcode(sub ($self, $type_environment) {
            # Clone with the type instantiated.
            my $SIG_ELEM_NOMINAL_GENERIC := 524288;
            my $ins      := nqp::clone($self);
            my $type     := nqp::getattr($self, Parameter, '$!nominal_type');
            my $cd       := nqp::getattr($self, Parameter, '$!container_descriptor');
            my $ap       := nqp::getattr($self, Parameter, '$!attr_package');
            my $ins_type := $type;
            my $ins_cd   := $cd;
            if $type.HOW.archetypes.generic {
                $ins_type := $type.HOW.instantiate_generic($type, $type_environment);
                $ins_cd   := nqp::isnull($cd) ?? $cd !! $cd.instantiate_generic($type_environment);
            }
            my $ins_ap := !nqp::isnull($ap) && $ap.HOW.archetypes.generic
                ?? $ap.HOW.instantiate_generic($ap, $type_environment)
                !! $ap;
            unless $ins_type.HOW.archetypes.generic {
                my $flags := nqp::getattr_i($ins, Parameter, '$!flags');
                if $flags +& $SIG_ELEM_NOMINAL_GENERIC {
                    nqp::bindattr_i($ins, Parameter, '$!flags',
                        $flags - $SIG_ELEM_NOMINAL_GENERIC)
                }
            }
            nqp::bindattr($ins, Parameter, '$!nominal_type', $ins_type);
            nqp::bindattr($ins, Parameter, '$!container_descriptor', $ins_cd);
            nqp::bindattr($ins, Parameter, '$!attr_package', $ins_ap);
            $ins
        }));
    Parameter.HOW.add_method(Parameter, 'set_rw', nqp::getstaticcode(sub ($self) {
            my $SIG_ELEM_IS_RW       := 256;
            my $SIG_ELEM_IS_OPTIONAL := 2048;
            my $dcself := nqp::decont($self);
            my $flags  := nqp::getattr_i($dcself, Parameter, '$!flags');
            if $flags +& $SIG_ELEM_IS_OPTIONAL {
                nqp::die("Cannot use 'is rw' on an optional parameter");
            }
            my $cd := nqp::getattr($dcself, Parameter, '$!container_descriptor');
            if nqp::defined($cd) { $cd.set_rw(1) }
            nqp::bindattr_i($dcself, Parameter, '$!flags', $flags + $SIG_ELEM_IS_RW);
            $dcself
        }));
    Parameter.HOW.add_method(Parameter, 'set_copy', nqp::getstaticcode(sub ($self) {
            my $SIG_ELEM_IS_COPY := 512;
            my $dcself := nqp::decont($self);
            my $cd     := nqp::getattr($dcself, Parameter, '$!container_descriptor');
            if nqp::defined($cd) { $cd.set_rw(1) }
            nqp::bindattr_i($dcself, Parameter, '$!flags',
                nqp::getattr_i($dcself, Parameter, '$!flags') + $SIG_ELEM_IS_COPY);
            $dcself
        }));
    Parameter.HOW.add_method(Parameter, 'set_required', nqp::getstaticcode(sub ($self) {
            my $SIG_ELEM_IS_OPTIONAL := 2048;
            my $dcself := nqp::decont($self);
            my $flags := nqp::getattr_i($dcself, Parameter, '$!flags');
            if $flags +& $SIG_ELEM_IS_OPTIONAL {
                nqp::bindattr_i($dcself, Parameter, '$!flags',
                    $flags - $SIG_ELEM_IS_OPTIONAL);
            }
            $dcself
        }));
    Parameter.HOW.add_method(Parameter, 'set_parcel', nqp::getstaticcode(sub ($self) {
            my $SIG_ELEM_IS_PARCEL := 1024;
            my $dcself := nqp::decont($self);
            my $flags := nqp::getattr_i($dcself, Parameter, '$!flags');
            unless $flags +& $SIG_ELEM_IS_PARCEL {
                nqp::bindattr_i($dcself, Parameter, '$!flags',
                    $flags + $SIG_ELEM_IS_PARCEL);
            }
            $dcself
        }));
    Parameter.HOW.add_method(Parameter, 'set_coercion', nqp::getstaticcode(sub ($self, $type) {
            my $dcself := nqp::decont($self);
            nqp::bindattr_s($dcself, Parameter, '$!coerce_method', $type.HOW.name($type));
            nqp::bindattr($dcself, Parameter, '$!coerce_type', $type);
            $dcself
        }));
    Parameter.HOW.compose_repr(Parameter);
    
    # class Code {
    #     has Mu $!do;                # Low level code object
    #     has Mu $!signature;         # Signature object
    #     has Mu $!compstuff;         # Place for the compiler to hang stuff
    Code.HOW.add_parent(Code, Any);
    Code.HOW.add_attribute(Code, BOOTSTRAPATTR.new(:name<$!do>, :type(Mu), :package(Code)));
    Code.HOW.add_attribute(Code, BOOTSTRAPATTR.new(:name<$!signature>, :type(Mu), :package(Code)));
    Code.HOW.add_attribute(Code, BOOTSTRAPATTR.new(:name<$!compstuff>, :type(Mu), :package(Code)));

    # Need clone in here, plus generics instantiation.
    Code.HOW.add_method(Code, 'clone', nqp::getstaticcode(sub ($self) {
            my $dcself    := nqp::decont($self);
            my $cloned    := nqp::clone($dcself);
            my $do        := nqp::getattr($dcself, Code, '$!do');
            my $do_cloned := nqp::clone($do);
            nqp::bindattr($cloned, Code, '$!do', $do_cloned);
            nqp::setcodeobj($do_cloned, $cloned);
            my $compstuff := nqp::getattr($dcself, Code, '$!compstuff');
            unless nqp::isnull($compstuff) {
                $compstuff[2]($do, $cloned);
            }
            $cloned
        }));
    Code.HOW.add_method(Code, 'is_generic', nqp::getstaticcode(sub ($self) {
            # Delegate to signature, since it contains all the type info.
            my $dc_self := nqp::decont($self);
            nqp::getattr($dc_self, Code, '$!signature').is_generic()
        }));
    Code.HOW.add_method(Code, 'instantiate_generic', nqp::getstaticcode(sub ($self, $type_environment) {
            # Clone the code object, then instantiate the generic signature. Also
            # need to clone dispatchees list.
            my $dcself := nqp::decont($self);
            my $ins := $self.clone();
            if nqp::defined(nqp::getattr($dcself, Routine, '$!dispatchees')) {
                nqp::bindattr($ins, Routine, '$!dispatchees',
                    nqp::clone(nqp::getattr($dcself, Routine, '$!dispatchees')));
            }
            my $sig := nqp::getattr($dcself, Code, '$!signature');
            nqp::bindattr($ins, Code, '$!signature',
                $sig.instantiate_generic($type_environment));
            $ins
        }));
    Code.HOW.add_method(Code, 'name', nqp::getstaticcode(sub ($self) {
            nqp::getcodename(nqp::getattr(nqp::decont($self),
                Code, '$!do'))
        }));
    Code.HOW.add_method(Code, 'set_name', nqp::getstaticcode(sub ($self, $name) {
            nqp::setcodename(
                nqp::getattr(nqp::decont($self), Code, '$!do'),
                $name)
        }));
    Code.HOW.add_method(Code, 'id', nqp::getstaticcode(sub ($self) {
            nqp::where(nqp::getattr(nqp::decont($self),
                Code, '$!do'))
        }));
    Code.HOW.compose_repr(Code);
        
    # Need to actually run the code block. Also need this available before we finish
    # up the stub.
    Code.HOW.set_invocation_attr(Code, Code, '$!do');
    Code.HOW.compose_invocation(Code);

    # class Block is Code {
    #     has Mu $!phasers;                # phasers for this block
    Block.HOW.add_parent(Block, Code);
    Block.HOW.add_attribute(Block, BOOTSTRAPATTR.new(:name<$!phasers>, :type(Mu), :package(Block)));
    Block.HOW.add_method(Block, 'clone', nqp::getstaticcode(sub ($self) {
            my $dcself    := nqp::decont($self);
            my $cloned    := nqp::clone($dcself);
            my $do        := nqp::getattr($dcself, Code, '$!do');
            my $do_cloned := nqp::clone($do);
            nqp::bindattr($cloned, Code, '$!do', $do_cloned);
            nqp::setcodeobj($do_cloned, $cloned);
            my $compstuff := nqp::getattr($dcself, Code, '$!compstuff');
            unless nqp::isnull($compstuff) {
                $compstuff[2]($do, $cloned);
            }
            $cloned
        }));
    Block.HOW.compose_repr(Block);
    Block.HOW.compose_invocation(Block);

    # class Routine is Block {
    #     has Mu $!dispatchees;
    #     has Mu $!dispatcher_cache;
    #     has Mu $!dispatcher;
    #     has int $!rw;
    #     has Mu $!inline_info;
    #     has int $!yada;
    #     has Mu $!package;
    #     has int $!onlystar;
    #     has Mu $!dispatch_order;
    #     has Mu $!dispatch_cache;
    Routine.HOW.add_parent(Routine, Block);
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!dispatchees>, :type(Mu), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!dispatcher_cache>, :type(Mu), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!dispatcher>, :type(Mu), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!rw>, :type(int), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!inline_info>, :type(Mu), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!yada>, :type(int), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!package>, :type(Mu), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!onlystar>, :type(int), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!dispatch_order>, :type(Mu), :package(Routine)));
    Routine.HOW.add_attribute(Routine, BOOTSTRAPATTR.new(:name<$!dispatch_cache>, :type(Mu), :package(Routine)));
    
    Routine.HOW.add_method(Routine, 'is_dispatcher', nqp::getstaticcode(sub ($self) {
            my $dc_self   := nqp::decont($self);
            my $disp_list := nqp::getattr($dc_self, Routine, '$!dispatchees');
            nqp::p6bool(nqp::defined($disp_list));
        }));
    Routine.HOW.add_method(Routine, 'add_dispatchee', nqp::getstaticcode(sub ($self, $dispatchee) {
            my $dc_self   := nqp::decont($self);
            my $disp_list := nqp::getattr($dc_self, Routine, '$!dispatchees');
            if nqp::defined($disp_list) {
                $disp_list.push($dispatchee);
                nqp::bindattr(nqp::decont($dispatchee),
                    Routine, '$!dispatcher', $dc_self);
                nqp::scwbdisable();
                nqp::bindattr($dc_self, Routine, '$!dispatch_order', nqp::null());
                nqp::bindattr($dc_self, Routine, '$!dispatch_cache', nqp::null());
                nqp::bindattr($dc_self, Routine, '$!dispatcher_cache', nqp::null());
                nqp::scwbenable();
                $dc_self
            }
            else {
                nqp::die("Cannot add a dispatchee to a non-dispatcher code object");
            }
        }));
    Routine.HOW.add_method(Routine, 'derive_dispatcher', nqp::getstaticcode(sub ($self) {
            my $clone := $self.clone();
            nqp::bindattr($clone, Routine, '$!dispatchees',
                nqp::clone(nqp::getattr($self, Routine, '$!dispatchees')));
            $clone
        }));
    Routine.HOW.add_method(Routine, 'dispatcher', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self),
                Routine, '$!dispatcher')
        }));
    Routine.HOW.add_method(Routine, 'dispatchees', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self),
                Routine, '$!dispatchees')
        }));
    Routine.HOW.add_method(Routine, '!sort_dispatchees_internal', nqp::getstaticcode(sub ($self) {
            my int $SLURPY_ARITY      := nqp::bitshiftl_i(1, 30);
            my int $EDGE_REMOVAL_TODO := -1;
            my int $EDGE_REMOVED      := -2;
            my int $DEFCON_NONE       := 0;
            my int $DEFCON_DEFINED    := 1;
            my int $DEFCON_UNDEFINED  := 2;
            my int $DEFCON_MASK       := $DEFCON_DEFINED +| $DEFCON_UNDEFINED;
            my int $TYPE_NATIVE_INT   := 4;
            my int $TYPE_NATIVE_NUM   := 8;
            my int $TYPE_NATIVE_STR   := 16;
            my int $TYPE_NATIVE_MASK  := $TYPE_NATIVE_INT +| $TYPE_NATIVE_NUM +| $TYPE_NATIVE_STR;

            my int $SIG_ELEM_SLURPY_POS          := 8;
            my int $SIG_ELEM_SLURPY_NAMED        := 16;
            my int $SIG_ELEM_SLURPY_LOL          := 32;
            my int $SIG_ELEM_MULTI_INVOCANT      := 128;
            my int $SIG_ELEM_IS_OPTIONAL         := 2048;
            my int $SIG_ELEM_IS_CAPTURE          := 32768;
            my int $SIG_ELEM_UNDEFINED_ONLY      := 65536;
            my int $SIG_ELEM_DEFINED_ONLY        := 131072;
            my int $SIG_ELEM_NOMINAL_GENERIC     := 524288;
            my int $SIG_ELEM_NATIVE_INT_VALUE    := 2097152;
            my int $SIG_ELEM_NATIVE_NUM_VALUE    := 4194304;
            my int $SIG_ELEM_NATIVE_STR_VALUE    := 8388608;
            
            # Takes two candidates and determines if the first one is narrower
            # than the second. Returns a true value if they are.
            sub is_narrower(%a, %b) {
                # Work out how many parameters to compare, factoring in
                # slurpiness and optionals.
                my int $types_to_check;
                if %a == %b {
                    $types_to_check := %a;
                }
                elsif %a == %b {
                    $types_to_check := %a > %b
                        ?? %b
                        !! %a;
                }
                elsif %a != $SLURPY_ARITY && %b == $SLURPY_ARITY {
                    return 1;
                }
                else {
                    return 0;
                }

                # Analyse each parameter in the two candidates.
                my int $i := 0;
                my int $narrower := 0;
                my int $tied := 0;
                while $i < $types_to_check {
                    my $type_obj_a := %a[$i];
                    my $type_obj_b := %b[$i];
                    if nqp::eqaddr($type_obj_a, $type_obj_b) {
                        # Same type; narrower if first has constraints and other doesn't;
                        # tied if neither has constraints or both have constraints. */
                        if %a[$i] && !%b[$i] {
                            $narrower++;
                        }
                        elsif (!%a[$i] && !%b[$i])
                           || (%a[$i] && %b[$i]) {
                            $tied++;
                        }
                    }
                    elsif (nqp::atpos_i(%a, $i) +& $TYPE_NATIVE_MASK)
                      && !(nqp::atpos_i(%b, $i) +& $TYPE_NATIVE_MASK) {
                        # Narrower because natives always are.
                        $narrower++;
                    }
                    elsif (nqp::atpos_i(%b, $i) +& $TYPE_NATIVE_MASK)
                      && !(nqp::atpos_i(%a, $i) +& $TYPE_NATIVE_MASK) {
                        # Wider; skip over here so we don't go counting this as tied in
                        # the next branch.
                    }
                    else {
                        if nqp::istype($type_obj_a, $type_obj_b) {
                            # Narrower - note it and we're done.
                            $narrower++;
                        }
                        else {
                            # Make sure it's tied, rather than the other way around.
                            unless nqp::istype($type_obj_b, $type_obj_a) {
                                $tied++;
                            }
                        }
                    }
                    $i++;
                }

                # If one is narrower than the other from current analysis, we're done.
                if $narrower >= 1 && $narrower + $tied == $types_to_check {
                    return 1;
                }

                # If they aren't tied, we're also done.
                elsif $tied != $types_to_check {
                    return 0;
                }
                
                # Otherwise, we see if one has a slurpy and the other not. A lack of
                # slurpiness makes the candidate narrower.
                if %a != $SLURPY_ARITY && %b == $SLURPY_ARITY {
                    return 1;
                }

                # Also narrower if the first needs a bind check and the second doesn't, if
                # we wouldn't deem the other one narrower than this one int terms of
                # slurpyness. Otherwise, they're tied.
                return !(%b != $SLURPY_ARITY && %a == $SLURPY_ARITY)
                    && (%a && !%b);
            }
            
            my $dcself     := nqp::decont($self);
            my @candidates := nqp::getattr($dcself, Routine, '$!dispatchees');
            
            # Create a node for each candidate in the graph.
            my @graph;
            for @candidates -> $candidate {
                # Get hold of signature.
                my $sig    := nqp::getattr($candidate, Code, '$!signature');
                my @params := nqp::getattr($sig, Signature, '$!params');

                # Create it an entry.
                my %info := nqp::hash(
                    'sub',          $candidate,
                    'signature',    $sig,
                    'types',        [],
                    'type_flags',   nqp::list_i(),
                    'constraints',  [],
                    'min_arity',    0,
                    'max_arity',    0,
                    'num_types',    0,
                );
                my int $significant_param := 0;
                for @params -> $param {
                    # If it's a required named (and not slurpy) don't need its type info
                    # but we will need a bindability check during the dispatch for it.
                    my int $flags   := nqp::getattr_i($param, Parameter, '$!flags');
                    my $named_names := nqp::getattr($param, Parameter, '$!named_names');
                    unless nqp::isnull($named_names) {
                        if !($flags +& $SIG_ELEM_IS_OPTIONAL) {
                            if nqp::elems($named_names) == 1 {
                                %info := nqp::atpos($named_names, 0);
                            }
                        }
                        %info := 1;
                        next;
                    }

                    # If it's got a sub-signature, also need a bind check.
                    unless nqp::isnull(nqp::getattr($param, Parameter, '$!sub_signature')) {
                        %info := 1;
                    }

                    # If it's named slurpy, we're done, also we don't need a bind
                    # check on account of nameds since we take them all.
                    if $flags +& $SIG_ELEM_SLURPY_NAMED {
                        last;
                    }

                    # Otherwise, positional or slurpy and contributes to arity.
                    if $flags +& ($SIG_ELEM_SLURPY_POS +| $SIG_ELEM_SLURPY_LOL +| $SIG_ELEM_IS_CAPTURE) {
                        %info := $SLURPY_ARITY;
                        last;
                    }
                    elsif $flags +& $SIG_ELEM_IS_OPTIONAL {
                        %info++;
                    }
                    else {
                        %info++;
                        %info++;
                    }

                    # Record type info for this parameter.
                    if $flags +& $SIG_ELEM_NOMINAL_GENERIC {
                        %info := 1;
                        %info[$significant_param] := Any;
                    }
                    else {
                        %info[$significant_param] :=
                            nqp::getattr($param, Parameter, '$!nominal_type');
                    }
                    unless nqp::isnull(nqp::getattr($param, Parameter, '$!post_constraints')) {
                        %info[$significant_param] := 1;
                        %info := 1;
                    }
                    if $flags +& $SIG_ELEM_MULTI_INVOCANT {
                        %info++;
                    }
                    if $flags +& $SIG_ELEM_DEFINED_ONLY {
                        nqp::bindpos_i(%info, $significant_param, $DEFCON_DEFINED);
                    }
                    elsif $flags +& $SIG_ELEM_UNDEFINED_ONLY {
                        nqp::bindpos_i(%info, $significant_param, $DEFCON_UNDEFINED);
                    }
                    if $flags +& $SIG_ELEM_NATIVE_INT_VALUE {
                        nqp::bindpos_i(%info, $significant_param,
                            $TYPE_NATIVE_INT + nqp::atpos_i(%info, $significant_param));
                    }
                    elsif $flags +& $SIG_ELEM_NATIVE_NUM_VALUE {
                        nqp::bindpos_i(%info, $significant_param,
                            $TYPE_NATIVE_NUM + nqp::atpos_i(%info, $significant_param));
                    }
                    elsif $flags +& $SIG_ELEM_NATIVE_STR_VALUE {
                        nqp::bindpos_i(%info, $significant_param,
                            $TYPE_NATIVE_STR + nqp::atpos_i(%info, $significant_param));
                    }
                    $significant_param++;
                }

                # Add it to graph node, and initialize list of edges.
                nqp::push(@graph, nqp::hash(
                    'info',      %info,
                    'edges',     [],
                    'edges_in',  0,
                    'edges_out', 0
                ));
            }

            # Now analyze type narrowness of the candidates relative to each
            # other and create the edges.
            my int $i := 0;
            my int $j;
            my int $n := nqp::elems(@candidates);
            while $i < $n {
                $j := 0;
                while $j < $n {
                    unless $i == $j {
                        if is_narrower(@graph[$i], @graph[$j]) {
                            @graph[$i][@graph[$i]] := @graph[$j];
                            @graph[$i]++;
                            @graph[$j]++;
                        }
                    }
                    $j++;
                }
                $i++;
            }

            # Perform the topological sort.
            my int $candidates_to_sort := nqp::elems(@candidates);
            my @result;
            while $candidates_to_sort > 0 {
                my int $rem_results := nqp::elems(@result);

                # Find any nodes that have no incoming edges and add them to
                # results.
                $i := 0;
                while $i < $n {
                    if @graph[$i] == 0 {
                        # Add to results.
                        nqp::push(@result, @graph[$i]);
                        $candidates_to_sort--;
                        @graph[$i] := $EDGE_REMOVAL_TODO;
                    }
                    $i++;
                }
                if $rem_results == nqp::elems(@result) {
                    nqp::die("Circularity detected in multi sub types");
                }

                # Now we need to decrement edges in counts for things that had
                # edges from candidates we added here.
                $i := 0;
                while $i < $n {
                    if @graph[$i] == $EDGE_REMOVAL_TODO {
                        $j := 0;
                        while $j < @graph[$i] {
                            @graph[$i][$j]--;
                            $j++;
                        }
                        @graph[$i] := $EDGE_REMOVED;
                    }
                    $i++;
                }

                # This is end of a tied group, so leave a gap.
                nqp::push(@result, Mu);
            }
            
            # Add final null sentinel.
            nqp::push(@result, Mu);

            @result
        }));
    Routine.HOW.add_method(Routine, 'sort_dispatchees', nqp::getstaticcode(sub ($self) {
        my $dcself := nqp::decont($self);
        unless nqp::isnull(nqp::getattr($dcself, Routine, '$!dispatch_order')) {
            nqp::bindattr($dcself, Routine, '$!dispatch_order',
                $self.'!sort_dispatchees_internal'());
        }
    }));
    Routine.HOW.add_method(Routine, 'find_best_dispatchee', nqp::getstaticcode(sub ($self, $capture, int $many = 0) {        
            my int $DEFCON_DEFINED    := 1;
            my int $DEFCON_UNDEFINED  := 2;
            my int $DEFCON_MASK       := $DEFCON_DEFINED +| $DEFCON_UNDEFINED;
            my int $TYPE_NATIVE_INT   := 4;
            my int $TYPE_NATIVE_NUM   := 8;
            my int $TYPE_NATIVE_STR   := 16;
            my int $TYPE_NATIVE_MASK  := $TYPE_NATIVE_INT +| $TYPE_NATIVE_NUM +| $TYPE_NATIVE_STR;
            my int $BIND_VAL_OBJ      := 0;
            my int $BIND_VAL_INT      := 1;
            my int $BIND_VAL_NUM      := 2;
            my int $BIND_VAL_STR      := 3;
            
            # Count arguments.
            my int $num_args := nqp::captureposelems($capture);

            # Get list and number of candidates, triggering a sort if there are none.
            my $dcself := nqp::decont($self);
            my @candidates := nqp::getattr($dcself, Routine, '$!dispatch_order');
            if nqp::isnull(@candidates) {
                nqp::scwbdisable();
                @candidates := $dcself.'!sort_dispatchees_internal'();
                nqp::bindattr($dcself, Routine, '$!dispatch_order', @candidates);
                nqp::scwbenable();
            }
            my $num_candidates := nqp::elems(@candidates);

            # Iterate over the candidates and collect best ones; terminate
            # when we see two type objects (indicating end).
            my int $cur_idx := 0;
            my $cur_candidate;
            my int $type_check_count;
            my int $type_mismatch;
            my int $i;
            my int $pure_type_result := 1;
            my $many_res := $many ?? [] !! Mu;
            my @possibles;
            my int $done := 0;
            my int $done_bind_check := 0;
            until $done {
                $cur_candidate := nqp::atpos(@candidates, $cur_idx);

                if nqp::isconcrete($cur_candidate) {
                    # Check if it's admissable by arity.
                    unless $num_args < nqp::atkey($cur_candidate, 'min_arity')
                    || $num_args > nqp::atkey($cur_candidate, 'max_arity') {
                        # Arity OK; now check if it's admissable by type.
                        $type_check_count := nqp::atkey($cur_candidate, 'num_types') > $num_args
                            ?? $num_args
                            !! nqp::atkey($cur_candidate, 'num_types');
                        $type_mismatch := 0;

                        $i := 0;
                        while $i < $type_check_count && !$type_mismatch {
                            my $type_obj     := nqp::atpos(nqp::atkey($cur_candidate, 'types'), $i);
                            my $type_flags   := nqp::atpos_i(nqp::atkey($cur_candidate, 'type_flags'), $i);
                            my int $got_prim := nqp::captureposprimspec($capture, $i);
                            if $type_flags +& $TYPE_NATIVE_MASK {
                                # Looking for a natively typed value. Did we get one?
                                if $got_prim == $BIND_VAL_OBJ {
                                    # Object; won't do.
                                    $type_mismatch := 1;
                                }
                                elsif (($type_flags +& $TYPE_NATIVE_INT) && $got_prim != $BIND_VAL_INT) ||
                                   (($type_flags +& $TYPE_NATIVE_NUM) && $got_prim != $BIND_VAL_NUM) ||
                                   (($type_flags +& $TYPE_NATIVE_STR) && $got_prim != $BIND_VAL_STR) {
                                    # Mismatch.
                                    $type_mismatch := 1;
                                }
                            }
                            else {
                                my $param;
                                if $got_prim == $BIND_VAL_OBJ {
                                    $param := nqp::hllizefor(
                                        nqp::captureposarg($capture, $i),
                                        'perl6');
                                }
                                else {
                                    $param := $got_prim == $BIND_VAL_INT ?? Int !!
                                              $got_prim == $BIND_VAL_NUM ?? Num !!
                                                                            Str;
                                }
                                unless nqp::eqaddr($type_obj, Mu) || nqp::istype($param, $type_obj) {
                                    $type_mismatch := 1;
                                }
                                if !$type_mismatch && $type_flags +& $DEFCON_MASK {
                                    my int $defined := $got_prim != $BIND_VAL_OBJ || nqp::isconcrete($param);
                                    my int $desired := $type_flags +& $DEFCON_MASK;
                                    if ($defined && $desired == $DEFCON_UNDEFINED) ||
                                       (!$defined && $desired == $DEFCON_DEFINED) {
                                        $type_mismatch := 1;
                                    }
                                }
                            }
                            $i++;
                        }
                        
                        unless $type_mismatch {
                            # It's an admissable candidate; add to list.
                            nqp::push(@possibles, $cur_candidate);
                        }
                    }

                    $cur_idx++;
                } else {
                    # We've hit the end of a tied group now. If any of them have a
                    # bindability check requirement, we'll do any of those now.
                    if nqp::elems(@possibles) {
                        my $new_possibles;
                        my %info;
                        $i := 0;
                        while $i < nqp::elems(@possibles) {
                            %info := nqp::atpos(@possibles, $i);
                            
                            # First, if there's a required named parameter and it was
                            # not passed, we can very quickly eliminate this candidate
                            # without doing a full bindability check.
                            if nqp::existskey(%info, 'req_named')
                            && !nqp::captureexistsnamed($capture, nqp::atkey(%info, 'req_named')) {
                                # Required named arg not passed, so we eliminate
                                # it right here. Flag that we've built a list of
                                # new possibles, and that this was not a pure
                                # type-based result that we can cache.
                                $new_possibles := [] unless nqp::islist($new_possibles);
                            }

                            # Otherwise, may need full bind check.
                            elsif nqp::existskey(%info, 'bind_check') {
                                my $sub := nqp::atkey(%info, 'sub');
                                my $cs := nqp::getattr($sub, Code, '$!compstuff');
                                unless nqp::isnull($cs) {
                                    # We need to do the tie-break on something not yet compiled.
                                    # Get it compiled.
                                    my $ctf := $cs[1];
                                    $ctf() if $ctf;
                                }
                                
                                # Since we had to do a bindability check, this is not
                                # a result we can cache on nominal type.
                                $pure_type_result := 0;
                                
                                # If we haven't got a possibles storage space, allocate it now.
                                $new_possibles := [] unless nqp::islist($new_possibles);
                                
                                my $sig := nqp::getattr($sub, Code, '$!signature');
#?if !parrot
                                unless $done_bind_check {
                                    # Need a copy of the capture, as we may later do a
                                    # multi-dispatch when evaluating the constraint.
                                    $capture := nqp::clone($capture);
                                    $done_bind_check := 1;
                                }
#?endif
                                if nqp::p6isbindable($sig, $capture) {
                                    nqp::push($new_possibles, nqp::atpos(@possibles, $i));
                                    unless $many {
                                        # Terminate the loop.
                                        $i := nqp::elems(@possibles);
                                    }
                                }
                            }
                            
                            # Otherwise, it's just nominal; accept it.
                            elsif $new_possibles {
                                nqp::push($new_possibles, nqp::atpos(@possibles, $i));
                            }
                            else {
                                $new_possibles := [nqp::atpos(@possibles, $i)];
                            }
                            $i++;
                        }

                        # If we have an updated list of possibles, use this
                        # new one from here on in.
                        if nqp::islist($new_possibles) {
                            @possibles := $new_possibles;
                        }
                    }

                    # Now we have eliminated any that fail the bindability check.
                    # See if we need to push it onto the many list and continue.
                    # Otherwise, we have the result we were looking for.
                    if $many {
                        while @possibles {
                            nqp::push($many_res, nqp::atkey(nqp::shift(@possibles), 'sub'))
                        }
                        $cur_idx++;
                        unless nqp::isconcrete(nqp::atpos(@candidates, $cur_idx)) {
                            $done := 1;
                        }
                    }
                    elsif @possibles {
                        $done := 1;
                    }
                    else {
                        # Keep looping and looking, unless we really hit the end.
                        $cur_idx++;
                        unless nqp::isconcrete(nqp::atpos(@candidates, $cur_idx)) {
                            $done := 1;
                        }
                    }
                }
            }
            
            # If we were looking for many candidates, we're done now.
            if $many {
                return $many_res;
            }

            # Check is default trait if we still have multiple options and we want one.
            if nqp::elems(@possibles) > 1 {
                # Locate any default candidates; if we find multiple defaults, this is
                # no help, so we'll not bother collecting just which ones are good.
                my $default_cand;
                for @possibles {
                    my $sub := nqp::atkey($_, 'sub');
                    if nqp::can($sub, 'default') && $sub.default {
                        if nqp::isconcrete($default_cand) {
                            $default_cand := Mu;
                        }
                        else {
                            $default_cand := $_;
                        }
                    }
                }
                if nqp::isconcrete($default_cand) {
                    nqp::pop(@possibles) while @possibles;
                    @possibles[0] := $default_cand;
                }
            }

            # If we're at a single candidate here, and we also know there's no
            # type constraints that follow, we can cache the result.
            if nqp::elems(@possibles) == 1 && $pure_type_result {
                unless nqp::capturehasnameds($capture) {
                    nqp::scwbdisable();
                    nqp::bindattr($dcself, Routine, '$!dispatch_cache',
                        nqp::multicacheadd(
                            nqp::getattr($dcself, Routine, '$!dispatch_cache'),
                            $capture,
                            nqp::atkey(nqp::atpos(@possibles, 0), 'sub')));
                    nqp::scwbenable();
                }
            }

            # Perhaps we found nothing but have junctional arguments?
            my $junctional_res;
            if nqp::elems(@possibles) == 0 {
                my int $has_junc_args := 0;
                $i := 0;
                while $i < $num_args {
                    if !nqp::captureposprimspec($capture, $i) {
                        if nqp::istype(nqp::captureposarg($capture, $i), Junction) {
                            $has_junc_args := 1;
                        }
                    }
                    $i++;
                }
                if $has_junc_args {
                    $junctional_res := -> *@pos, *%named {
                        Junction.AUTOTHREAD($self, |@pos, |%named)
                    }
                }
            }

            # Need a unique candidate.
            if nqp::elems(@possibles) == 1 {
                nqp::atkey(nqp::atpos(@possibles, 0), 'sub')
            }
            elsif nqp::isconcrete($junctional_res) {
                $junctional_res;
            }
            elsif nqp::elems(@possibles) == 0 {
                my %ex := nqp::gethllsym('perl6', 'P6EX');
                if nqp::isnull(%ex) || !nqp::existskey(%ex, 'X::Multi::NoMatch') {
                    nqp::die("Cannot call " ~ $self.name() ~
                        "; no signatures match");
                }
                else {
                    nqp::atkey(%ex, 'X::Multi::NoMatch')($self)
                }
            }
            else {
                my %ex := nqp::gethllsym('perl6', 'P6EX');
                if nqp::isnull(%ex) || !nqp::existskey(%ex, 'X::Multi::Ambiguous') {
                    nqp::die("Ambiguous call to " ~ $self.name());
                }
                else {
                    my @ambig;
                    for @possibles {
                        nqp::push(@ambig, $_);
                    }
                    nqp::atkey(%ex, 'X::Multi::Ambiguous')($self, @ambig)
                }
            }
        }));
    Routine.HOW.add_method(Routine, 'analyze_dispatch', nqp::getstaticcode(sub ($self, @args, @flags) {
            # Compile time dispatch result.
            my $MD_CT_NOT_SURE :=  0;  # Needs a runtime dispatch.
            my $MD_CT_DECIDED  :=  1;  # Worked it out; see result.
            my $MD_CT_NO_WAY   := -1;  # Proved it'd never manage to dispatch.
            
            # Other constants we need.
            my int $DEFCON_DEFINED    := 1;
            my int $DEFCON_UNDEFINED  := 2;
            my int $DEFCON_MASK       := $DEFCON_DEFINED +| $DEFCON_UNDEFINED;
            my int $TYPE_NATIVE_INT   := 4;
            my int $TYPE_NATIVE_NUM   := 8;
            my int $TYPE_NATIVE_STR   := 16;
            my int $TYPE_NATIVE_MASK  := $TYPE_NATIVE_INT +| $TYPE_NATIVE_NUM +| $TYPE_NATIVE_STR;
            my int $BIND_VAL_OBJ      := 0;
            my int $BIND_VAL_INT      := 1;
            my int $BIND_VAL_NUM      := 2;
            my int $BIND_VAL_STR      := 3;
            
            # Count arguments.
            my int $num_args := nqp::elems(@args);
            
            # Get list and number of candidates, triggering a sort if there are none.
            my $dcself := nqp::decont($self);
            my @candidates := nqp::getattr($dcself, Routine, '$!dispatch_order');
            if nqp::isnull(@candidates) {
                nqp::scwbdisable();
                @candidates := $dcself.'!sort_dispatchees_internal'();
                nqp::bindattr($dcself, Routine, '$!dispatch_order', @candidates);
                nqp::scwbenable();
            }
            my $num_candidates := nqp::elems(@candidates);
            
            # Look through the candidates. If we see anything that needs a bind
            # check or a definedness check, we can't decide it at compile time,
            # so bail out immediately.
            my int $all_native     := 1;
            my int $cur_idx        := 0;
            my int $seen_all       := 0;
            my int $arity_possible := 0;
            my int $type_possible  := 0;
            my int $used_defcon;
            my int $type_mismatch;
            my int $type_check_count;
            my int $type_match_possible;
            my int $i;
            my $cur_candidate;
            my $cur_result;
            while 1 {
                $cur_candidate := nqp::atpos(@candidates, $cur_idx);
                $used_defcon := 0;

                # Did we reach the end of a tied group? If so, note we can only
                # consider the narrowest group, *unless* they are all natively
                # typed candidates in which case we can look a bit further.
                # We also exit if we found something.
                unless nqp::isconcrete($cur_candidate) {
                    $cur_idx++;
                    if nqp::isconcrete(nqp::atpos(@candidates, $cur_idx))
                    && $all_native && !nqp::isconcrete($cur_result) {
                        next;
                    }
                    else {
                        $seen_all := !nqp::isconcrete(nqp::atpos(@candidates, $cur_idx));
                        last;
                    }
                }

                # Check if it's admissable by arity.
                if $num_args < nqp::atkey($cur_candidate, 'min_arity')
                || $num_args > nqp::atkey($cur_candidate, 'max_arity') {
                    $cur_idx++;
                    next;
                }
                
                # If we got this far, something at least matched on arity.
                $arity_possible := 1;

                # Check if it's admissable by type.
                $type_check_count := nqp::atkey($cur_candidate, 'num_types') > $num_args
                    ?? $num_args
                    !! nqp::atkey($cur_candidate, 'num_types');
                $type_mismatch := 0;
                $type_match_possible := 1;
                $i := 0;
                while $i < $type_check_count {
                    my $type_obj     := nqp::atpos(nqp::atkey($cur_candidate, 'types'), $i);
                    my $type_flags   := nqp::atpos_i(nqp::atkey($cur_candidate, 'type_flags'), $i);
                    my int $got_prim := nqp::atpos(@flags, $i);
                    if $type_flags +& $TYPE_NATIVE_MASK {
                        # Looking for a natively typed value. Did we get one?
                        if $got_prim == $BIND_VAL_OBJ {
                            # Object; won't do.
                            $type_mismatch := 1;
                            last;
                        }
                        if (($type_flags +& $TYPE_NATIVE_INT) && $got_prim != $BIND_VAL_INT)
                        || (($type_flags +& $TYPE_NATIVE_NUM) && $got_prim != $BIND_VAL_NUM)
                        || (($type_flags +& $TYPE_NATIVE_STR) && $got_prim != $BIND_VAL_STR) {
                            # Mismatch.
                            $type_mismatch := 1;
                            $type_match_possible := 0;
                            last;
                        }
                    }
                    else {
                        # Work out parameter.
                        my $param :=
                            $got_prim == $BIND_VAL_OBJ ?? nqp::atpos(@args, $i) !!
                            $got_prim == $BIND_VAL_INT ?? Int !!
                            $got_prim == $BIND_VAL_NUM ?? Num !!
                                                          Str;
                
                        # If we're here, it's a non-native.
                        $all_native := 0;
                        
                        # Check type. If that doesn't rule it out, then check if it's
                        # got definedness constraints. If it does, note that; if we
                        # match but depend on definedness constraints we can't do
                        # any more.
                        if !nqp::eqaddr($type_obj, Mu) && !nqp::istype($param, $type_obj) {
                            $type_mismatch := 1;
                            
                            # We didn't match, but that doesn't mean we cannot at
                            # runtime (e.g. the most we know about the type could
                            # be that it's Any, but at runtime that feasibly could
                            # be Int). In some cases we never could though (Str
                            # passed to an Int parameter).
                            if !nqp::istype($type_obj, $param) {
                                $type_match_possible := 0;
                            }
                        }
                        elsif $type_flags +& $DEFCON_MASK {
                            $used_defcon := 1;
                        }
                    }
                    $i++;
                }
                if $type_match_possible {
                    $type_possible := 1;
                }
                if $type_mismatch {
                    $cur_idx++;
                    next;
                }
                if ($used_defcon) {
                    return [$MD_CT_NOT_SURE, NQPMu];
                }

                # If it's possible but needs a bind check, we're not going to be
                # able to decide it. */
                if nqp::existskey($cur_candidate, 'bind_check') {
                    return [$MD_CT_NOT_SURE, NQPMu];
                }

                # If we get here, it's the result. Well, unless we already had one,
                # in which case we're in bother 'cus we don't know how to disambiguate
                # at compile time.
                if nqp::isconcrete($cur_result) {
                    return [$MD_CT_NOT_SURE, NQPMu];
                }
                else {
                    $cur_result := nqp::atkey($cur_candidate, 'sub');
                    $cur_idx++;
                }
            }
            
            # If we saw all the candidates, and got no result, and the arity never
            # matched or when it did there was no way any candidates could get
            # passed matching types, then we know it would never work.
            if $seen_all && (!$arity_possible || !$type_possible) && !nqp::isconcrete($cur_result) {
                # Ensure no junctional args before we flag the failure.
                for @args {
                    if nqp::istype($_, Junction) {
                        return [$MD_CT_NOT_SURE, NQPMu];
                    }
                }
                return [$MD_CT_NO_WAY, NQPMu];
            }
            
            # If we got a result, return it.
            if nqp::isconcrete($cur_result) {
                return [$MD_CT_DECIDED, $cur_result];
            }

            # Otherwise, dunno...we'll have to find out at runtime.
            return [$MD_CT_NOT_SURE, NQPMu];
        }));
    Routine.HOW.add_method(Routine, 'set_rw', nqp::getstaticcode(sub ($self) {
            my $dcself := nqp::decont($self);
            nqp::bindattr_i($dcself, Routine, '$!rw', 1);
            $dcself
        }));
    Routine.HOW.add_method(Routine, 'set_inline_info', nqp::getstaticcode(sub ($self, $info) {
            my $dcself := nqp::decont($self);
            nqp::bindattr($dcself, Routine, '$!inline_info', $info);
            $dcself
        }));
    Routine.HOW.add_method(Routine, 'inline_info', nqp::getstaticcode(sub ($self) {
            my $dcself := nqp::decont($self);
            nqp::getattr($dcself, Routine, '$!inline_info')
        }));
    Routine.HOW.add_method(Routine, 'set_onlystar', nqp::getstaticcode(sub ($self) {
            my $dcself := nqp::decont($self);
            nqp::bindattr_i($dcself, Routine, '$!onlystar', 1);
            $dcself
        }));
    Routine.HOW.compose_repr(Routine);
    Routine.HOW.compose_invocation(Routine);

    # class Sub is Routine {
    Sub.HOW.add_parent(Sub, Routine);
    Sub.HOW.compose_repr(Sub);
    Sub.HOW.compose_invocation(Sub);

    # class Method is Routine {
    Method.HOW.add_parent(Method, Routine);
    Method.HOW.compose_repr(Method);
    Method.HOW.compose_invocation(Method);

    # class Submethod is Routine {
    Submethod.HOW.add_parent(Submethod, Routine);
    Submethod.HOW.compose_repr(Submethod);
    Submethod.HOW.compose_invocation(Submethod);

    # class Regex is Method {
    #     has Mu $!caps;
    #     has Mu $!nfa;
    #     has Mu $!alt_nfas
    Regex.HOW.add_parent(Regex, Method);
    Regex.HOW.add_attribute(Regex, scalar_attr('$!caps', Mu, Regex));
    Regex.HOW.add_attribute(Regex, scalar_attr('$!nfa', Mu, Regex));
    Regex.HOW.add_attribute(Regex, scalar_attr('$!alt_nfas', Mu, Regex));
    Regex.HOW.add_method(Regex, 'SET_CAPS', nqp::getstaticcode(sub ($self, $caps) {
            nqp::bindattr(nqp::decont($self), Regex, '$!caps', $caps)
        }));
    Regex.HOW.add_method(Regex, 'SET_NFA', nqp::getstaticcode(sub ($self, $nfa) {
            nqp::bindattr(nqp::decont($self), Regex, '$!nfa', $nfa)
        }));
    Regex.HOW.add_method(Regex, 'SET_ALT_NFA', nqp::getstaticcode(sub ($self, str $name, $nfa) {
            my %alts := nqp::getattr(nqp::decont($self), Regex, '$!alt_nfas');
            unless %alts {
                %alts := nqp::hash();
                nqp::bindattr(nqp::decont($self), Regex, '$!alt_nfas', %alts);
            }
            nqp::bindkey(%alts, $name, $nfa);
        }));
    Regex.HOW.add_method(Regex, 'CAPS', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self), Regex, '$!caps')
        }));
    Regex.HOW.add_method(Regex, 'NFA', nqp::getstaticcode(sub ($self) {
            nqp::getattr(nqp::decont($self), Regex, '$!nfa')
        }));
    Regex.HOW.add_method(Regex, 'ALT_NFA', nqp::getstaticcode(sub ($self, str $name) {
            nqp::atkey(
                nqp::getattr(nqp::decont($self), Regex, '$!alt_nfas'),
                $name)
        }));
    Regex.HOW.compose_repr(Regex);
    Regex.HOW.compose_invocation(Regex);

    # class Str is Cool {
    #     has str $!value is box_target;
    Str.HOW.add_parent(Str, Cool);
    Str.HOW.add_attribute(Str, BOOTSTRAPATTR.new(:name<$!value>, :type(str), :box_target(1), :package(Str)));
    Str.HOW.set_boolification_mode(Str, 4);
    Str.HOW.publish_boolification_spec(Str);
#?if parrot
    Str.HOW.add_parrot_vtable_mapping(Str, 'get_string',
        nqp::getstaticcode(sub ($self) {
            nqp::unbox_s($self)
        }));
#?endif
    Str.HOW.compose_repr(Str);

    # class Int is Cool {
    #     has bigint $!value is box_target;
    Int.HOW.add_parent(Int, Cool);
    Int.HOW.add_attribute(Int, BOOTSTRAPATTR.new(:name<$!value>, :type(bigint), :box_target(1), :package(Int)));
    Int.HOW.set_boolification_mode(Int, 6);
    Int.HOW.publish_boolification_spec(Int);
    Int.HOW.compose_repr(Int);

    # class Num is Cool {
    #     has num $!value is box_target;
    Num.HOW.add_parent(Num, Cool);
    Num.HOW.add_attribute(Num, BOOTSTRAPATTR.new(:name<$!value>, :type(num), :box_target(1), :package(Num)));
    Num.HOW.set_boolification_mode(Num, 2);
    Num.HOW.publish_boolification_spec(Num);
    Num.HOW.compose_repr(Num);

    # class Parcel is Cool {
    #     has Mu $!storage;    # VM's array of Parcel's elements
    Parcel.HOW.add_parent(Parcel, Cool);
    Parcel.HOW.add_attribute(Parcel, scalar_attr('$!storage', Mu, Parcel));
    Parcel.HOW.compose_repr(Parcel);

    # class Iterable is Any {
    Iterable.HOW.add_parent(Iterable, Any);
    Iterable.HOW.compose_repr(Iterable);

    # class Iterator is Iterable {
    Iterator.HOW.add_parent(Iterator, Iterable);
    Iterator.HOW.compose_repr(Iterator);

    # class Nil is Iterator {
    Nil.HOW.add_parent(Nil, Iterator);
    Nil.HOW.compose_repr(Nil);
    
    # class ListIter is Iterator {
    #     has Mu $!reified;
    #     has Mu $!nextiter;
    #     has Mu $!rest;
    #     has Mu $!list;
    ListIter.HOW.add_parent(ListIter, Iterator);
    ListIter.HOW.add_attribute(ListIter, scalar_attr('$!reified', Mu, ListIter));
    ListIter.HOW.add_attribute(ListIter, scalar_attr('$!nextiter', Mu, ListIter));
    ListIter.HOW.add_attribute(ListIter, scalar_attr('$!rest', Mu, ListIter));
    ListIter.HOW.add_attribute(ListIter, scalar_attr('$!list', Mu, ListIter));
    ListIter.HOW.compose_repr(ListIter);
    
    # class List is Iterable is Cool {
    #     has Mu $!items;
    #     has Mu $!flattens;
    #     has Mu $!nextiter;
    List.HOW.add_parent(List, Iterable);
    List.HOW.add_parent(List, Cool);
    List.HOW.add_attribute(List, scalar_attr('$!items', Mu, List));
    List.HOW.add_attribute(List, scalar_attr('$!flattens', Mu, List));
    List.HOW.add_attribute(List, scalar_attr('$!nextiter', Mu, List));
    List.HOW.compose_repr(List);

    # class Array is List {
    #     has Mu $!descriptor;
    Array.HOW.add_parent(Array, List);
    Array.HOW.add_attribute(Array, BOOTSTRAPATTR.new(:name<$!descriptor>, :type(Mu), :package(Array)));
    Array.HOW.compose_repr(Array);

    # class LoL is List {
    #     has Mu $!descriptor;
    LoL.HOW.add_parent(LoL, List);
    LoL.HOW.add_attribute(LoL, BOOTSTRAPATTR.new(:name<$!descriptor>, :type(Mu), :package(LoL)));
    LoL.HOW.compose_repr(LoL);

    # my class EnumMap is Iterable is Cool {
    #     has Mu $!storage;
    EnumMap.HOW.add_parent(EnumMap, Iterable);
    EnumMap.HOW.add_parent(EnumMap, Cool);
    EnumMap.HOW.add_attribute(EnumMap, scalar_attr('$!storage', Mu, EnumMap, :associative_delegate));
    EnumMap.HOW.compose_repr(EnumMap);

    # my class Hash is EnumMap {
    #     has Mu $!descriptor;
    Hash.HOW.add_parent(Hash, EnumMap);
    Hash.HOW.add_attribute(Hash, BOOTSTRAPATTR.new(:name<$!descriptor>, :type(Mu), :package(Hash)));
    Hash.HOW.compose_repr(Hash);

    # class Capture is Any {
    #     has Mu $!list;
    #     has Mu $!hash;
    Capture.HOW.add_parent(Capture, Any);
    Capture.HOW.add_attribute(Capture, BOOTSTRAPATTR.new(:name<$!list>, :type(Mu), :package(Capture)));
    Capture.HOW.add_attribute(Capture, BOOTSTRAPATTR.new(:name<$!hash>, :type(Mu), :package(Capture)));
    Capture.HOW.compose_repr(Capture);
    
    # class Junction is Mu {
    #     has Mu $!storage;
    #     has Mu $!type;
    Junction.HOW.add_parent(Junction, Mu);
    Junction.HOW.add_attribute(Junction, scalar_attr('$!storage', Mu, Junction));
    Junction.HOW.add_attribute(Junction, scalar_attr('$!type', Mu, Junction));
    Junction.HOW.compose_repr(Junction);
    
    # class Bool is Cool {
    #     has int $!value;
    Bool.HOW.add_parent(Bool, Cool);
    Bool.HOW.add_attribute(Bool, BOOTSTRAPATTR.new(:name<$!value>, :type(int), :box_target(1), :package(Bool)));
    Bool.HOW.set_boolification_mode(Bool, 1);
    Bool.HOW.publish_boolification_spec(Bool);
    Bool.HOW.compose_repr(Bool);

    # class ObjAt is Any {
    #     has str $!value;
    ObjAt.HOW.add_parent(ObjAt, Any);
    ObjAt.HOW.add_attribute(ObjAt, BOOTSTRAPATTR.new(:name<$!value>, :type(str), :box_target(1), :package(ObjAt)));
    ObjAt.HOW.compose_repr(ObjAt);
    
    # class ForeignCode {
    #     has Mu $!do;                # Code object we delegate to
    ForeignCode.HOW.add_parent(ForeignCode, Any);
    ForeignCode.HOW.add_attribute(ForeignCode, BOOTSTRAPATTR.new(:name<$!do>, :type(Mu), :package(ForeignCode)));
    ForeignCode.HOW.compose_repr(ForeignCode);
    ForeignCode.HOW.set_invocation_attr(ForeignCode, ForeignCode, '$!do');
    ForeignCode.HOW.compose_invocation(ForeignCode);

    # Set up Stash type, which is really just a hash.
    # class Stash is Hash {
    Stash.HOW.add_parent(Stash, Hash);
    Stash.HOW.compose_repr(Stash);

    # Set this Stash type for the various types of package.
    Perl6::Metamodel::PackageHOW.set_stash_type(Stash, EnumMap);
    Perl6::Metamodel::ModuleHOW.set_stash_type(Stash, EnumMap);
    Perl6::Metamodel::NativeHOW.set_stash_type(Stash, EnumMap);
    Perl6::Metamodel::ClassHOW.set_stash_type(Stash, EnumMap);
    Perl6::Metamodel::GrammarHOW.set_stash_type(Stash, EnumMap);
    Perl6::Metamodel::ParametricRoleHOW.set_stash_type(Stash, EnumMap);
    Perl6::Metamodel::ParametricRoleGroupHOW.set_stash_type(Stash, EnumMap);

    # Give everything we've set up so far a Stash.
    Perl6::Metamodel::ClassHOW.add_stash(Mu);
    Perl6::Metamodel::ClassHOW.add_stash(Any);
    Perl6::Metamodel::ClassHOW.add_stash(Cool);
    Perl6::Metamodel::ClassHOW.add_stash(Attribute);
    Perl6::Metamodel::ClassHOW.add_stash(Signature);
    Perl6::Metamodel::ClassHOW.add_stash(Parameter);
    Perl6::Metamodel::ClassHOW.add_stash(Code);
    Perl6::Metamodel::ClassHOW.add_stash(Block);
    Perl6::Metamodel::ClassHOW.add_stash(Routine);
    Perl6::Metamodel::ClassHOW.add_stash(Sub);
    Perl6::Metamodel::ClassHOW.add_stash(Method);
    Perl6::Metamodel::ClassHOW.add_stash(Str);
    Perl6::Metamodel::ClassHOW.add_stash(Int);
    Perl6::Metamodel::ClassHOW.add_stash(Num);
    Perl6::Metamodel::ClassHOW.add_stash(Scalar);
    Perl6::Metamodel::ClassHOW.add_stash(Bool);
    Perl6::Metamodel::ClassHOW.add_stash(Stash);
    Perl6::Metamodel::ClassHOW.add_stash(List);
    Perl6::Metamodel::ClassHOW.add_stash(Array);
    Perl6::Metamodel::ClassHOW.add_stash(Hash);
    Perl6::Metamodel::ClassHOW.add_stash(ObjAt);
    Perl6::Metamodel::ClassHOW.add_stash(ForeignCode);

    # Default invocation behavior delegates off to postcircumfix:<( )>.
    my $invoke_forwarder :=
        nqp::getstaticcode(sub ($self, *@pos, *%named) {
            if !nqp::isconcrete($self) && !nqp::can($self, 'postcircumfix:<( )>') {
                my $coercer_name := $self.HOW.name($self);
                nqp::die("Cannot coerce to $coercer_name with named parameters")
                  if +%named;
                if +@pos == 1 {
                    @pos[0]."$coercer_name"()
                }
                else {
                    my $parcel := nqp::create(Parcel);
                    nqp::bindattr($parcel, Parcel, '$!storage', @pos);
                    $parcel."$coercer_name"()
                }
            }
            else {
                my $c := nqp::create(Capture);
                nqp::bindattr($c, Capture, '$!list', @pos);
                nqp::bindattr($c, Capture, '$!hash', %named);
                $self.postcircumfix:<( )>($c);
            }
        });
    Mu.HOW.set_invocation_handler(Mu, $invoke_forwarder);
    Mu.HOW.compose_invocation(Mu);

    # If we don't already have a PROCESS, set it up.
    my $PROCESS := nqp::gethllsym('perl6', 'PROCESS');
    if nqp::isnull($PROCESS) {
        PROCESS.HOW.compose(PROCESS);
        Perl6::Metamodel::ModuleHOW.add_stash(PROCESS);
        $PROCESS := PROCESS;
        nqp::bindhllsym('perl6', 'PROCESS', $PROCESS);
    }

    # Bool::False and Bool::True.
    my $false := nqp::create(Bool);
    nqp::bindattr_i($false, Bool, '$!value', 0);
    (Bool.WHO) := $false;
    my $true := nqp::create(Bool);
    nqp::bindattr_i($true, Bool, '$!value', 1);
    (Bool.WHO) := $true;

    # Setup some regexy/grammary bits.
    Perl6::Metamodel::ClassHOW.add_stash(Grammar);
    Grammar.HOW.compose_repr(Grammar);

    # Export the metamodel bits to a Metamodel namespace so it's available
    # from user land.
    Perl6::Metamodel::PackageHOW.add_stash(Metamodel);
    for Perl6::Metamodel.WHO {
        (Metamodel.WHO){$_.key} := $_.value;
    }

    # Fill out EXPORT namespace.
    EXPORT::DEFAULT.WHO        := Mu;
    EXPORT::DEFAULT.WHO       := Any;
    EXPORT::DEFAULT.WHO      := Cool;
    EXPORT::DEFAULT.WHO       := Nil;
    EXPORT::DEFAULT.WHO := Attribute;
    EXPORT::DEFAULT.WHO := Signature;
    EXPORT::DEFAULT.WHO := Parameter;
    EXPORT::DEFAULT.WHO      := Code;
    EXPORT::DEFAULT.WHO     := Block;
    EXPORT::DEFAULT.WHO   := Routine;
    EXPORT::DEFAULT.WHO       := Sub;
    EXPORT::DEFAULT.WHO    := Method;
    EXPORT::DEFAULT.WHO := Submethod;
    EXPORT::DEFAULT.WHO     := Regex;
    EXPORT::DEFAULT.WHO       := Str;
    EXPORT::DEFAULT.WHO       := Int;
    EXPORT::DEFAULT.WHO       := Num;
    EXPORT::DEFAULT.WHO    := Parcel;  
    EXPORT::DEFAULT.WHO  := Iterable;
    EXPORT::DEFAULT.WHO  := Iterator;
    EXPORT::DEFAULT.WHO  := ListIter;
    EXPORT::DEFAULT.WHO      := List;
    EXPORT::DEFAULT.WHO     := Array;
    EXPORT::DEFAULT.WHO       := LoL;
    EXPORT::DEFAULT.WHO   := EnumMap;
    EXPORT::DEFAULT.WHO      := Hash;
    EXPORT::DEFAULT.WHO   := Capture;
    EXPORT::DEFAULT.WHO     := ObjAt;
    EXPORT::DEFAULT.WHO     := Stash;
    EXPORT::DEFAULT.WHO    := Scalar;
    EXPORT::DEFAULT.WHO     := Proxy;
    EXPORT::DEFAULT.WHO   := Grammar;
    EXPORT::DEFAULT.WHO  := Junction;
    EXPORT::DEFAULT.WHO   := $PROCESS;
    EXPORT::DEFAULT.WHO      := Bool;
    EXPORT::DEFAULT.WHO     := $false;
    EXPORT::DEFAULT.WHO      := $true;
    EXPORT::DEFAULT.WHO := Perl6::Metamodel::ContainerDescriptor;
    EXPORT::DEFAULT.WHO    := Perl6::Metamodel::MethodDispatcher;
    EXPORT::DEFAULT.WHO     := Perl6::Metamodel::MultiDispatcher;
    EXPORT::DEFAULT.WHO      := Perl6::Metamodel::WrapDispatcher;
    EXPORT::DEFAULT.WHO           := Metamodel;
    EXPORT::DEFAULT.WHO         := ForeignCode;
}
EXPORT::DEFAULT.WHO := NQPCursorRole;

#?if parrot
# Publish Parrot v-table handler mappings.
Mu.HOW.publish_parrot_vtable_mapping(Mu);
Attribute.HOW.publish_parrot_vtable_mapping(Attribute);
Code.HOW.publish_parrot_vtable_handler_mapping(Code);
Code.HOW.publish_parrot_vtable_mapping(Code);
Block.HOW.publish_parrot_vtable_handler_mapping(Block);
Block.HOW.publish_parrot_vtable_mapping(Block);
Routine.HOW.publish_parrot_vtable_handler_mapping(Routine);
Routine.HOW.publish_parrot_vtable_mapping(Routine);
Sub.HOW.publish_parrot_vtable_handler_mapping(Sub);
Sub.HOW.publish_parrot_vtable_mapping(Sub);
Method.HOW.publish_parrot_vtable_handler_mapping(Method);
Method.HOW.publish_parrot_vtable_mapping(Method);
Submethod.HOW.publish_parrot_vtable_handler_mapping(Submethod);
Submethod.HOW.publish_parrot_vtable_mapping(Submethod);
Regex.HOW.publish_parrot_vtable_handler_mapping(Regex);
Regex.HOW.publish_parrot_vtable_mapping(Regex);
Stash.HOW.publish_parrot_vtable_handler_mapping(Stash);
Str.HOW.publish_parrot_vtable_handler_mapping(Str);
#?endif

# Set up various type mappings.
nqp::p6settypes(EXPORT::DEFAULT.WHO);

# Tell parametric role groups how to create a dispatcher.
Perl6::Metamodel::ParametricRoleGroupHOW.set_selector_creator({
    my $sel := nqp::create(Sub);
    my $onlystar := sub (*@pos, *%named) {
        nqp::invokewithcapture(
            nqp::getcodeobj(nqp::curcode()).find_best_dispatchee(nqp::usecapture()),
            nqp::usecapture())
    };
    nqp::setcodeobj($onlystar, $sel);
    nqp::bindattr($sel, Code, '$!do', $onlystar);
    nqp::bindattr($sel, Routine, '$!dispatchees', []);
    $sel
});

# Roles pretend to be narrower than certain types for the purpose
# of type checking. Also, they pun to classes.
Perl6::Metamodel::ParametricRoleGroupHOW.pretend_to_be([Cool, Any, Mu]);
Perl6::Metamodel::ParametricRoleGroupHOW.configure_punning(
    Perl6::Metamodel::ClassHOW,
    hash( ACCEPTS => Mu, item => Mu ));
Perl6::Metamodel::ParametricRoleHOW.pretend_to_be([Cool, Any, Mu]);
Perl6::Metamodel::ParametricRoleHOW.configure_punning(
    Perl6::Metamodel::ClassHOW,
    hash( ACCEPTS => Mu, item => Mu ));
Perl6::Metamodel::CurriedRoleHOW.pretend_to_be([Cool, Any, Mu]);
Perl6::Metamodel::CurriedRoleHOW.configure_punning(
    Perl6::Metamodel::ClassHOW,
    hash( ACCEPTS => Mu, item => Mu ));
    
# Similar for packages and modules, but just has methods from Any.
Perl6::Metamodel::PackageHOW.pretend_to_be([Any, Mu]);
Perl6::Metamodel::PackageHOW.delegate_methods_to(Any);
Perl6::Metamodel::ModuleHOW.pretend_to_be([Any, Mu]);
Perl6::Metamodel::ModuleHOW.delegate_methods_to(Any);

# Let ClassHOW and EnumHOW know about the invocation handler.
Perl6::Metamodel::ClassHOW.set_default_invoke_handler(
    Mu.HOW.invocation_handler(Mu));
Perl6::Metamodel::EnumHOW.set_default_invoke_handler(
    Mu.HOW.invocation_handler(Mu));

# Set this Stash type for the various types of package (not persisted as it ends
# up in a lexical...)
Perl6::Metamodel::PackageHOW.set_stash_type(Stash, EnumMap);
Perl6::Metamodel::ModuleHOW.set_stash_type(Stash, EnumMap);
Perl6::Metamodel::NativeHOW.set_stash_type(Stash, EnumMap);
Perl6::Metamodel::ClassHOW.set_stash_type(Stash, EnumMap);
Perl6::Metamodel::GrammarHOW.set_stash_type(Stash, EnumMap);
Perl6::Metamodel::ParametricRoleHOW.set_stash_type(Stash, EnumMap);
Perl6::Metamodel::ParametricRoleGroupHOW.set_stash_type(Stash, EnumMap);

# Register default parent types.
Perl6::Metamodel::ClassHOW.set_default_parent_type(Any);
Perl6::Metamodel::GrammarHOW.set_default_parent_type(Grammar);

# Put PROCESS in place.
nqp::bindhllsym('perl6', 'PROCESS', PROCESS);

# HLL configuration: interop, boxing and exit handling.
nqp::sethllconfig('perl6', nqp::hash(
    'int_box', Int,
    'num_box', Num,
    'str_box', Str,
    'null_value', Mu,
    'foreign_type_int', Int,
    'foreign_type_num', Num,
    'foreign_type_str', Str,
    'foreign_transform_array', -> $array {
        nqp::p6parcel($array, Mu)
    },
    'foreign_transform_hash', -> $hash {
        my $result := nqp::create(Hash);
        nqp::bindattr($result, EnumMap, '$!storage', $hash);
        $result
    },
    'foreign_transform_code', -> $code {
        my $result := nqp::create(ForeignCode);
        nqp::bindattr($result, ForeignCode, '$!do', $code);
        $result
    },
#?if !parrot
    'exit_handler', -> $coderef, $resultish {
        my $code := nqp::getcodeobj($coderef);
        my %phasers := nqp::getattr($code, Block, '$!phasers');
        unless nqp::isnull(%phasers) || nqp::p6inpre() {
            my @leaves := nqp::atkey(%phasers, '!LEAVE-ORDER');
            my @keeps  := nqp::atkey(%phasers, 'KEEP');
            my @undos  := nqp::atkey(%phasers, 'UNDO');
            unless nqp::isnull(@leaves) {
                my int $n := nqp::elems(@leaves);
                my int $i := 0;
                my int $run;
                my $phaser;
                while $i < $n {
                    $phaser := nqp::decont(nqp::atpos(@leaves, $i));
                    $run := 1;
                    unless nqp::isnull(@keeps) {
                        for @keeps {
                            if nqp::decont($_) =:= $phaser {
                                $run := !nqp::isnull($resultish) && 
                                         nqp::isconcrete($resultish) &&
                                         $resultish.defined;
                                last;
                            }
                        }
                    }
                    unless nqp::isnull(@undos) {
                        for @undos {
                            if nqp::decont($_) =:= $phaser {
                                $run := nqp::isnull($resultish) ||
                                        !nqp::isconcrete($resultish) ||
                                        !$resultish.defined;
                                last;
                            }
                        }
                    }
                    if $run {
                        $phaser();
                    }
                    $i++;
                }
            }
            
            my @posts := nqp::atkey(%phasers, 'POST');
            unless nqp::isnull(@posts) {
                my int $n := nqp::elems(@posts);
                my int $i := 0;
                while $i < $n {
                    nqp::atpos(@posts, $i)(nqp::ifnull($resultish, Mu));
                    $i++;
                }
            }
        }
    }
#?endif
));

#?if jvm
# On JVM, set up JVM interop bits.
nqp::gethllsym('perl6', 'JavaModuleLoader').set_interop_loader(-> {
    nqp::jvmrakudointerop()
});
Perl6::Metamodel::JavaHOW.pretend_to_be([Any, Mu]);
#?endif
rakudo-2013.12/src/Perl6/Metamodel/BUILDPLAN.nqp0000664000175000017500000000615112242026101020314 0ustar  moritzmoritzrole Perl6::Metamodel::BUILDPLAN {
    has @!BUILDALLPLAN;
    has @!BUILDPLAN;
    
    # Creates the plan for building up the object. This works
    # out what we'll need to do up front, so we can just zip
    # through the "todo list" each time we need to make an object.
    # The plan is an array of arrays. The first element of each
    # nested array is an "op" representing the task to perform:
    #   0 code = call specified BUILD method
    #   1 class name attr_name = try to find initialization value
    #   2 class name attr_name = try to find initialization value, or set nqp::list()
    #   3 class name attr_name = try to find initialization value, or set nqp::hash()
    #   4 class attr_name code = call default value closure if needed
    #   5 class name attr_name = set a native int attribute
    #   6 class name attr_name = set a native num attribute
    #   7 class name attr_name = set a native str attribute
    method create_BUILDPLAN($obj) {
        # First, we'll create the build plan for just this class.
        my @plan;
        my @attrs := $obj.HOW.attributes($obj, :local(1));
        
        # Does it have its own BUILD?
        my $build := $obj.HOW.find_method($obj, 'BUILD', :no_fallback(1));
        if !nqp::isnull($build) && $build {
            # We'll call the custom one.
            @plan[+@plan] := [0, $build];
        }
        else {
            # No custom BUILD. Rather than having an actual BUILD
            # in Mu, we produce ops here per attribute that may
            # need initializing.
            for @attrs {
                if $_.has_accessor {
                    my $attr_name := $_.name;
                    my $name      := nqp::substr($attr_name, 2);
                    my $typespec  := nqp::objprimspec($_.type);
                    if $typespec == 1 || $typespec == 2 || $typespec == 3 {
                        @plan[+@plan] :=  [nqp::add_i(4, $typespec),
                                              $obj, $name, $attr_name];
                    } else {
                        @plan[+@plan] :=  [1, $obj, $name, $attr_name];
                    }
                }
            }
        }
        
        # Check if there's any default values to put in place.
        for @attrs {
            if nqp::can($_, 'build') {
                my $default := $_.build;
                if !nqp::isnull($default) && $default {
                    @plan[+@plan] := [4, $obj, $_.name, $default];
                }
            }
        }
        
        # Install plan for this class.
        @!BUILDPLAN := @plan;
        
        # Now create the full plan by getting the MRO, and working from
        # least derived to most derived, copying the plans.
        my @all_plan;
        my @mro := self.mro($obj);
        my $i := +@mro;
        while $i > 0 {
            $i := $i - 1;
            my $class := @mro[$i];
            for $class.HOW.BUILDPLAN($class) {
                nqp::push(@all_plan, $_);
            }
        }
        @!BUILDALLPLAN := @all_plan;
    }
    
    method BUILDPLAN($obj) {
        @!BUILDPLAN
    }
    
    method BUILDALLPLAN($obj) {
        @!BUILDALLPLAN
    }
}
rakudo-2013.12/src/Perl6/Metamodel/C3MRO.nqp0000664000175000017500000001136612224263172017644 0ustar  moritzmoritzrole Perl6::Metamodel::C3MRO {
    # Storage of the MRO.
    has @!mro;
    
    # The MRO minus anything that is hidden.
    has @!mro_unhidden;
    
    # Computes C3 MRO.
    method compute_mro($class) {
        my @immediate_parents := $class.HOW.parents($class, :local);

        # Provided we have immediate parents...
        my @result;
        if +@immediate_parents {
            if +@immediate_parents == 1 {
                @result := nqp::clone(@immediate_parents[0].HOW.mro(@immediate_parents[0]));
            } else {
                # Build merge list of lineraizations of all our parents, add
                # immediate parents and merge.
                my @merge_list;
                for @immediate_parents {
                    @merge_list.push($_.HOW.mro($_));
                }
                @merge_list.push(@immediate_parents);
                @result := self.c3_merge(@merge_list);
            }
        }

        # Put this class on the start of the list, and we're done.
        @result.unshift($class);
        @!mro := @result;
        
        # Also compute the unhidden MRO (all the things in the MRO that
        # are not somehow hidden).
        my @unhidden;
        my @hidden;
        for @result -> $c {
            unless nqp::can($c.HOW, 'hidden') && $c.HOW.hidden($c) {
                my $is_hidden := 0;
                for @hidden {
                    if nqp::decont($c) =:= nqp::decont($_) {
                        $is_hidden := 1;
                    }
                }
                nqp::push(@unhidden, $c) unless $is_hidden;
            }
            if nqp::can($c.HOW, 'hides') {
                for $c.HOW.hides($c) {
                    nqp::push(@hidden, $_);
                }
            }
        }
        @!mro_unhidden := @unhidden;
        
        @!mro
    }

    # C3 merge routine.
    method c3_merge(@merge_list) {
        my @result;
        my $accepted;
        my $something_accepted := 0;
        my $cand_count := 0;

        # Try to find something appropriate to add to the MRO.
        for @merge_list {
            my @cand_list := $_;
            if +@cand_list {
                my $rejected := 0;
                my $cand_class := @cand_list[0];
                $cand_count := $cand_count + 1;
                for @merge_list {
                    # Skip current list.
                    unless $_ =:= @cand_list {
                        # Is current candidate in the tail? If so, reject.
                        my $cur_pos := 1;
                        while $cur_pos <= +$_ {
                            if nqp::decont($_[$cur_pos]) =:= nqp::decont($cand_class) {
                                $rejected := 1;
                            }
                            $cur_pos := $cur_pos + 1;
                        }
                    }

                }
                # If we didn't reject it, this candidate will do.
                unless $rejected {
                    $accepted := $cand_class;
                    $something_accepted := 1;
                    last;
                }
            }
        }

        # If we never found any candidates, return an empty list.
        if $cand_count == 0 {
            return @result;
        }

        # If we didn't find anything to accept, error.
        unless $something_accepted {
            nqp::die("Could not build C3 linearization: ambiguous hierarchy");
        }

        # Otherwise, remove what was accepted from the merge lists.
        my $i := 0;
        while $i < +@merge_list {
            my @new_list;
            for @merge_list[$i] {
                unless nqp::decont($_) =:= nqp::decont($accepted) {
                    @new_list.push($_);
                }
            }
            @merge_list[$i] := @new_list;
            $i := $i + 1;
        }

        # Need to merge what remains of the list, then put what was accepted on
        # the start of the list, and we're done.
        @result := self.c3_merge(@merge_list);
        @result.unshift($accepted);
        return @result;
    }

    # Introspects the Method Resolution Order.
    method mro($obj) {
        my @result := @!mro;
        if +@result {
            @result
        }
        else {
            # Never computed before; do it best we can so far (and it will
            # be finalized at compose time).
            self.compute_mro($obj)
        }
    }
    
    # Introspects the Method Resolution Order without anything that has
    # been hidden.
    method mro_unhidden($obj) {
        my @result := @!mro_unhidden;
        if +@result {
            @result
        }
        else {
            # Never computed before; do it best we can so far (and it will
            # be finalized at compose time).
            self.compute_mro($obj);
            @!mro_unhidden
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ClassHOW.nqp0000664000175000017500000002056112224263172020441 0ustar  moritzmoritzclass Perl6::Metamodel::ClassHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Documenting
    does Perl6::Metamodel::Versioning
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::AttributeContainer
    does Perl6::Metamodel::MethodContainer
    does Perl6::Metamodel::PrivateMethodContainer
    does Perl6::Metamodel::MultiMethodContainer
    does Perl6::Metamodel::RoleContainer
    does Perl6::Metamodel::MultipleInheritance
    does Perl6::Metamodel::DefaultParent
    does Perl6::Metamodel::C3MRO
    does Perl6::Metamodel::MROBasedMethodDispatch
    does Perl6::Metamodel::MROBasedTypeChecking
    does Perl6::Metamodel::Trusting
    does Perl6::Metamodel::BUILDPLAN
    does Perl6::Metamodel::Mixins
    does Perl6::Metamodel::ArrayType
    does Perl6::Metamodel::BoolificationProtocol
    does Perl6::Metamodel::REPRComposeProtocol
    does Perl6::Metamodel::InvocationProtocol
#?if parrot
    does Perl6::Metamodel::ParrotInterop
#?endif
{
    has @!roles;
    has @!role_typecheck_list;
    has @!concretizations;
    has @!fallbacks;
    has $!composed;

    my $archetypes := Perl6::Metamodel::Archetypes.new(
        :nominal(1), :inheritable(1), :augmentable(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }

    method new_type(:$name = '', :$repr = 'P6opaque', :$ver, :$auth) {
        my $metaclass := self.new();
        my $obj := nqp::settypehll(nqp::newtype($metaclass, $repr), 'perl6');
        self.add_stash($obj);
        $metaclass.set_name($obj, $name);
        $metaclass.set_ver($obj, $ver) if $ver;
        $metaclass.set_auth($obj, $auth) if $auth;
        nqp::setboolspec($obj, 5, nqp::null());
        $obj
    }
    
    method parameterize($obj, *@pos_args, *%named_args) {
        # XXX This mechanism may well change. For now we pass these along
        # to a PARAMETERIZE_TYPE method on the object if it has one. If
        # not, we complain.
        if nqp::can($obj, 'PARAMETERIZE_TYPE') {
            $obj.PARAMETERIZE_TYPE(|@pos_args, |%named_args)
        }
        else {
            nqp::die("Type " ~ self.name($obj) ~ " cannot accept type arguments")
        }
    }
    
    # Adds a new fallback for method dispatch. Expects the specified
    # condition to have been met (passes it the object and method name),
    # and if it is calls $calculator with the object and method name to
    # calculate an invokable object.
    method add_fallback($obj, $condition, $calculator) {
        # Adding a fallback means any method cache is no longer authoritative.
        nqp::setmethcacheauth($obj, 0);
        
        # Add it.
        my %desc;
        %desc := $condition;
        %desc := $calculator;
        @!fallbacks[+@!fallbacks] := %desc;
    }

    method compose($obj) {
        # Instantiate all of the roles we have (need to do this since
        # all roles are generic on ::?CLASS) and pass them to the
        # composer.
        my @roles_to_compose := self.roles_to_compose($obj);
        if @roles_to_compose {
            my @ins_roles;
            while @roles_to_compose {
                my $r := @roles_to_compose.pop();
                @!roles[+@!roles] := $r;
                @!role_typecheck_list[+@!role_typecheck_list] := $r;
                my $ins := $r.HOW.specialize($r, $obj);
                @ins_roles.push($ins);
                nqp::push(@!concretizations, [$r, $ins]);
            }
            self.compute_mro($obj); # to the best of our knowledge, because the role applier wants it.
            RoleToClassApplier.apply($obj, @ins_roles);
            
            # Add them to the typecheck list, and pull in their
            # own type check lists also.
            for @ins_roles {
                @!role_typecheck_list[+@!role_typecheck_list] := $_;
                for $_.HOW.role_typecheck_list($_) {
                    @!role_typecheck_list[+@!role_typecheck_list] := $_;
                }
            }
        }

        # Some things we only do if we weren't already composed once, like
        # building the MRO.
        my $was_composed := $!composed;
        unless $!composed {
            if self.parents($obj, :local(1)) == 0 && self.has_default_parent_type && self.name($obj) ne 'Mu' {
                self.add_parent($obj, self.get_default_parent_type);
            }
            self.compute_mro($obj);
            $!composed := 1;
        }

        # Incorporate any new multi candidates (needs MRO built).
        self.incorporate_multi_candidates($obj);

        # Compose attributes.
        self.compose_attributes($obj);
        
        # See if we have a Bool method other than the one in the top type.
        # If not, all it does is check if we have the type object.
        unless self.get_boolification_mode($obj) != 0 {
            my $i := 0;
            my @mro := self.mro($obj);
            while $i < +@mro {
                my %meths := @mro[$i].HOW.method_table(@mro[$i]);
                if nqp::existskey(%meths, 'Bool') {
                    last;
                }
                $i := $i + 1;
            }
            if $i + 1 == +@mro {
                self.set_boolification_mode($obj, 5)
            }
        }

        # Publish type and method caches.
        self.publish_type_cache($obj);
        self.publish_method_cache($obj);
        self.publish_boolification_spec($obj);
        
#?if parrot
        # Install Parrot v-table mappings.
        self.publish_parrot_vtable_mapping($obj);
		self.publish_parrot_vtable_handler_mapping($obj);
#?endif

        # Create BUILDPLAN.
        self.create_BUILDPLAN($obj);
        
        # Compose the representation, unless we already did so once.
        unless $was_composed {
            self.compose_repr($obj);
        }
        
        # Compose invocation protocol.
        self.compose_invocation($obj);

        $obj
    }
    
    method roles($obj, :$local, :$transitive) {
        my @result;
        for @!roles {
            @result.push($_);
            if $transitive {
                for $_.HOW.roles($_, :transitive(1)) {
                    @result.push($_);
                }
            }
        }
        unless $local {
            my $first := 1;
            for self.mro($obj) {
                if $first {
                    $first := 0;
                    next;
                }
                for $_.HOW.roles($_, :transitive($transitive), :local(1)) {
                    @result.push($_);
                }
            }
        }
        @result
    }
    
    method role_typecheck_list($obj) {
        @!role_typecheck_list
    }
    
    method concretization($obj, $ptype) {
        for @!concretizations {
            if nqp::decont($_[0]) =:= nqp::decont($ptype) {
                return $_[1];
            }
        }
        nqp::die("No concretization found for " ~ $ptype.HOW.name($ptype));
    }
    
    method is_composed($obj) {
        $!composed
    }
    
    # Maybe this belongs on a role. Also, may be worth memoizing.
    method can($obj, $name) {
        my @meths;
        for self.mro($obj) {
            my %mt := $_.HOW.method_table($_);
            if nqp::existskey(%mt, $name) {
                @meths.push(%mt{$name})
            }
        }
        @meths
    }
    
    # Stuff for junctiony dispatch fallback.
    my $junction_type;
    my $junction_autothreader;
    method setup_junction_fallback($type, $autothreader) {
        nqp::setmethcacheauth($type, 0);
        $junction_type := $type;
        $junction_autothreader := $autothreader;
    }
    
    # Handles the various dispatch fallback cases we have.
    method find_method_fallback($obj, $name) {
        # If the object is a junction, need to do a junction dispatch.
        if $obj.WHAT =:= $junction_type && $junction_autothreader {
            my $p6name := nqp::hllizefor($name, 'perl6');
            return -> *@pos_args, *%named_args {
                $junction_autothreader($p6name, |@pos_args, |%named_args)
            };
        }
        
        # Consider other fallbacks, if we have any.
        for @!fallbacks {
            if ($_)($obj, $name) {
                return ($_)($obj, $name);
            }
        }

        # Otherwise, didn't find anything.
        nqp::null()
    }
    
    # Does the type have any fallbacks?
    method has_fallbacks($obj) {
        return nqp::istype($obj, $junction_type) || +@!fallbacks;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ConcreteRoleHOW.nqp0000664000175000017500000000704712224263172021764 0ustar  moritzmoritzclass Perl6::Metamodel::ConcreteRoleHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Versioning
    does Perl6::Metamodel::PrivateMethodContainer
    does Perl6::Metamodel::MethodContainer
    does Perl6::Metamodel::MultiMethodContainer
    does Perl6::Metamodel::AttributeContainer
    does Perl6::Metamodel::RoleContainer
    does Perl6::Metamodel::MultipleInheritance
    does Perl6::Metamodel::ArrayType
{
    # Any collisions to resolve.
    has @!collisions;
    
    # The (parametric) role(s) that this concrete one was directly derived
    # from.
    has @!roles;
    
    # Full flat list of done roles.
    has @!role_typecheck_list;
    
    # Are we composed yet?
    has $!composed;

    my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    my class Collision {
        has $!name;
        has @!roles;
        has $!private;
        method name() { $!name }
        method roles() { @!roles }
        method private() { $!private }
    }
    
    method new_type(:@roles, :$name = '', :$ver, :$auth, :$repr) {
        my $metarole := self.new(:roles(@roles));
        my $obj := nqp::settypehll(nqp::newtype($metarole, 'Uninstantiable'), 'perl6');
        $metarole.set_name($obj, $name);
        $metarole.set_ver($obj, $ver) if $ver;
        $metarole.set_auth($obj, $auth) if $auth;
        $obj;
    }
    
    method add_collision($obj, $colliding_name, @role_names, :$private = 0) {
        @!collisions[+@!collisions] := Collision.new(
            :name($colliding_name), :roles(@role_names), :private($private)
        );
    }

    method compose($obj) {
        RoleToRoleApplier.apply($obj, self.roles_to_compose($obj));
        for self.roles_to_compose($obj) {
            @!role_typecheck_list[+@!role_typecheck_list] := $_;
            for $_.HOW.role_typecheck_list($_) {
                @!role_typecheck_list[+@!role_typecheck_list] := $_;
            }
        }
        for @!roles {
            @!role_typecheck_list[+@!role_typecheck_list] := $_;
            for $_.HOW.role_typecheck_list($_) {
                @!role_typecheck_list[+@!role_typecheck_list] := $_;
            }
        }
        self.publish_type_cache($obj);
        $!composed := 1;
        $obj
    }
    
    method is_composed($obj) {
        $!composed ?? 1 !! 0
    }
    
    method collisions($obj) {
        @!collisions
    }
    
    method roles($obj, :$transitive) {
        if $transitive {
            my @trans;
            for @!roles {
                @trans.push($_);
                for $_.HOW.roles($_) {
                    @trans.push($_);
                }
            }
        }
        else {
            @!roles
        }
    }
    
    method add_to_role_typecheck_list($obj, $type) {
        @!role_typecheck_list[+@!role_typecheck_list] := $type;
    }
    
    method role_typecheck_list($obj) {
        @!role_typecheck_list
    }
    
    method type_check($obj, $checkee) {
        my $decont := nqp::decont($checkee);
        if $decont =:= $obj.WHAT {
            return 1;
        }
        for @!role_typecheck_list {
            if nqp::decont($_) =:= $decont {
                return 1;
            }
        }
        0
    }
    
    method publish_type_cache($obj) {
        my @types := [$obj.WHAT];
        for @!role_typecheck_list { @types.push($_) }
        nqp::settypecache($obj, @types)
    }
    
    method mro($obj) {
        [$obj]
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ContainerDescriptor.nqp0000664000175000017500000000200012224263172022763 0ustar  moritzmoritzclass Perl6::Metamodel::ContainerDescriptor {
    has     $!of;
    has int $!rw;
    has str $!name;
    has     $!default;
    has int $!dynamic;
    
    method BUILD(:$of, :$rw, :$name, :$default, :$dynamic) {
        $!of := $of;
        $!rw := $rw;
        $!name := $name;
        $!default := $default;
        $!dynamic := $dynamic;
    }
    
    method of() { $!of }
    method rw() { $!rw }
    method name() { $!name }
    method default() { $!default }
    method dynamic() { $!dynamic }
    
    method set_of($of) { $!of := $of }
    method set_rw($rw) { $!rw := $rw }
    method set_default($default) { $!default := $default }
    method set_dynamic($dynamic) { $!dynamic := $dynamic }
    
    method is_generic() {
        $!of.HOW.archetypes.generic
    }
    
    method instantiate_generic($type_environment) {
        my $ins_of := $!of.HOW.instantiate_generic($!of, $type_environment);
        my $ins := nqp::clone(self);
        nqp::bindattr($ins, $?CLASS, '$!of', $ins_of);
        $ins
    }
}
rakudo-2013.12/src/Perl6/Metamodel/CurriedRoleHOW.nqp0000664000175000017500000001216212224263172021611 0ustar  moritzmoritz# Sometimes, we see references to roles that provide parameters but
# do not fully resolve them. For example, in:
# 
#   class C does R[T] { }
#
# We need to represent R[T], but we cannot yet fully specialize the
# role because we don't have the first parameter to hand. We may also
# run into the issue where we have things like:
# 
#   sub foo(R[T] $x) { ... }
#   if $x ~~ R[T] { ... }
# 
# Where we clearly want to talk about a partial parameterization of a
# role and actually want to do so in a way distinct from a particular
# instantiation of it. This meta-object represents those "partial types"
# as both a way to curry on your way to a full specialization, but also
# as a way to do type-checking or punning.
class Perl6::Metamodel::CurriedRoleHOW
    does Perl6::Metamodel::RolePunning
    does Perl6::Metamodel::TypePretense
{
    has $!curried_role;
    has @!pos_args;
    has %!named_args;
    has $!name;

    my $archetypes_g := Perl6::Metamodel::Archetypes.new( :composable(1), :inheritalizable(1), :parametric(1), :generic(1) );
    my $archetypes_ng := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
    method archetypes() {
        if nqp::isconcrete(self) {
            for @!pos_args {
                if $_.HOW.archetypes.generic {
                    return $archetypes_g;
                }
            }
            for %!named_args {
                if $_.value.HOW.archetypes.generic {
                    return $archetypes_g;
                }
            }
        }
        $archetypes_ng
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    method new_type($curried_role, *@pos_args, *%named_args) {
        # construct a name
        my $name := $curried_role.HOW.name($curried_role);
        if @pos_args {
            my @pieces := nqp::list_s();
            for @pos_args {
                nqp::push_s(@pieces, $_.HOW.name($_));
            }
            $name := $name ~ "[" ~ nqp::join(",", @pieces) ~ "]";
        }

        my $meta := self.new(:curried_role($curried_role), :pos_args(@pos_args),
            :named_args(%named_args), :name($name));
        my $type := nqp::settypehll(nqp::newtype($meta, 'Uninstantiable'), 'perl6');
        nqp::settypecheckmode($type, 2)
    }
    
    method instantiate_generic($obj, $type_env) {
        my @new_pos;
        my %new_named;
        for @!pos_args {
            @new_pos.push($_.HOW.archetypes.generic ??
                $_.HOW.instantiate_generic($_, $type_env) !!
                $_);
        }
        for %!named_args {
            %new_named{$_.key} := $_.value.HOW.archetypes.generic ??
                $_.value.HOW.instantiate_generic($_.value, $type_env) !!
                $_.value;
        }
        self.new_type($!curried_role, |@new_pos, |%new_named)
    }
    
    method specialize($obj, $first_arg) {
        $!curried_role.HOW.specialize($!curried_role, $first_arg,
            |@!pos_args, |%!named_args);
    }
    
    method name($obj) {
        $!name
    }
    
    method curried_role($obj) {
        $!curried_role
    }
    
    method role_arguments($obj) {
        @!pos_args
    }
    
    method roles($obj, :$transitive) {
        $!curried_role.HOW.roles($obj, :transitive($transitive))
    }
    
    method role_typecheck_list($obj) {
        $!curried_role.HOW.role_typecheck_list($obj)
    }
    
    method type_check($obj, $checkee) {
        $!curried_role.HOW.type_check($!curried_role, $checkee)
    }
    
    method accepts_type($obj, $checkee) {
        # First, we locate candidate curryings to check against. If
        # the checkee is itself a curried role, it also goes in. Note
        # that we only want those that have the same parametric role
        # as us.
        my @cands;
        my $crdc := nqp::decont($!curried_role);
        if nqp::istype($checkee.HOW, self.WHAT) {
            if nqp::decont($checkee.HOW.curried_role($checkee)) =:= $crdc {
                @cands.push($checkee);
            }
        }
        if nqp::can($checkee.HOW, 'role_typecheck_list') {
            for $checkee.HOW.role_typecheck_list($checkee) {
                if nqp::istype($_.HOW, self.WHAT) && !$_.HOW.archetypes.generic {
                    if nqp::decont($_.HOW.curried_role($_)) =:= $crdc {
                        @cands.push($_);
                    }
                }
            }
        }
        
        # Provided we have some candidates, check the arguments.
        my $num_args := +@!pos_args;
        if @cands {
            for @cands {
                my @try_args := $_.HOW.role_arguments($_);
                if +@try_args == $num_args {
                    my $i := 0;
                    my $ok := 1;
                    while $i < +$num_args {
                        if !@!pos_args[$i].ACCEPTS(@try_args[$i]) {
                            $ok := 0;
                            $i := $num_args;
                        }
                        $i := $i + 1;
                    }
                    if $ok {
                        return 1;
                    }
                }
            }
        }
        
        0;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/DefaultParent.nqp0000664000175000017500000000051112224263172021545 0ustar  moritzmoritzrole Perl6::Metamodel::DefaultParent {
    my @default_parent_type;
    
    method set_default_parent_type($type) {
        @default_parent_type[0] := $type;
    }
    
    method has_default_parent_type() {
        +@default_parent_type
    }
    
    method get_default_parent_type() {
        @default_parent_type[0]
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Dispatchers.nqp0000664000175000017500000000556012224263172021271 0ustar  moritzmoritzclass Perl6::Metamodel::BaseDispatcher {
    has @!candidates;
    has $!idx;
    
    method candidates() { @!candidates }
    
    method exhausted() { $!idx >= +@!candidates }
    
    method last()      { @!candidates := [] }
    
    method call_with_args(*@pos, *%named) {
        my $call := @!candidates[$!idx];
        $!idx := $!idx + 1;
        if self.has_invocant {
            my $inv := self.invocant;
            nqp::setdispatcher(self);
            $call($inv, |@pos, |%named);
        }
        else {
            nqp::setdispatcher(self);
            $call(|@pos, |%named);
        }
    }
    
    method call_with_capture($capture) {
        my $call := @!candidates[$!idx];
        $!idx := $!idx + 1;
        nqp::setdispatcher(self);
        nqp::invokewithcapture(nqp::decont($call), $capture)
    }
}

class Perl6::Metamodel::MethodDispatcher is Perl6::Metamodel::BaseDispatcher {
    has $!obj;
    
    method vivify_for($sub, $lexpad, $args) {
        my $obj      := $lexpad;
        my $name     := $sub.name;
        my @mro      := nqp::can($obj.HOW, 'mro_unhidden')
            ?? $obj.HOW.mro_unhidden($obj)
            !! $obj.HOW.mro($obj);
        my @methods;
        for @mro {
            my %mt := $_.HOW.method_table($_);
            if nqp::existskey(%mt, $name) {
                @methods.push(%mt{$name});
            }
        }
        self.new(:candidates(@methods), :obj($obj), :idx(1))
    }
    
    method has_invocant() { 1 }
    method invocant()     { $!obj }
}

class Perl6::Metamodel::MultiDispatcher is Perl6::Metamodel::BaseDispatcher {
    has $!has_invocant;
    has $!invocant;
    
    method vivify_for($sub, $lexpad, $args) {
        my $disp         := $sub.dispatcher();
        my $has_invocant := nqp::existskey($lexpad, 'self');
        my $invocant     := $has_invocant && $lexpad;
        my @cands        := $disp.find_best_dispatchee($args, 1);
        self.new(:candidates(@cands), :idx(1), :invocant($invocant),
            :has_invocant($has_invocant))
    }

    method has_invocant() { $!has_invocant }
    method invocant() { $!invocant }
}

class Perl6::Metamodel::WrapDispatcher is Perl6::Metamodel::BaseDispatcher {
    method new() {
        self.bless(:candidates([]), :idx(1))
    }

    method has_invocant() { 0 }
    
    method add($wrapper) {
        self.candidates.unshift($wrapper)
    }
    
    method remove($wrapper) {
        my @cands := self.candidates;
        my $i := 0;
        while $i < +@cands {
            if nqp::decont(@cands[$i]) =:= nqp::decont($wrapper) {
                nqp::splice(@cands, [], $i, 1);
                return 1;
            }
            $i := $i + 1;
        }
        return 0;
    }
    
    method enter(*@pos, *%named) {
        my $fresh := nqp::clone(self);
        my $first := self.candidates[0];
        nqp::setdispatcher($fresh);
        $first(|@pos, |%named)
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Documenting.nqp0000664000175000017500000000023112224263172021262 0ustar  moritzmoritzrole Perl6::Metamodel::Documenting {
    has $!docs;
    method set_docs($new) {
        $!docs := $new
    }
    method docs() {
        $!docs
    }
}
rakudo-2013.12/src/Perl6/Metamodel/EnumHOW.nqp0000664000175000017500000001031112224263172020270 0ustar  moritzmoritz# This is the meta-object for an enumeration (declared with enum).
# It keeps hold of the enumeration values in an EnumMap, which is
# created at composition time. It supports having roles composed in,
# one or two of which presumably provide the core enum-ish methods.
class Perl6::Metamodel::EnumHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::AttributeContainer
    does Perl6::Metamodel::MethodContainer
    does Perl6::Metamodel::MultiMethodContainer
    does Perl6::Metamodel::RoleContainer
    does Perl6::Metamodel::BaseType
    does Perl6::Metamodel::MROBasedMethodDispatch
    does Perl6::Metamodel::MROBasedTypeChecking
    does Perl6::Metamodel::BUILDPLAN
    does Perl6::Metamodel::BoolificationProtocol
    does Perl6::Metamodel::REPRComposeProtocol
    does Perl6::Metamodel::InvocationProtocol
#?if parrot
    does Perl6::Metamodel::ParrotInterop
#?endif
{
    # Hash representing enumeration keys to values.
    has %!values;
    
    # Reverse mapping hash.
    has %!value_to_enum;
    
    # List of enum values (actual enum objects).
    has @!enum_value_list;
    
    # Roles that we do.
    has @!does_list;
    
    # Role'd version of the enum.
    has $!role;
    has int $!roled;
    
    # Are we composed yet?
    has $!composed;

    my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composalizable(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    method new_type(:$name!, :$base_type!) {
        my $meta := self.new();
        my $obj  := nqp::settypehll(nqp::newtype($meta, 'P6opaque'), 'perl6');
        $meta.set_name($obj, $name);
        $meta.set_base_type($meta, $base_type);
        self.add_stash($obj);
    }
    
    method add_enum_value($obj, $value) {
        %!values{nqp::unbox_s($value.key)} := $value.value;
        @!enum_value_list[+@!enum_value_list] := $value;
    }
    
    method enum_values($obj) {
        %!values
    }
    
    method enum_from_value($obj, $value) {
        unless %!value_to_enum {
            for @!enum_value_list {
                %!value_to_enum{$_.value} := $_;
            }
        }
        nqp::existskey(%!value_to_enum, $value)
            ?? %!value_to_enum{$value}
            !! $obj.WHAT;
    }
    
    method enum_value_list($obj) {
        @!enum_value_list
    }
    
    method compose($obj) {
        # Instantiate all of the roles we have (need to do this since
        # all roles are generic on ::?CLASS) and pass them to the
        # composer.
        my @roles_to_compose := self.roles_to_compose($obj);
        if @roles_to_compose {
            my @ins_roles;
            while @roles_to_compose {
                my $r := @roles_to_compose.pop();
                @ins_roles.push($r.HOW.specialize($r, $obj))
            }
            @!does_list := RoleToClassApplier.apply($obj, @ins_roles)
        }
        
        # Incorporate any new multi candidates (needs MRO built).
        self.incorporate_multi_candidates($obj);

        # Compose attributes.
        for self.attributes($obj, :local) {
            $_.compose($obj);
        }

        # Publish type and method caches.
        self.publish_type_cache($obj);
        self.publish_method_cache($obj);
        
#?if parrot
        # Install Parrot v-table mappings.
        self.publish_parrot_vtable_mapping($obj);
		self.publish_parrot_vtable_handler_mapping($obj);
#?endif
        
        # Publish boolification spec.
        self.publish_boolification_spec($obj);
        
        # Create BUILDPLAN.
        self.create_BUILDPLAN($obj);
        
        # Compose the representation.
        unless $!composed {
            self.compose_repr($obj);
            $!composed := 1;
        }
        
        # Compose invocation protocol.
        self.compose_invocation($obj);

        $obj
    }
    
    my $composalizer;
    method set_composalizer($c) { $composalizer := $c }
    method composalize($obj) {
        unless $!roled {
            $!role := $composalizer($obj, self.name($obj), %!values);
            $!roled := 1;
        }
        $!role
    }
    
    method does_list($obj) {
        @!does_list
    }
}
rakudo-2013.12/src/Perl6/Metamodel/EXPORTHOW.nqp0000664000175000017500000000164212224263172020414 0ustar  moritzmoritz# Bind the HOWs into the EXPORTHOW package under the package declarator
# names.
my module EXPORTHOW {
    ($?PACKAGE.WHO)      := Perl6::Metamodel::PackageHOW;
    ($?PACKAGE.WHO)       := Perl6::Metamodel::ModuleHOW;
    ($?PACKAGE.WHO)      := Perl6::Metamodel::GenericHOW;
    ($?PACKAGE.WHO)        := Perl6::Metamodel::ClassHOW;
    ($?PACKAGE.WHO)   := Attribute;
    ($?PACKAGE.WHO)         := Perl6::Metamodel::ParametricRoleHOW;
    ($?PACKAGE.WHO)    := Attribute;
    ($?PACKAGE.WHO)   := Perl6::Metamodel::ParametricRoleGroupHOW;
    ($?PACKAGE.WHO)      := Perl6::Metamodel::GrammarHOW;
    ($?PACKAGE.WHO) := Attribute;
    ($?PACKAGE.WHO)       := Perl6::Metamodel::NativeHOW;
    ($?PACKAGE.WHO)       := Perl6::Metamodel::SubsetHOW;
    ($?PACKAGE.WHO)         := Perl6::Metamodel::EnumHOW;
}
rakudo-2013.12/src/Perl6/Metamodel/GenericHOW.nqp0000664000175000017500000000251312224263172020745 0ustar  moritzmoritz# A HOW that represents a generic type. It's something of a
# placeholder for a type that we don't actually know yet.
# It sits anywhere that a type could, and possession of one
# of these confers genericity on the holder.
class Perl6::Metamodel::GenericHOW
    does Perl6::Metamodel::Naming
{
    my $archetypes := Perl6::Metamodel::Archetypes.new( :generic(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    # The name we're created with is both the name we'll claim
    # to be if asked, but also the name we'll look up in a
    # supplied type environment when we want to instantiate
    # ourself.
    method new_type(:$name) {
        my $meta := self.new();
        my $obj := nqp::settypehll(nqp::newtype($meta, 'Uninstantiable'), 'perl6');
        $meta.set_name($obj, $name);
        $obj
    }

    method instantiate_generic($obj, $type_environment) {
        my $name := self.name($obj);
        nqp::existskey($type_environment, $name) ?? $type_environment{$name} !! $obj
    }
    
    method compose($obj) {
    }
    
    method find_method($obj, $name) {
        nqp::null()
    }
    
    method type_check($obj, $checkee) {
        nqp::die("Cannot type check against type variable " ~ self.name($obj))
    }
}
rakudo-2013.12/src/Perl6/Metamodel/GrammarHOW.nqp0000664000175000017500000000016212224263172020755 0ustar  moritzmoritzclass Perl6::Metamodel::GrammarHOW
    is Perl6::Metamodel::ClassHOW
    does Perl6::Metamodel::DefaultParent
{
}
rakudo-2013.12/src/Perl6/Metamodel/InvocationProtocol.nqp0000664000175000017500000000474512224263172022657 0ustar  moritzmoritzrole Perl6::Metamodel::InvocationProtocol {
    has int $!has_invocation_attr;
    has $!invocation_attr_class;
    has str $!invocation_attr_name;
    
    has int $!has_invocation_handler;
    has $!invocation_handler;
    
    my $default_invoke_handler;
    method set_default_invoke_handler($h) {
        $default_invoke_handler := $h;
    }
    
    method set_invocation_attr($obj, $class, $name) {
        $!has_invocation_attr   := 1;
        $!invocation_attr_class := $class;
        $!invocation_attr_name  := $name;
    }
    
    method set_invocation_handler($obj, $handler) {
        $!has_invocation_handler := 1;
        $!invocation_handler     := $handler;
    }
    
    method has_invocation_attr($obj) { $!has_invocation_attr }
    method invocation_attr_class($obj) { $!invocation_attr_class }
    method invocation_attr_name($obj) { $!invocation_attr_name }
    
    method has_invocation_handler($obj) { $!has_invocation_handler }
    method invocation_handler($obj) { $!invocation_handler }
    
    method compose_invocation($obj) {
        # Check if we have a postcircumfix:<( )>, and if so install
        # the default invocation forwarder. Otherwise, see if we or
        # a parent has an invocation attr.
        my $pcmeth := self.find_method($obj, 'postcircumfix:<( )>', :no_fallback(1));
        if !nqp::isnull(pcmeth) && nqp::defined($pcmeth) {
            nqp::die('Default invocation handler is not invokable')
                unless nqp::isinvokable($default_invoke_handler);
            nqp::setinvokespec($obj, nqp::null(), nqp::null_s(),
                $default_invoke_handler);
        }
        else {
            for self.mro($obj) -> $class {
                if nqp::can($class.HOW, 'has_invocation_attr') {
                    if $class.HOW.has_invocation_attr($class) {
                        nqp::setinvokespec($obj,
                            $class.HOW.invocation_attr_class($class),
                            $class.HOW.invocation_attr_name($class),
                            nqp::null());
                        last;
                    }
                }
                if nqp::can($class.HOW, 'has_invocation_handler') {
                    if $class.HOW.has_invocation_handler($class) {
                        nqp::setinvokespec($obj,
                            nqp::null(), nqp::null_s(),
                            $class.HOW.invocation_handler($class));
                        last;
                    }
                }
            }
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/MethodContainer.nqp0000664000175000017500000000546412240627044022106 0ustar  moritzmoritzrole Perl6::Metamodel::MethodContainer {
    # Lookup table of the methods.
    has %!methods;
    has %!submethods;

    # The order that the methods were added in.
    has @!method_order;
    
    # Cache that expires when we add methods (primarily to support NFA stuff).
    has %!cache;

    # Add a method.
    method add_method($obj, $name, $code_obj) {

        # We may get Parrot subs in here during BOOTSTRAP; the try is to cope
        # with them.
        my $method_type := "Method";
        try { $method_type := $code_obj.HOW.name($code_obj) };
        
        # Ensure we haven't already got it.
        if nqp::existskey(%!methods, $name) || nqp::existskey(%!submethods, $name) {
            nqp::die("Package '"
              ~ self.name($obj)
              ~ "' already has a "
              ~ $method_type
              ~ " '"
              ~ $name
              ~ "' (did you mean to declare a multi-method?)");
        }
        
        # Add to correct table depending on if it's a Submethod. Note, we
        if $method_type eq 'Submethod' {
            %!submethods{$name} := $code_obj;
        }
        else {
            %!methods{$name} := $code_obj;
        }

        # Adding a method means any cache is no longer authoritative.
        nqp::setmethcacheauth($obj, 0);
        %!cache := {};
        @!method_order[+@!method_order] := $code_obj;
    }

    # Gets the method hierarchy.
    method methods($obj, :$local, :$excl, :$all) {
        # Always need local methods on the list.
        my @meths;
        for @!method_order {
            @meths.push(nqp::hllizefor($_, 'perl6'));
        }

        # If local flag was not passed, include those from parents.
        unless $local {
            for self.parents($obj, :all($all), :excl($excl)) {
                for $_.HOW.method_table($_) {
                    @meths.push(nqp::hllizefor($_.value, 'perl6'));
                }
                for $_.HOW.submethod_table($_) {
                    @meths.push(nqp::hllizefor($_.value, 'perl6'));
                }
            }
        }
        
        # Return result list.
        @meths
    }

    # Get the method table. Only contains methods directly declared here,
    # and excludes submethods.
    method method_table($obj) {
        %!methods
    }
    
    # Gets the submethods table.
    method submethod_table($obj) {
        %!submethods
    }
    
    # Checks if this package (not its parents) declares a given
    # method. Checks submethods also.
    method declares_method($obj, $name) {
        %!methods{$name} || %!submethods{$name} ?? 1 !! 0
    }

    # Caches or updates a cached value.
    method cache($obj, $key, $value_generator) {
        %!cache || (%!cache := {});
        nqp::existskey(%!cache, $key) ??
            %!cache{$key} !!
            (%!cache{$key} := $value_generator())
    }
}
rakudo-2013.12/src/Perl6/Metamodel/MethodDelegation.nqp0000664000175000017500000000051512224263172022227 0ustar  moritzmoritzrole Perl6::Metamodel::MethodDelegation {
    my $delegate_type;
    
    method delegate_methods_to($type) {
        $delegate_type := $type
    }
    
    method delegating_methods_to() {
        $delegate_type
    }
    
    method find_method($obj, $name) {
        $delegate_type.HOW.find_method($delegate_type, $name);
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Mixins.nqp0000664000175000017500000000321212224263172020257 0ustar  moritzmoritzrole Perl6::Metamodel::Mixins {
    has $!is_mixin;
    method set_is_mixin($obj) { $!is_mixin := 1 }
    method is_mixin($obj) { $!is_mixin }
    method flush_cache($obj) { }

    method mixin($obj, *@roles) {
        # Flush its cache as promised, otherwise outdated NFAs will stick around.
        self.flush_cache($obj) if !nqp::isnull($obj) || self.is_mixin($obj);
        # Work out a type name for the post-mixed-in role.
        my @role_names;
        for @roles { @role_names.push(~$_.HOW.name($_)) }
        my $new_name := self.name($obj) ~ '+{' ~
            nqp::join(',', @role_names) ~ '}';
        
        # Create new type, derive it from ourself and then add
        # all the roles we're mixing it.
        my $new_type := self.new_type(:name($new_name), :repr($obj.REPR));
        $new_type.HOW.set_is_mixin($new_type);
        $new_type.HOW.add_parent($new_type, $obj.WHAT);
        for @roles {
            $new_type.HOW.add_role($new_type, $_);
        }
        $new_type.HOW.compose($new_type);
        $new_type.HOW.set_boolification_mode($new_type,
            nqp::existskey($new_type.HOW.method_table($new_type), 'Bool') ?? 0 !!
                self.get_boolification_mode($obj));
        $new_type.HOW.publish_boolification_spec($new_type);
        
        # If the original object was concrete, change its type by calling a
        # low level op. Otherwise, we just return the new type object
        nqp::isconcrete($obj) ?? nqp::rebless($obj, $new_type) !! $new_type
    }
    
    method mixin_base($obj) {
        for self.mro($obj) {
            unless $_.HOW.is_mixin($_) {
                return $_;
            }
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ModuleHOW.nqp0000664000175000017500000000206712224263172020622 0ustar  moritzmoritzclass Perl6::Metamodel::ModuleHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Documenting
    does Perl6::Metamodel::Versioning
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::TypePretense
    does Perl6::Metamodel::MethodDelegation
{
    has $!composed;

    my $archetypes := Perl6::Metamodel::Archetypes.new( );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }

    method new_type(:$name = '', :$repr, :$ver, :$auth) {
        if $repr { nqp::die("'module' does not support custom representations") }
        my $metaclass := self.new();
        my $obj := nqp::settypehll(nqp::newtype($metaclass, 'Uninstantiable'), 'perl6');
        $metaclass.set_name($obj, $name);
        $metaclass.set_ver($obj, $ver) if $ver;
        $metaclass.set_auth($obj, $auth) if $auth;
        self.add_stash($obj);
    }

    method compose($obj) {
        $!composed := 1;
    }
    
    method is_composed($obj) {
        $!composed
    }
}
rakudo-2013.12/src/Perl6/Metamodel/MROBasedMethodDispatch.nqp0000664000175000017500000000422412224263172023231 0ustar  moritzmoritzrole Perl6::Metamodel::MROBasedMethodDispatch {
    # While we normally end up locating methods through the method cache,
    # this is here as a fallback.
    method find_method($obj, $name, :$no_fallback, *%adverbs) {
        my %methods;
        for self.mro($obj) {
            %methods := $_.HOW.method_table($_);
            if nqp::existskey(%methods, $name) {
                return %methods{$name}
            }
        }
        my %submethods := $obj.HOW.submethod_table($obj);
        if nqp::existskey(%submethods, $name) {
            return %submethods{$name}
        }
        !$no_fallback && nqp::can(self, 'find_method_fallback') ??
            self.find_method_fallback($obj, $name) !!
            nqp::null();
    }
    
    method find_method_qualified($obj, $qtype, $name) {
        if $qtype.HOW.archetypes.parametric && nqp::can(self, 'concretization') {
            # Resolve it via the concrete form of this parametric.
            my $conc := self.concretization($obj, $qtype);
            $conc.HOW.method_table($conc){$name}
        }
        else {
            # Non-parametric, so just locate it from the already concrete
            # type (or fallback to this if no .concretization on ourself).
            nqp::findmethod($qtype, $name)
        }
    }
    
    method publish_method_cache($obj) {
        # Walk MRO and add methods to cache, unless another method
        # lower in the class hierarchy "shadowed" it.
        my %cache;
        my @mro_reversed;
        my $authable := 1;
        for self.mro($obj) {
            @mro_reversed.unshift($_);
        }
        for @mro_reversed {
            for $_.HOW.method_table($_) {
                %cache{$_.key} := $_.value;
            }
            if nqp::can($_.HOW, 'is_composed') && !$_.HOW.is_composed($_) {
                $authable := 0;
            }
        }
        
        # Also add submethods.
        for $obj.HOW.submethod_table($obj) {
            %cache{$_.key} := $_.value;
        }
        
        nqp::setmethcache($obj, %cache);
        unless nqp::can(self, 'has_fallbacks') && self.has_fallbacks($obj) {
            nqp::setmethcacheauth($obj, $authable);
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/MROBasedTypeChecking.nqp0000664000175000017500000000235112224263172022705 0ustar  moritzmoritzrole Perl6::Metamodel::MROBasedTypeChecking {
    method isa($obj, $type) {
        my $decont := nqp::decont($type);
        for self.mro($obj) {
            if nqp::decont($_) =:= $decont { return 1 }
        }
        0
    }
    
    method does($obj, $type) {
        nqp::p6bool(nqp::istype($obj, $type))
    }
    
    method type_check($obj, $checkee) {
        # The only time we end up in here is if the type check cache was
        # not yet published, which means the class isn't yet fully composed.
        # Just hunt through MRO.
        for self.mro($obj) {
            if $_ =:= $checkee {
                return 1;
            }
            if nqp::can($_.HOW, 'role_typecheck_list') {
                for $_.HOW.role_typecheck_list($_) {
                    if $_ =:= $checkee {
                        return 1;
                    }
                }
            }
        }
        0
    }
    
    method publish_type_cache($obj) {
        my @tc;
        for self.mro($obj) {
            @tc.push($_);
            if nqp::can($_.HOW, 'role_typecheck_list') {
                for $_.HOW.role_typecheck_list($_) {
                    @tc.push($_);
                }
            }
        }
        nqp::settypecache($obj, @tc)
    }
}
rakudo-2013.12/src/Perl6/Metamodel/MultiMethodContainer.nqp0000664000175000017500000001057712224263172023122 0ustar  moritzmoritzrole Perl6::Metamodel::MultiMethodContainer {
    # Set of multi-methods to incorporate. Not just the method handles;
    # each is a hash containing keys name and body.
    has @!multi_methods_to_incorporate;
    
    # The proto we'll clone.
    my $autogen_proto;
    
    # Sets the proto we'll auto-gen based on.
    method set_autogen_proto($proto) {
        $autogen_proto := $proto
    }

    # We can't incorporate multis right away as we don't know all parents
    # yet, maybe, which influences whether we even can have multis, need to
    # generate a proto and so forth. So just queue them up in a todo list and
    # we handle it at class composition time.
    method add_multi_method($obj, $name, $code_obj) {
        # Represents a multi candidate to incorporate.
        my class MultiToIncorporate {
            has $!name;
            has $!code;
            method name() { $!name }
            method code() { $!code }
        }
        my $how := MultiToIncorporate.HOW.WHAT;
        my $todo := MultiToIncorporate.new( :name($name), :code($code_obj) );
        @!multi_methods_to_incorporate[+@!multi_methods_to_incorporate] := $todo;
        $code_obj;
    }

    # Gets the multi methods that are to be incorporated.
    method multi_methods_to_incorporate($obj) {
        @!multi_methods_to_incorporate
    }
    
    # Incorporates the multi candidates into the appropriate proto. Need to
    # implement proto incorporation yet.
    method incorporate_multi_candidates($obj) {
        my $num_todo := +@!multi_methods_to_incorporate;
        my $i := 0;
        my @new_protos;
        while $i != $num_todo {
            # Get method name and code.
            my $name := @!multi_methods_to_incorporate[$i].name;
            my $code := @!multi_methods_to_incorporate[$i].code;

            # Do we have anything in the methods table already in
            # this class?
            my %meths := self.method_table($obj);
            if nqp::existskey(%meths, $name) {
                # Yes. Only or dispatcher, though? If only, error. If
                # dispatcher, simply add new dispatchee.
                my $dispatcher := %meths{$name};
                if $dispatcher.is_dispatcher {
                    $dispatcher.add_dispatchee($code);
                }
                else {
                    nqp::die("Cannot have a multi candidate for '" ~ $name ~ 
                        "' when an only method is also in the package '" ~
                        self.name($obj) ~ "'");
                }
            }
            else {
                # Go hunting in the MRO for a proto.
                my @mro := self.mro($obj);
                my $j := 1;
                my $found := 0;
                while $j != +@mro && !$found {
                    my $parent := @mro[$j];
                    my %meths := $parent.HOW.method_table($parent);
                    if nqp::existskey(%meths, $name) {
                        # Found a possible - make sure it's a dispatcher, not
                        # an only.
                        my $dispatcher := %meths{$name};
                        if $dispatcher.is_dispatcher {
                            # Clone it and install it in our method table.
                            my $copy := $dispatcher.derive_dispatcher();
                            $copy.add_dispatchee($code);
                            self.add_method($obj, $name, $copy);
                            nqp::push(@new_protos, $copy);
                            $found := 1;
                        }
                    }
                    $j := $j + 1;
                }
                unless $found {
                    # No proto found, so we'll generate one here.
                    unless $autogen_proto {
                        nqp::die("Cannot auto-generate a proto method for '$name' in the setting");
                    }
                    my $proto := $autogen_proto.instantiate_generic(
                        nqp::hash('T', $obj));
                    $proto.set_name($name);
                    $proto.add_dispatchee($code);
                    self.add_method($obj, $name, $proto);
                    nqp::push(@new_protos, $proto);
                }
            }
            $i := $i + 1;
        }
        for @new_protos {
            if nqp::can($_, 'sort_dispatchees') {
                $_.sort_dispatchees();
            }
        }
        @!multi_methods_to_incorporate := [];
    }
}
rakudo-2013.12/src/Perl6/Metamodel/MultipleInheritance.nqp0000664000175000017500000000435312224263172022764 0ustar  moritzmoritzrole Perl6::Metamodel::MultipleInheritance {
    # Array of parents.
    has @!parents;
    
    # Are any of the parents hidden?
    has @!hides;
    
    # Is this class hidden?
    has $!hidden;
    
    # Classes to exclude from the parents list in introspection by default.
    my @excluded;
    method exclude_parent($parent) {
        @excluded.push($parent);
    }

    # Adds a parent.
    method add_parent($obj, $parent, :$hides) {
        if self.is_composed($obj) {
            nqp::die("Parents cannot be added to a class after it has been composed");
        }
        if nqp::decont($parent) =:= nqp::decont($obj) {
            nqp::die("Class " ~ self.name($obj) ~ " cannot inherit from itself");
        }
        for @!parents {
            if nqp::decont($_) =:= nqp::decont($parent) {
                nqp::die("Package '" ~ self.name($obj) ~
                    "' already has parent '" ~
                    $parent.HOW.name($parent) ~ "'");
            }
        }
        if $hides {
            @!hides[+@!hides] := $parent;
        }
        @!parents[+@!parents] := $parent;
    }

    # Introspects the parents.
    method parents($obj, :$local, :$tree, :$excl, :$all) {
        if $local {
            @!parents
        }
        elsif $tree {
            my @result;
            for @!parents {
                my @pt := [$_];
                @pt.push($_.HOW.parents($_, :tree(1)));
                @result.push(nqp::hllizefor(@pt, 'perl6').Array.item);
            }
            return nqp::hllizefor(@result, 'perl6');
        }
        else {
            # All parents is MRO minus the first thing (which is us).
            my @mro := self.mro($obj);
            my @parents;
            my $i := 1;
            while $i < +@mro {
                my $exclude := 0;
                unless $all {
                    for @excluded {
                        $exclude := 1 if @mro[$i] =:= $_;
                    }
                }
                @parents.push(@mro[$i]) unless $exclude;
                $i := $i + 1;
            }
            @parents
        }
    }
    
    method hides($obj) {
        @!hides
    }
    
    method hidden($obj) {
        $!hidden ?? 1 !! 0
    }
    
    method set_hidden($obj) {
        $!hidden := 1;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Naming.nqp0000664000175000017500000000024012224263172020217 0ustar  moritzmoritzrole Perl6::Metamodel::Naming {
    has $!name;
    method set_name($obj, $name) {
        $!name := $name
    }
    method name($obj) {
        $!name
    }
}
rakudo-2013.12/src/Perl6/Metamodel/NativeHOW.nqp0000664000175000017500000000407312224263172020622 0ustar  moritzmoritzclass Perl6::Metamodel::NativeHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Documenting
    does Perl6::Metamodel::Versioning
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::MultipleInheritance    
    does Perl6::Metamodel::C3MRO
    does Perl6::Metamodel::MROBasedMethodDispatch
    does Perl6::Metamodel::MROBasedTypeChecking
{
    has $!nativesize;
    has int $!unsigned;
    has $!composed;

    my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :inheritable(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }

    method new_type(:$name = '', :$repr = 'P6opaque', :$ver, :$auth) {
        my $metaclass := self.new(:nativesize(0));
        my $obj := nqp::settypehll(nqp::newtype($metaclass, $repr), 'perl6');
        $metaclass.set_name($obj, $name);
        $metaclass.set_ver($obj, $ver) if $ver;
        $metaclass.set_auth($obj, $auth) if $auth;
        self.add_stash($obj);
    }

    method compose($obj) {
        self.compute_mro($obj);
        self.publish_method_cache($obj);
        self.publish_type_cache($obj);
        if !$!composed && $!nativesize {
            my $info := nqp::hash();
            $info := nqp::hash();
            $info := nqp::unbox_i($!nativesize);
            $info := 1 if $!unsigned;
            $info := nqp::hash();
            $info := nqp::unbox_i($!nativesize);
            nqp::composetype($obj, $info);
        }
        $!composed := 1;
    }
    
    method is_composed($obj) {
        $!composed
    }
    
    method set_nativesize($obj, $nativesize) {
        $!nativesize := $nativesize;
    }
    
    method nativesize($obj) {
        $!nativesize
    }
    
    method set_unsigned($obj, $unsigned) {
        $!unsigned := $unsigned ?? 1 !! 0
    }
    
    method unsigned($obj) {
        $!unsigned
    }
    
    method method_table($obj) { nqp::hash() }
    method submethod_table($obj) { nqp::hash() }
}
rakudo-2013.12/src/Perl6/Metamodel/PackageHOW.nqp0000664000175000017500000000167712224263172020736 0ustar  moritzmoritzclass Perl6::Metamodel::PackageHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Documenting
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::TypePretense
    does Perl6::Metamodel::MethodDelegation
{
    has $!composed;

    my $archetypes := Perl6::Metamodel::Archetypes.new( );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    method new_type(:$name = '', :$repr, :$ver, :$auth) {
        if $repr { nqp::die("'package' does not support custom representations") }
        my $metaclass := nqp::create(self);
        my $obj := nqp::settypehll(nqp::newtype($metaclass, 'Uninstantiable'), 'perl6');
        $metaclass.set_name($obj, $name);
        self.add_stash($obj);
    }
    
    method compose($obj) {
        $!composed := 1;
    }
    
    method is_composed($obj) {
        $!composed
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ParametricRoleGroupHOW.nqp0000664000175000017500000000736612242026101023317 0ustar  moritzmoritz# This represents a group of parametric roles. For example, given
# we have the declarations:
# 
#   role Foo[] { } # (which is same as role Foo { })
#   role Foo[::T] { }
#   role Foo[::T1, ::T2] { }
# 
# Each of them results in a type object that has a HOW of type
# Perl6::Metamodel::ParametricRoleHOW. In here, we keep the whole
# group of those, and know how to specialize to a certain parameter
# list by multi-dispatching over the set of possibilities to pick
# a particular candidate.
class Perl6::Metamodel::ParametricRoleGroupHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::TypePretense
    does Perl6::Metamodel::RolePunning
    does Perl6::Metamodel::BoolificationProtocol
{
    has @!possibilities;
    has @!add_to_selector;
    has $!selector;
    has @!role_typecheck_list;

    my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    my $selector_creator;
    method set_selector_creator($sc) {
        $selector_creator := $sc;
    }

    method new_type(:$name!, :$repr) {
        my $meta := self.new(:selector($selector_creator()));
        my $type_obj := self.add_stash(nqp::settypehll(
            nqp::newtype($meta, 'Uninstantiable'), 'perl6'));
        $meta.set_name($type_obj, $name);
        $meta.set_pun_repr($meta, $repr) if $repr;
        $meta.set_boolification_mode($type_obj, 5);
        $meta.publish_boolification_spec($type_obj);
        $type_obj
    }
    
    method parameterize($obj, *@pos_args, *%named_args) {
        my $curried := $currier.new_type($obj, |@pos_args, |%named_args);
        $curried.HOW.set_pun_repr($curried, self.pun_repr($obj));
        $curried
    }
    
    method add_possibility($obj, $possible) {
        @!possibilities[+@!possibilities] := $possible;
        @!add_to_selector[+@!add_to_selector] := $possible;
        self.update_role_typecheck_list($obj);
    }
    
    method specialize($obj, *@pos_args, *%named_args) {
        # Locate correct parametric role and type environment.
        my $error;
        my @result;
        try {
            @result := (self.get_selector($obj))(|@pos_args, |%named_args);
            CATCH { $error := $! }
        }
        if $error {
            nqp::die("None of the parametric role variants for '" ~
                self.name($obj) ~ "' matched the arguments supplied.\n" ~
                $error);
        }
        
        # Having picked the appropraite one, specialize it.
        my $prole := @result[0];
        my $type_env := @result[1];
        $prole.HOW.specialize_with($prole, $type_env, @pos_args)
    }
    
    method get_selector($obj) {
        if @!add_to_selector {
            for @!add_to_selector {
                $!selector.add_dispatchee($_.HOW.body_block($_));
            }
            @!add_to_selector := [];
        }
        $!selector
    }
    
    method update_role_typecheck_list($obj) {
        for @!possibilities {
            if !$_.HOW.signatured($_) {
                @!role_typecheck_list := $_.HOW.role_typecheck_list($_);
            }
        }
    }
    
    method role_typecheck_list($obj) {
        @!role_typecheck_list
    }
    
    method type_check($obj, $checkee) {
        my $decont := nqp::decont($checkee);
        if $decont =:= $obj.WHAT {
            return 1;
        }
        for self.pretending_to_be() {
            if $decont =:= nqp::decont($_) {
                return 1;
            }
        }
        for @!role_typecheck_list {
            if $decont =:= nqp::decont($_) {
                return 1;
            }
        }
        0;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ParametricRoleHOW.nqp0000664000175000017500000001527512242026101022300 0ustar  moritzmoritzmy $concrete := Perl6::Metamodel::ConcreteRoleHOW;
my $currier := Perl6::Metamodel::CurriedRoleHOW;
class Perl6::Metamodel::ParametricRoleHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Documenting
    does Perl6::Metamodel::Versioning
    does Perl6::Metamodel::MethodContainer
    does Perl6::Metamodel::PrivateMethodContainer
    does Perl6::Metamodel::MultiMethodContainer
    does Perl6::Metamodel::AttributeContainer
    does Perl6::Metamodel::RoleContainer
    does Perl6::Metamodel::MultipleInheritance
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::TypePretense
    does Perl6::Metamodel::RolePunning
    does Perl6::Metamodel::ArrayType
{
    has $!composed;
    has $!body_block;
    has $!in_group;
    has $!group;
    has $!signatured;
    has @!role_typecheck_list;

    my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }

    method new_type(:$name = '', :$ver, :$auth, :$repr, :$signatured, *%extra) {
        my $metarole := self.new(:signatured($signatured));
        my $type := nqp::settypehll(nqp::newtype($metarole, 'Uninstantiable'), 'perl6');
        $metarole.set_name($type, $name);
        $metarole.set_ver($type, $ver) if $ver;
        $metarole.set_auth($type, $auth) if $auth;
        $metarole.set_pun_repr($type, $repr) if $repr;
        if nqp::existskey(%extra, 'group') {
            $metarole.set_group($type, %extra);
        }
        self.add_stash($type);
    }
    
    method parameterize($obj, *@pos_args, *%named_args) {
        $currier.new_type($obj, |@pos_args, |%named_args)
    }
    
    method set_body_block($obj, $block) {
        $!body_block := $block
    }
    
    method body_block($obj) {
        $!body_block
    }
    
    method signatured($obj) {
        $!signatured
    }
    
    method set_group($obj, $group) {
        $!group := $group;
        $!in_group := 1;
    }
    
    method group($obj) {
        $!in_group ?? $!group !! $obj
    }
    
    method compose($obj) {
        my @rtl;
        if $!in_group {
            @rtl.push($!group);
        }
        for self.roles_to_compose($obj) {
            @rtl.push($_);
            for $_.HOW.role_typecheck_list($_) {
                @rtl.push($_);
            }
        }
        @!role_typecheck_list := @rtl;
        $!composed := 1;
        $obj
    }
    
    method is_composed($obj) {
        $!composed
    }
    
    method roles($obj, :$transitive) {
        if $transitive {
            my @result;
            for self.roles_to_compose($obj) {
                @result.push($_);
                for $_.HOW.roles($_, :transitive(1)) {
                    @result.push($_)
                }
            }
            @result
        }
        else {
            self.roles_to_compose($obj)
        }
    }
    
    method role_typecheck_list($obj) {
        @!role_typecheck_list
    }
    
    method type_check($obj, $checkee) {
        my $decont := nqp::decont($checkee);
        if $decont =:= $obj.WHAT {
            return 1;
        }
        if $!in_group && $decont =:= $!group {
            return 1;
        }
        for self.pretending_to_be() {
            if $decont =:= nqp::decont($_) {
                return 1;
            }
        }
        for self.roles_to_compose($obj) {
            if nqp::istype($checkee, $_) {
                return 1;
            }
        }
        0
    }
    
    method specialize($obj, *@pos_args, *%named_args) {
        # Run the body block to get the type environment (we know
        # the role in this csae).
        my $type_env;
        my $error;
        try {
            my @result := $!body_block(|@pos_args, |%named_args);
            $type_env := @result[1];
            CATCH {
                $error := $!
            }
        }
        if $error {
            nqp::die("Could not instantiate role '" ~ self.name($obj) ~ "':\n$error")
        }
        
        # Use it to build concrete role.
        self.specialize_with($obj, $type_env, @pos_args)
    }
    
    method specialize_with($obj, $type_env, @pos_args) {
        # Create a concrete role.
        my $conc := $concrete.new_type(:roles([$obj]), :name(self.name($obj)));
        
        # Go through attributes, reifying as needed and adding to
        # the concrete role.
        for self.attributes($obj, :local(1)) {
            $conc.HOW.add_attribute($conc,
                $_.is_generic ?? $_.instantiate_generic($type_env) !! $_);
        }
        
        # Go through methods and instantiate them; we always do this
        # unconditionally, since we need the clone anyway.
        for self.method_table($obj) {
            $conc.HOW.add_method($conc, $_.key, $_.value.instantiate_generic($type_env))
        }
        for self.submethod_table($obj) {
            $conc.HOW.add_method($conc, $_.key, $_.value.instantiate_generic($type_env))
        }
        for self.private_method_table($obj) {
            $conc.HOW.add_private_method($conc, $_.key, $_.value.instantiate_generic($type_env));
        }
        for self.multi_methods_to_incorporate($obj) {
            $conc.HOW.add_multi_method($conc, $_.name, $_.code.instantiate_generic($type_env))
        }
        
        # Roles done by this role need fully specializing also; all
        # they'll be missing is the target class (e.g. our first arg).
        for self.roles_to_compose($obj) {
            my $r := $_;
            if $_.HOW.archetypes.generic {
                $r := $r.HOW.instantiate_generic($r, $type_env);
                $conc.HOW.add_to_role_typecheck_list($conc, $r);
            }
            $conc.HOW.add_role($conc, $r.HOW.specialize($r, @pos_args[0]));
        }
        
        # Pass along any parents that have been added, resolving them in
        # the case they're generic (role Foo[::T] is T { })
        for self.parents($obj, :local(1)) {
            my $p := $_;
            if $_.HOW.archetypes.generic {
                $p := $p.HOW.instantiate_generic($p, $type_env);
            }
            $conc.HOW.add_parent($conc, $p);
        }
        
        # Resolve any array type being passed along (only really used in the
        # punning case, since roles are the way we get generic types).
        if self.is_array_type($obj) {
            my $at := self.array_type($obj);
            if $at.HOW.archetypes.generic {
                $at := $at.HOW.instantiate_generic($at, $type_env);
            }
            $conc.HOW.set_array_type($conc, $at);
        }
        
        $conc.HOW.compose($conc);
        return $conc;
    }
    
    method mro($obj) {
        [$obj]
    }
}
rakudo-2013.12/src/Perl6/Metamodel/ParrotInterop.nqp0000664000175000017500000000511012224263172021617 0ustar  moritzmoritz# Various bits of Parrot interoperability, including vtable overrides and specifying
# that an attribute delegates to a given Parrot vtable.
role Perl6::Metamodel::ParrotInterop {
    # Maps vtable names to vtable method overrides.
    has %!parrot_vtable_mapping;
    
    # Maps vtable names to attributes lookup info, so that an override can work by
    # delegation.
	has %!parrot_vtable_handler_mapping;
    
    method add_parrot_vtable_mapping($obj, $name, $meth) {
        if nqp::defined(%!parrot_vtable_mapping{$name}) {
            nqp::die("Class '" ~ self.name($obj) ~
                "' already has a Parrot v-table override for '" ~
                $name ~ "'");
        }
        %!parrot_vtable_mapping{$name} := $meth;
    }

    method add_parrot_vtable_handler_mapping($obj, $name, $attr_name) {
        if nqp::defined(%!parrot_vtable_handler_mapping{$name}) {
            nqp::die("Class '" ~ self.name($obj) ~
                "' already has a Parrot v-table handler for '" ~
                $name ~ "'");
        }
        %!parrot_vtable_handler_mapping{$name} := [ $obj, $attr_name ];
    }
    
    method publish_parrot_vtable_mapping($obj) {
        my %mapping;
        for self.mro($obj) {
            my %map := $_.HOW.parrot_vtable_mappings($_, :local(1));
            for %map {
                unless nqp::existskey(%mapping, $_.key) {
                    if !nqp::isnull($_.value) && $_.value {
                        %mapping{$_.key} := $_.value;
                    }
                    else {
                        %mapping{$_.key} := nqp::null();
                    }
                }
            }
        }
        if +%mapping {
            pir::stable_publish_vtable_mapping__0PP($obj, %mapping);
        }
    }

    method publish_parrot_vtable_handler_mapping($obj) {
        my %mapping;
        for self.mro($obj) {
            my %map := $_.HOW.parrot_vtable_handler_mappings($_, :local(1));
            for %map {
                unless nqp::existskey(%mapping, $_.key) {
                    if !nqp::isnull($_.value) && $_.value {
                        %mapping{$_.key} := $_.value;
                    }
                    else {
                        %mapping{$_.key} := nqp::null();
                    }
                }
            }
        }
        if +%mapping {
            pir::stable_publish_vtable_handler_mapping__0PP($obj, %mapping);
        }
    }
    
    method parrot_vtable_mappings($obj, :$local!) {
        %!parrot_vtable_mapping
    }

    method parrot_vtable_handler_mappings($obj, :$local!) {
        %!parrot_vtable_handler_mapping
    }
}
rakudo-2013.12/src/Perl6/Metamodel/PrivateMethodContainer.nqp0000664000175000017500000000135712224263172023436 0ustar  moritzmoritzrole Perl6::Metamodel::PrivateMethodContainer {
    has %!private_methods;
    
    # Adds a private method.
    method add_private_method($obj, $name, $code) {
        if nqp::existskey(%!private_methods, $name) {
            nqp::die("Private method '$name' already declared in package " ~
                self.name($obj));
        }
        %!private_methods{$name} := $code;
    }
    
    # Gets the table of private methods.
    method private_method_table($obj) {
        %!private_methods
    }
    
    # Locates a private method, and hands back null if it doesn't exist.
    method find_private_method($obj, $name) {
        nqp::existskey(%!private_methods, $name) ??
            %!private_methods{$name} !!
            nqp::null()
    }
}
rakudo-2013.12/src/Perl6/Metamodel/REPRComposeProtocol.nqp0000664000175000017500000000524712224263172022642 0ustar  moritzmoritzrole Perl6::Metamodel::REPRComposeProtocol {
    has $!composed_repr;
    
    method compose_repr($obj) {
        unless $!composed_repr {
            # Is it an array type?
            if nqp::can(self, 'is_array_type') && self.is_array_type($obj) {
                if self.attributes($obj) {
                    nqp::die("Cannot have attributes on an array representation");
                }
                nqp::composetype($obj, nqp::hash('array',
                    nqp::hash('type', nqp::decont(self.array_type($obj)))));
            }
            
            # Otherwise, presume it's an attribute type.
            else {
                # Use any attribute information to produce attribute protocol
                # data. The protocol consists of an array...
                my @repr_info;
                
                # ...which contains an array per MRO entry...
                for self.mro($obj) -> $type_obj {
                    my @type_info;
                    nqp::push(@repr_info, @type_info);
        
                    # ...which in turn contains the current type in the MRO...
                    nqp::push(@type_info, $type_obj);
                
                    # ...then an array of hashes per attribute...
                    my @attrs;
                    nqp::push(@type_info, @attrs);
                    for $type_obj.HOW.attributes($type_obj, :local) -> $attr {
                        my %attr_info;
                        %attr_info := $attr.name;
                        %attr_info := $attr.type;
                        if $attr.box_target {
                            # Merely having the key serves as a "yes".
                            %attr_info := 1;
                        }
                        if nqp::can($attr, 'auto_viv_container') {
                            %attr_info := $attr.auto_viv_container;
                        }
                        if $attr.positional_delegate {
                            %attr_info := 1;
                        }
                        if $attr.associative_delegate {
                            %attr_info := 1;
                        }
                        nqp::push(@attrs, %attr_info);
                    }
                
                    # ...followed by a list of immediate parents.
                    nqp::push(@type_info, $type_obj.HOW.parents($type_obj, :local));
                }
                
                # Compose the representation using it.
                nqp::composetype($obj, nqp::hash('attribute', @repr_info));
            }
            
            $!composed_repr := 1;
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/RoleContainer.nqp0000664000175000017500000000036612224263172021563 0ustar  moritzmoritzrole Perl6::Metamodel::RoleContainer {
    has @!roles_to_compose;
    
    method add_role($obj, $role) {
        @!roles_to_compose[+@!roles_to_compose] := $role
    }
    
    method roles_to_compose($obj) {
        @!roles_to_compose
    }
}
rakudo-2013.12/src/Perl6/Metamodel/RolePunning.nqp0000664000175000017500000000333512224263172021256 0ustar  moritzmoritzrole Perl6::Metamodel::RolePunning {
    # Meta-object we use to make a pun.
    my $pun_meta;
    
    # Exceptions to the punning. Hash of name to actual object to call on.
    my %exceptions;
    
    # The pun for the current meta-object.
    has $!pun;
    
    # Did we make a pun?
    has $!made_pun;
    
    # Representation to pun to, if any.
    has str $!pun_repr;
    
    # Configures the punning.
    method configure_punning($my_pun_meta, %my_exceptions) {
        $pun_meta := $my_pun_meta;
        %exceptions := %my_exceptions;
    }
    
    method set_pun_repr($obj, $repr) {
        $!pun_repr := $repr
    }
    
    method pun_repr($obj) {
        $!pun_repr
    }
    
    # Produces the pun.
    method make_pun($obj) {
        my $pun := $!pun_repr
            ?? $pun_meta.new_type(:name(self.name($obj)), :repr($!pun_repr))
            !! $pun_meta.new_type(:name(self.name($obj)));
        $pun.HOW.add_role($pun, $obj);
        $pun.HOW.compose($pun);
        $pun
    }
    
    # Produces something that can be inherited from (the pun).
    method inheritalize($obj) {
        unless $!made_pun {
            $!pun := self.make_pun($obj);
            $!made_pun := 1;
        }
        $!pun
    }
    
    # Do a pun-based dispatch. If we pun, return a thunk that will delegate.
    method find_method($obj, $name) {
        if nqp::existskey(%exceptions, $name) {
            return nqp::findmethod(%exceptions{$name}, $name);
        }
        unless $!made_pun {
            $!pun := self.make_pun($obj);
            $!made_pun := 1;
        }
        unless nqp::can($!pun, $name) {
            return nqp::null();
        }
        -> $inv, *@pos, *%named {
            $!pun."$name"(|@pos, |%named)
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/RoleToClassApplier.nqp0000664000175000017500000001315512224263172022526 0ustar  moritzmoritzmy class RoleToClassApplier {
    sub has_method($target, $name, $local) {
        if $local {
            my %mt := $target.HOW.method_table($target);
            return 1 if nqp::existskey(%mt, $name);
            %mt := $target.HOW.submethod_table($target);
            return nqp::existskey(%mt, $name);
        }
        else {
            for $target.HOW.mro($target) {
                my %mt := $_.HOW.method_table($_);
                if nqp::existskey(%mt, $name) {
                    return 1;
                }
                %mt := $_.HOW.submethod_table($_);
                if nqp::existskey(%mt, $name) {
                    return 1;
                }
            }
            return 0;
        }
    }
    
    sub has_private_method($target, $name) {
        my %pmt := $target.HOW.private_method_table($target);
        return nqp::existskey(%pmt, $name)
    }

    sub has_attribute($target, $name) {
        my @attributes := $target.HOW.attributes($target, :local(1));
        for @attributes {
            if $_.name eq $name { return 1; }
        }
        return 0;
    }
    sub has_public_attribute($target, $name) {
        my @attributes := $target.HOW.attributes($target, :local(1));
        for @attributes {
            return 1 if nqp::substr($_.name, 2) eq $name && $_.has_accessor;
        }
        return 0;
    }

    method apply($target, @roles) {
        # If we have many things to compose, then get them into a single helper
        # role first.
        my $to_compose;
        my $to_compose_meta;
        if +@roles == 1 {
            $to_compose := @roles[0];
            $to_compose_meta := $to_compose.HOW;
        }
        else {
            $to_compose := $concrete.new_type();
            $to_compose_meta := $to_compose.HOW;
            for @roles {
                $to_compose_meta.add_role($to_compose, $_);
            }
            $to_compose := $to_compose_meta.compose($to_compose);
        }

        # Collisions?
        my @collisions := $to_compose_meta.collisions($to_compose);
        for @collisions {
            if $_.private {
                unless has_private_method($target, $_.name) {
                    nqp::die("Private method '" ~ $_.name ~
                        "' must be resolved by class " ~
                        $target.HOW.name($target) ~
                        " because it exists in multiple roles (" ~
                        nqp::join(", ", $_.roles) ~ ")");
                }
            }
            else {
                unless has_method($target, $_.name, 1) {
                    nqp::die("Method '" ~ $_.name ~
                        "' must be resolved by class " ~
                        $target.HOW.name($target) ~
                        " because it exists in multiple roles (" ~
                        nqp::join(", ", $_.roles) ~ ")");
                }
            }
        }

        # Compose in any methods.
        sub compose_method_table(%methods) {
            for %methods {
                my $name := $_.key;
                my $yada := 0;
                try { $yada := $_.value.yada }
                if $yada {
                    unless has_method($target, $name, 0)
                            || has_public_attribute($target, $name) {
                        nqp::die("Method '$name' must be implemented by " ~
                        $target.HOW.name($target) ~
                        " because it is required by a role");
                    }
                }
                elsif !has_method($target, $name, 1) {
                    $target.HOW.add_method($target, $name, $_.value);
                }
            }
        }
        compose_method_table($to_compose_meta.method_table($to_compose));
        compose_method_table($to_compose_meta.submethod_table($to_compose))
            if nqp::can($to_compose_meta, 'submethod_table');
        if nqp::can($to_compose_meta, 'private_method_table') {
            for $to_compose_meta.private_method_table($to_compose) {
                unless has_private_method($target, $_.key) {
                    $target.HOW.add_private_method($target, $_.key, $_.value);
                }
            }
        }
        
        # Compose in any multi-methods; conflicts can be caught by
        # the multi-dispatcher later.
        if nqp::can($to_compose_meta, 'multi_methods_to_incorporate') {
            my @multis := $to_compose_meta.multi_methods_to_incorporate($to_compose);
            for @multis {
                $target.HOW.add_multi_method($target, $_.name, $_.code);
            }
        }

        # Compose in any role attributes.
        my @attributes := $to_compose_meta.attributes($to_compose, :local(1));
        for @attributes {
            if has_attribute($target, $_.name) {
                nqp::die("Attribute '" ~ $_.name ~ "' already exists in the class '" ~
                    $target.HOW.name($target) ~ "', but a role also wishes to compose it");
            }
            $target.HOW.add_attribute($target, $_);
        }
        
        # Compose in any parents.
        if nqp::can($to_compose_meta, 'parents') {
            my @parents := $to_compose_meta.parents($to_compose, :local(1));
            for @parents {
                $target.HOW.add_parent($target, $_);
            }
        }
        
        # Copy any array_type.
        if nqp::can($target.HOW, 'is_array_type') && !$target.HOW.is_array_type($target) {
            if nqp::can($to_compose_meta, 'is_array_type') {
                if $to_compose_meta.is_array_type($to_compose) {
                    $target.HOW.set_array_type($target, $to_compose_meta.array_type($to_compose));
                }
            }
        }
        
        1;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/RoleToRoleApplier.nqp0000664000175000017500000001423412224263172022361 0ustar  moritzmoritzmy class RoleToRoleApplier {
    method apply($target, @roles) {
        # Ensure we actually have something to appply.
        unless +@roles {
            return [];
        }
        
        # Aggregate all of the methods sharing names, eliminating
        # any duplicates (a method can't collide with itself).
        my %meth_info;
        my %meth_providers;
        my %priv_meth_info;
        my %priv_meth_providers;
        for @roles {
            my $role := $_;
            sub build_meth_info(%methods, %meth_info_to_use, %meth_providers_to_use) {
                for %methods {
                    my $name := $_.key;
                    my $meth := $_.value;
                    my @meth_list;
                    my @meth_providers;
                    if nqp::existskey(%meth_info_to_use, $name) {
                        @meth_list := %meth_info_to_use{$name};
                        @meth_providers := %meth_providers_to_use{$name};
                    }
                    else {
                        %meth_info_to_use{$name} := @meth_list;
                        %meth_providers_to_use{$name} := @meth_providers;
                    }
                    my $found := 0;
                    for @meth_list {
                        if $meth =:= $_ {
                            $found := 1;
                        }
                        elsif nqp::can($meth, 'id') && nqp::can($_, 'id') {
                            $found := $meth.id == $_.id;
                        }
                    }
                    unless $found {
                        @meth_list.push($meth);
                        @meth_providers.push($role.HOW.name($role));
                    }
                }
            }
            build_meth_info($_.HOW.method_table($_), %meth_info, %meth_providers);
            build_meth_info($_.HOW.submethod_table($_), %meth_info, %meth_providers)
                if nqp::can($_.HOW, 'submethod_table');
            build_meth_info($_.HOW.private_method_table($_), %priv_meth_info, %priv_meth_providers)
                if nqp::can($_.HOW, 'private_method_table');
        }

        # Also need methods of target.
        my %target_meth_info := $target.HOW.method_table($target);

        # Process method list.
        for %meth_info {
            my $name := $_.key;
            my @add_meths := %meth_info{$name};

            # Do we already have a method of this name? If so, ignore all of the
            # methods we have from elsewhere.
            unless nqp::existskey(%target_meth_info, $name) {
                # No methods in the target role. If only one, it's easy...
                if +@add_meths == 1 {
                    $target.HOW.add_method($target, $name, @add_meths[0]);
                }
                else {
                    # Find if any of the methods are actually requirements, not
                    # implementations.
                    my @impl_meths;
                    for @add_meths {
                        my $yada := 0;
                        try { $yada := $_.yada; }
                        unless $yada {
                            @impl_meths.push($_);
                        }
                    }
                    
                    # If there's still more than one possible - add to collisions list.
                    # If we got down to just one, add it. If they were all requirements,
                    # just choose one.
                    if +@impl_meths == 1 {
                        $target.HOW.add_method($target, $name, @impl_meths[0]);
                    }
                    elsif +@impl_meths == 0 {
                        $target.HOW.add_method($target, $name, @add_meths[0]);
                    }
                    else {
                        $target.HOW.add_collision($target, $name, %meth_providers{$name});
                    }
                }
            }
        }
        
        # Process private method list.
        if nqp::can($target.HOW, 'private_method_table') {
            my %target_priv_meth_info := $target.HOW.private_method_table($target);
            for %priv_meth_info {
                my $name := $_.key;
                my @add_meths := %priv_meth_info{$name};
                unless nqp::existskey(%target_priv_meth_info, $name) {
                    if +@add_meths == 1 {
                        $target.HOW.add_private_method($target, $name, @add_meths[0]);
                    }
                    elsif +@add_meths {
                        $target.HOW.add_collision($target, $name, %priv_meth_providers{$name}, :private(1));
                    }
                }
            }
        }

        # Now do the other bits.
        for @roles {
            my $how := $_.HOW;

            # Compose is any attributes, unless there's a conflict.
            my @attributes := $how.attributes($_, :local(1));
            for @attributes {
                my $add_attr := $_;
                my $skip := 0;
                my @cur_attrs := $target.HOW.attributes($target, :local(1));
                for @cur_attrs {
                    if $_ =:= $add_attr {
                        $skip := 1;
                    }
                    else {
                        if $_.name eq $add_attr.name {
                            nqp::die("Attribute '" ~ $_.name ~ "' conflicts in role composition");
                        }
                    }
                }
                unless $skip {
                    $target.HOW.add_attribute($target, $add_attr);
                }
            }
            
            # Any multi-methods go straight in; conflicts can be
            # caught by the multi-dispatcher later.
            if nqp::can($how, 'multi_methods_to_incorporate') {
                my @multis := $how.multi_methods_to_incorporate($_);
                for @multis {
                    $target.HOW.add_multi_method($target, $_.name, $_.code);
                }
            }
            
            # Any parents can also just be copied over.
            if nqp::can($how, 'parents') {
                my @parents := $how.parents($_, :local(1));
                for @parents {
                    $target.HOW.add_parent($target, $_);
                }
            }
        }

        1;
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Stashing.nqp0000664000175000017500000000145512224263172020577 0ustar  moritzmoritz# XXX Little hacky because NQP doesn't let us see lexicals outside of
# code that does its runtime during compile time yet. Really should just
# have a my $stash_type and set/get from that.
role Perl6::Metamodel::Stashing {
    method set_stash_type($type, $attr_type) {
        nqp::bindcurhllsym('StashType', $type);
        nqp::bindcurhllsym('StashAttrType', $attr_type);
    }
    
    method add_stash($type_obj) {
        unless nqp::isnull(nqp::getcurhllsym('StashType')) {
            my $stash_type := nqp::getcurhllsym('StashType');
            my $attr_type := nqp::getcurhllsym('StashAttrType');
            my $stash := nqp::create($stash_type);
            nqp::bindattr($stash, $attr_type, '$!storage', my %symbols);
            nqp::setwho($type_obj, $stash);
        }
        $type_obj
    }
}
rakudo-2013.12/src/Perl6/Metamodel/SubsetHOW.nqp0000664000175000017500000000441412224263172020640 0ustar  moritzmoritzclass Perl6::Metamodel::SubsetHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Documenting
{
    # The subset type or nominal type that we refine.
    has $!refinee;
    
    # The block implementing the refinement.
    has $!refinement;

    my $archetypes := Perl6::Metamodel::Archetypes.new( :nominalizable(1) );
    method archetypes() {
        $archetypes
    }
    
    method new(*%named) {
        nqp::findmethod(NQPMu, 'BUILDALL')(nqp::create(self), |%named)
    }
    
    method BUILD(:$refinee, :$refinement) {
        $!refinee := $refinee;
        $!refinement := $refinement;
    }

    method new_type(:$name = '', :$refinee!, :$refinement!) {
        my $metasubset := self.new(:refinee($refinee), :refinement($refinement));
        my $type := nqp::settypehll(nqp::newtype($metasubset, 'Uninstantiable'), 'perl6');
        $metasubset.set_name($type, $name);
        nqp::settypecheckmode($type, 2)
    }
    
    method set_of($obj, $refinee) {
        my $archetypes := $!refinee.HOW.archetypes;
        unless $archetypes.nominal || $archetypes.nominalizable {
            nqp::die("The 'of' type of a subset must either be a valid nominal " ~
                "type or a type that can provide one");
        }
        $!refinee := nqp::decont($refinee);
    }
    
    method refinee($obj) {
        $!refinee
    }
    
    method refinement($obj) {
        $!refinement
    }
    
    method nominalize($obj) {
        $!refinee.HOW.archetypes.nominal ??
            $!refinee !!
            $!refinee.HOW.nominalize($!refinee)
    }
    
    # Should have the same methods of the (eventually nominal) type
    # that we refine. (For the performance win, work out a way to
    # steal its method cache.)
    method find_method($obj, $name) {
        $!refinee.HOW.find_method($!refinee, $name)
    }
    
    # Do check when we're on LHS of smartmatch (e.g. Even ~~ Int).
    method type_check($obj, $checkee) {
        nqp::p6bool(nqp::istrue($checkee.HOW =:= self) ||
            nqp::istype($!refinee, $checkee))
    }
    
    # Here we check the value itself (when on RHS on smartmatch).
    method accepts_type($obj, $checkee) {
        nqp::p6bool(
            nqp::istype($checkee, $!refinee) &&
            nqp::istrue($!refinement.ACCEPTS($checkee)))
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Trusting.nqp0000664000175000017500000000155412224263172020636 0ustar  moritzmoritz# Implements managing trust relationships between types.
role Perl6::Metamodel::Trusting {
    # Who do we trust?
    has @!trustees;
    
    # Adds a type that we trust.
    method add_trustee($obj, $trustee) {
        @!trustees[+@!trustees] := $trustee;
    }
    
    # Introspect the types that we trust.
    method trusts($obj) {
        @!trustees
    }
    
    # Checks if we trust a certain type. Can be used by the compiler
    # to check if a private call is allowable.
    method is_trusted($obj, $claimant) {
        # Always trust ourself.
        if $claimant.WHAT =:= $obj.WHAT {
            return 1;
        }
        
        # Otherwise, look through our trustee list.
        for @!trustees {
            if $_.WHAT =:= $claimant.WHAT {
                return 1;
            }
        }
        
        # If we get here, not trusted.
        0
    }
}
rakudo-2013.12/src/Perl6/Metamodel/TypePretense.nqp0000664000175000017500000000066312242026101021433 0ustar  moritzmoritzrole Perl6::Metamodel::TypePretense {
    my @pretending;
    
    method pretend_to_be(@types) {
        @pretending := @types;
    }
    
    method pretending_to_be() {
        @pretending
    }
    
    method type_check($obj, $checkee) {
        if $obj =:= $checkee {
            return 1;
        }
        for self.pretending_to_be() {
            if $checkee =:= $_ {
                return 1;
            }
        }
    }
}
rakudo-2013.12/src/Perl6/Metamodel/Versioning.nqp0000664000175000017500000000036112224263172021135 0ustar  moritzmoritzrole Perl6::Metamodel::Versioning {
    has $!ver;
    has $!auth;

    method ver($obj) { $!ver }
    method auth($obj) { $!auth }
    
    method set_ver($obj, $ver) { $!ver := $ver }
    method set_auth($obj, $auth) { $!auth := $auth }
}
rakudo-2013.12/src/Perl6/ModuleLoader.nqp0000664000175000017500000002742712255230273017473 0ustar  moritzmoritzmy $DEBUG := +nqp::ifnull(nqp::atkey(nqp::getenvhash(), 'RAKUDO_MODULE_DEBUG'), 0);
sub DEBUG(*@strs) {
    my $err := nqp::getstderr();
    nqp::printfh($err, "MODULE_DEBUG: ");
    for @strs { nqp::printfh($err, $_) };
    nqp::printfh($err, "\n");
    1;
}

class Perl6::ModuleLoader does Perl6::ModuleLoaderVMConfig {
    my %modules_loaded;
    my %settings_loaded;
    my $absolute_path_func;
    
    my %language_module_loaders := nqp::hash(
        'NQP', nqp::gethllsym('nqp', 'ModuleLoader'),
    ); 
    
    method register_language_module_loader($lang, $loader) {
        nqp::die("Language loader already registered for $lang")
            if nqp::existskey(%language_module_loaders, $lang);
        %language_module_loaders{$lang} := $loader;
    }
    
    method register_absolute_path_func($func) {
        $absolute_path_func := $func;
    }
    
    method absolute_path($path) {
        $absolute_path_func ?? $absolute_path_func($path) !! $path;
    }
    
    method ctxsave() {
        $*MAIN_CTX := nqp::ctxcaller(nqp::ctx());
        $*CTXSAVE := 0;
    }
    
    method search_path() {
        # See if we have an @*INC set up, and if so just use that.
        my $PROCESS := nqp::gethllsym('perl6', 'PROCESS');
        if !nqp::isnull($PROCESS) && nqp::existskey($PROCESS.WHO, '@INC') {
            my $INC := ($PROCESS.WHO)<@INC>;
            if nqp::defined($INC) {
                my @INC := $INC.FLATTENABLE_LIST();
                if +@INC {
                    return @INC;
                }
            }
        }

        # Too early to have @*INC; probably no setting yet loaded to provide
        # the PROCESS initialization.
        my @search_paths;
        @search_paths.push('.');
        @search_paths.push('blib');
        for self.vm_search_paths() {    
            @search_paths.push($_);
        }
        @search_paths
    }
    
    method load_module($module_name, %opts, *@GLOBALish, :$line, :$file?) {
        # See if we need to load it from elsewhere.
        if nqp::existskey(%opts, 'from') {
            if nqp::existskey(%language_module_loaders, %opts) {
                # We expect that custom module loaders will accept a Stash, only
                # NQP expects a hash and therefor needs special handling.
                if +@GLOBALish && %opts eq 'NQP' {
                    my $target := nqp::knowhow().new_type(:name('GLOBALish'));
                    nqp::setwho($target, @GLOBALish[0].WHO.FLATTENABLE_HASH());
                    return %language_module_loaders{%opts}.load_module($module_name,
                        %opts, $target, :$line, :$file);
                }
                return %language_module_loaders{%opts}.load_module($module_name,
                    %opts, |@GLOBALish, :$line, :$file);
            }
            else {
                nqp::die("Do not know how to load code from " ~ %opts);
            }
        }
        
        # Locate all the things that we potentially could load. Choose
        # the first one for now (XXX need to filter by version and auth).
        my @prefixes   := self.search_path();
        my @candidates := self.locate_candidates($module_name, @prefixes, :$file);
        if +@candidates == 0 {
            if nqp::defined($file) {
                nqp::die("Could not find file '$file' for module $module_name");
            }
            else {
                nqp::die("Could not find $module_name in any of: " ~
                    join(', ', @prefixes));
            }
        }
        my %chosen := @candidates[0];
        
        my @MODULES := nqp::clone(@*MODULES // []);
        for @MODULES -> $m {
            if $m eq $module_name {
                nqp::die("Circular module loading detected involving module '$module_name'");
            }
        }

        # If we didn't already do so, load the module and capture
        # its mainline. Otherwise, we already loaded it so go on
        # with what we already have.
        my $module_ctx;
        if nqp::defined(%modules_loaded{%chosen}) {
            $module_ctx := %modules_loaded{%chosen};
        }
        else {
            my @*MODULES := @MODULES;
            if +@*MODULES  == 0 {
                my %prev        := nqp::hash();
                %prev     := $line;
                %prev := nqp::getlexdyn('$?FILES');
                @*MODULES[0]    := %prev;
            }
            else {
                @*MODULES[-1] := $line;
            }
            my %trace := nqp::hash();
            %trace   := $module_name;
            %trace := %chosen;
            my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), NQPMu);
            nqp::push(@*MODULES, %trace);
            if %chosen {
                %trace := %chosen;
                DEBUG("loading ", %chosen) if $DEBUG;
                my %*COMPILING := {};
                my $*CTXSAVE := self;
                my $*MAIN_CTX;
                nqp::loadbytecode(%chosen);
                %modules_loaded{%chosen} := $module_ctx := $*MAIN_CTX;
                DEBUG("done loading ", %chosen) if $DEBUG;
            }
            else {
                # If we're doing module pre-compilation, we should only
                # allow the modules we load to be pre-compiled also.
                my $precomp := 0;
                try $precomp := $*W.is_precompilation_mode();
                if $precomp {
                    nqp::die(
                        "When pre-compiling a module, its dependencies must be pre-compiled first.\n" ~
                        "Please pre-compile " ~ %chosen);
                }
                
                # Read source file.
                DEBUG("loading ", %chosen) if $DEBUG;
#?if parrot
                my $fh := nqp::open(%chosen, 'r');
                $fh.encoding('utf8');
                my $source := $fh.readall();
                $fh.close();
#?endif
#?if jvm
                my $fh := nqp::open(%chosen, 'r');
                nqp::setencoding($fh, 'utf8');
                my $source := nqp::readallfh($fh);
                nqp::closefh($fh);
#?endif
                
                # Get the compiler and compile the code, then run it
                # (which runs the mainline and captures UNIT).
                my $?FILES   := %chosen;
                my $eval     := nqp::getcomp('perl6').compile($source);
                my $*CTXSAVE := self;
                my $*MAIN_CTX;
                $eval();
                %modules_loaded{%chosen} := $module_ctx := $*MAIN_CTX;
                DEBUG("done loading ", %chosen) if $DEBUG;

            }
            nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global);
            CATCH {
                nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global);
                nqp::rethrow($_);
            }
        }

        # Provided we have a mainline and need to do global merging...
        if nqp::defined($module_ctx) {
            # Merge any globals.
            my $UNIT := nqp::ctxlexpad($module_ctx);
            if +@GLOBALish {
                unless nqp::isnull($UNIT) {
                    merge_globals(@GLOBALish[0], $UNIT);
                }
            }
            return $UNIT;
        }
        else {
            return {};
        }
    }
    
    # This is a first cut of the globals merger. For another approach,
    # see sorear++'s work in Niecza. That one is likely more "pure"
    # than this, but that would seem to involve copying too, and the
    # details of exactly what that entails are a bit hazy to me at the
    # moment. We'll see how far this takes us.
    my $stub_how := 'Perl6::Metamodel::PackageHOW';
    sub merge_globals($target, $source) {
        # Start off merging top-level symbols. Easy when there's no
        # overlap. Otherwise, we need to recurse.
        my %known_symbols;
        for stash_hash($target) {
            %known_symbols{$_.key} := 1;
        }
        for stash_hash($source) {
            my $sym := $_.key;
            if !%known_symbols{$sym} {
                ($target.WHO){$sym} := $_.value;
            }
            elsif ($target.WHO){$sym} =:= $_.value {
                # No problemo; a symbol can't conflict with itself.
            }
            else {
                my $source_mo := $_.value.HOW;
                my $source_is_stub := $source_mo.HOW.name($source_mo) eq $stub_how;
                my $target_mo := ($target.WHO){$sym}.HOW;
                my $target_is_stub := $target_mo.HOW.name($target_mo) eq $stub_how;
                if $source_is_stub && $target_is_stub {
                    # Both stubs. We can safely merge the symbols from
                    # the source into the target that's importing them.
                    merge_globals(($target.WHO){$sym}, $_.value);
                }
                elsif $source_is_stub {
                    # The target has a real package, but the source is a
                    # stub. Also fine to merge source symbols into target.
                    merge_globals(($target.WHO){$sym}, $_.value);
                }
                elsif $target_is_stub {
                    # The tricky case: here the interesting package is the
                    # one in the module. So we merge the other way around
                    # and install that as the result.
                    merge_globals($_.value, ($target.WHO){$sym});
                    ($target.WHO){$sym} := $_.value;
                }
                else {
                    nqp::die("Merging GLOBAL symbols failed: duplicate definition of symbol $sym");
                }
            }
        }
    }
    
    method load_setting($setting_name) {
        my $setting;
        
        if $setting_name ne 'NULL' {
            # Unless we already did so, locate and load the setting.
            unless nqp::defined(%settings_loaded{$setting_name}) {
                # Find it.
                my $path := self.find_setting($setting_name);
                
                # Load it.
                my $*CTXSAVE := self;
                my $*MAIN_CTX;
                my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), NQPMu);
                nqp::scwbdisable();
                nqp::loadbytecode($path);
                nqp::scwbenable();
                nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global);
                unless nqp::defined($*MAIN_CTX) {
                    nqp::die("Unable to load setting $setting_name; maybe it is missing a YOU_ARE_HERE?");
                }
                %settings_loaded{$setting_name} := $*MAIN_CTX;
            }
            
            $setting := %settings_loaded{$setting_name};
        }
        
        return $setting;
    }
    
    # Handles any object repossession conflicts that occurred during module load,
    # or complains about any that cannot be resolved.
    method resolve_repossession_conflicts(@conflicts) {
        for @conflicts -> $orig, $current {
            # If it's a Stash in conflict, we make sure any original entries get
            # appropriately copied.
            if $orig.HOW.name($orig) eq 'Stash' {
                for $orig.FLATTENABLE_HASH() {
                    unless nqp::existskey($current, $_.key) {
                        $current{$_.key} := $_.value;
                    }
                }
            }
            # We could complain about anything else, and may in the future; for
            # now, we let it pass by with "latest wins" semantics.
        }
    }
    
    sub stash_hash($pkg) {
        my $hash := $pkg.WHO;
        unless nqp::ishash($hash) {
            $hash := $hash.FLATTENABLE_HASH();
        }
        $hash
    }
}

# We stash this in the perl6 HLL namespace, just so it's easy to
# locate. Note this makes it invisible inside Perl 6 itself.
nqp::bindhllsym('perl6', 'ModuleLoader', Perl6::ModuleLoader);
rakudo-2013.12/src/Perl6/Optimizer.nqp0000664000175000017500000011373312255230276017100 0ustar  moritzmoritzuse NQPP6QRegex;
use QAST;
use Perl6::Ops;

my $NULL := QAST::Op.new( :op );

# This powers the optimization pass. It takes place after we've done all
# of the stuff in the grammar and actions, which means CHECK time is over.
# Thus we're allowed to assume that lexpads are immutable, declarations are
# over and done with, multi candidate lists won't change and so forth.
class Perl6::Optimizer {
    # Tracks the nested blocks we're in; it's the lexical chain, essentially.
    has @!block_stack;

    has %!adverbs;

    # How deep a chain we're in, for chaining operators.
    has int $!chain_depth;
    
    # Unique ID for topic ($_) preservation registers.
    has int $!pres_topic_counter;
    
    # Unique ID for inline args variables.
    has int $!inline_arg_counter;
    
    # Things that should cause compilation to fail; keys are errors, value is
    # array of line numbers.
    has %!deadly;
    
    # Things that should be warned about; keys are warnings, value is an array
    # of line numbers.
    has %!worrying;
    
    # Top type, Mu, and Any (the top non-junction type).
    has $!Mu;
    has $!Any;

    # The Setting, which contains things like Signature and Parameter.
    has $!SETTING;
    has %!SETTING_CACHE;

    has %!foldable_junction;
    has %!foldable_outer;

    # Entry point for the optimization process.
    method optimize($past, *%adverbs) {
        # Initialize.
        @!block_stack := [$past[0]];
        $!chain_depth := 0;
        $!pres_topic_counter := 0;
        $!inline_arg_counter := 0;
        %!deadly := nqp::hash();
        %!worrying := nqp::hash();
        my $*DYNAMICALLY_COMPILED := 0;
        my $*VOID_CONTEXT := 0;
        my $*IN_DECLARATION := 0;
        %!foldable_junction{'&infix:<|>'} :=  '&infix:<||>';
        %!foldable_junction{'&infix:<&>'} :=  '&infix:<&&>';

        # until there's a good way to figure out flattening at compile time,
        # don't support these junctions
        #%!foldable_junction{'&any'} := '&infix:<||>';
        #%!foldable_junction{'&all'} :=  '&infix:<&&>';

        %!foldable_outer{'&prefix:'} := 1;
        %!foldable_outer{'&prefix:'} := 1;
        %!foldable_outer{'&prefix:'} := 1;
        %!foldable_outer{'&prefix:'} := 1;

        %!foldable_outer{'if'} := 1;
        %!foldable_outer{'unless'} := 1;
        %!foldable_outer{'while'} := 1;
        %!foldable_outer{'until'} := 1;

        # Work out optimization level.
        my $*LEVEL := nqp::existskey(%adverbs, 'optimize') ??
            +%adverbs !! 2;
        %!adverbs := %adverbs;
        
        # Locate UNIT and some other useful symbols.
        my $*GLOBALish := $past;
        my $*W         := $past;
        my $unit       := $past;
        unless nqp::istype($unit, QAST::Block) {
            nqp::die("Optimizer could not find UNIT");
        }
        nqp::push(@!block_stack, $unit);
        $!Mu  := self.find_lexical('Mu');
        $!Any := self.find_lexical('Any');
        nqp::pop(@!block_stack);
        
        # Walk and optimize the program.
        self.visit_block($unit);
        
        # Die if we failed check in any way; otherwise, print any warnings.
        if +%!deadly {
            my @fails;
            for %!deadly {
                my @parts := nqp::split("\n", $_.key);
                my $headline := @parts.shift();
                @fails.push("$headline (line" ~ (+$_.value == 1 ?? ' ' !! 's ') ~
                    join(', ', $_.value) ~ ")" ~
                    (+@parts ?? "\n" ~ join("\n", @parts) !! ""));
            }
            nqp::die("CHECK FAILED:\n" ~ join("\n", @fails))
        }
        if +%!worrying {
            my $err := nqp::getstderr();
            nqp::printfh($err, "WARNINGS:\n");
            my @fails;
            for %!worrying {
                nqp::printfh($err, $_.key ~ " (line" ~ (+$_.value == 1 ?? ' ' !! 's ') ~
                    join(', ', $_.value) ~ ")\n");
            }
        }
        
        $past
    }
    
    # Called when we encounter a block in the tree.
    method visit_block($block) {
        # Push block onto block stack.
        @!block_stack.push($block);
        
        # Visit children.
        if $block {
            my $*DYNAMICALLY_COMPILED := 1;
            self.visit_children($block, :resultchild(+@($block) - 1));
        }
        else {
            self.visit_children($block, :resultchild(+@($block) - 1));
        }
        
        # Pop block from block stack.
        @!block_stack.pop();
        
        # If the block is immediate, we may be able to inline it.
        my $outer := @!block_stack[+@!block_stack - 1];
        if $block.blocktype eq 'immediate' && !$*DYNAMICALLY_COMPILED {
            # Scan symbols for any non-interesting ones.
            my @sigsyms;
            for $block.symtable() {
                my $name := $_.key;
                if $name ne '$_' && $name ne '$*DISPATCHER' {
                    @sigsyms.push($name);
                }
            }
            
            # If we have no interesting ones, then we can inline the
            # statements.
            # XXX We can also check for lack of colliding symbols and
            # do something in that case. However, it's non-trivial as
            # the static lexpad entries will need twiddling with.
            if +@sigsyms == 0 {
                if $*LEVEL >= 3 {
                    return self.inline_immediate_block($block, $outer);
                }
            }
        }

        # We may also be able to optimize away the full-blown binder in some
        # cases and on some backends.
        my $code_obj := $block;
        my $backend  := nqp::getcomp('perl6').backend.name;
        if $backend eq 'jvm' && $*LEVEL >= 3 && nqp::isconcrete($code_obj) {
            my $sig := $code_obj.signature;
            self.try_eliminate_binder($block, $sig);
        }

        $block
    }
    
    method try_eliminate_binder($block, $sig) {
        my $Signature := self.find_in_setting('Signature');
        my @params := nqp::getattr($sig, $Signature, '$!params');
        if nqp::elems(@params) == 0 {
            # Zero args; no need for binder call, and no more to do.
            try_remove_binder_call();
        }
        sub try_remove_binder_call() {
            my int $found := 0;
            for @($block[0]) {
                if nqp::istype($_, QAST::Op) && $_.op eq 'p6bindsig' {
                    $_.op('null');
                    $found := 1;
                    last;
                }
            }
            if $found {
                $block.custom_args(0);
                1
            }
            else {
                0
            }
        }
    }

    method is_from_core($name) {
        my int $i := +@!block_stack;
        while $i > 0 {
            $i := $i - 1;
            my $block := @!block_stack[$i];
            my %sym := $block.symbol($name);
            if +%sym && nqp::existskey(%sym, 'value') {
                my %sym := $block.symbol("!CORE_MARKER");
                if +%sym {
                    return 1;
                }
                return 0;
            }
        }
        return 0;
    }

    method find_in_setting($symbol) {
        if !nqp::defined($!SETTING) {
            my int $i := +@!block_stack;
            while $i > 0 && !nqp::defined($!SETTING) {
                $i := $i - 1;
                my $block := @!block_stack[$i];
                my %sym := $block.symbol("!CORE_MARKER");
                if +%sym {
                    $!SETTING := $block;
                }
            }
            if !nqp::defined($!SETTING) {
                nqp::die("Optimizer couldn't find CORE while looking for $symbol.");
            }
        } else {
            if nqp::existskey(%!SETTING_CACHE, $symbol) {
                return %!SETTING_CACHE{$symbol};
            }
        }
        my %sym := $!SETTING.symbol($symbol);
        if +%sym {
            if nqp::existskey(%sym, 'value') {
                %!SETTING_CACHE{$symbol} := %sym;
                return %sym;
            } else {
                nqp::die("Optimizer: cannot find $symbol in SETTING.");
            }
        }
    }

    method can_chain_junction_be_warped($node) {
        sub has_core-ish_junction($node) {
            if nqp::istype($node, QAST::Op) && $node.op eq 'call' &&
                    nqp::existskey(%!foldable_junction, $node.name) {
                if self.is_from_core($node.name) {
                    # TODO: special handling for any()/all(), because they create
                    #       a Stmts with a infix:<,> in it.
                    if +$node.list == 1 {
                        return 0;
                    }
                    return 1;
                }
            }
            return 0;
        }

        if has_core-ish_junction($node[0]) {
            return 0;
        } elsif has_core-ish_junction($node[1]) {
            return 1;
        }
        return -1;
    }
    
    # Called when we encounter a QAST::Op in the tree. Produces either
    # the op itself or some replacement opcode to put in the tree.
    method visit_op($op) {
        # If it's a QAST::Op of type handle, needs some special attention.
        my str $optype := $op.op;
        if $optype eq 'handle' {
            return self.visit_handle($op);
        }
        
        # A chain with exactly two children can become the op itself.
        if $optype eq 'chain' {
            $!chain_depth := $!chain_depth + 1;
            $optype := 'call' if $!chain_depth == 1 &&
                !(nqp::istype($op[0], QAST::Op) && $op[0].op eq 'chain') &&
                !(nqp::istype($op[1], QAST::Op) && $op[1].op eq 'chain');
        }

        # there's a list of foldable outers up in the constructor.
        sub is_outer_foldable() {
            if $op.op eq "call" {
                if nqp::existskey(%!foldable_outer, $op.name) && self.is_from_core($op.name) {
                    return 1;
                }
            } elsif nqp::existskey(%!foldable_outer, $op.op) {
                return 1;
            }
            return 0;
        }

        # only if a chain operator handles Any, rather than Mu, in its signature
        # will autothreading actually happen.
        sub chain_handles_Any($op) {
            my $obj;
            my int $found := 0;
            try {
                $obj := self.find_lexical($op);
                $found := 1;
            }
            if $found == 1 {
                my $signature := self.find_in_setting("Signature");
                my $iter := nqp::iterator(nqp::getattr($obj.signature, $signature, '$!params'));
                while $iter {
                    my $p := nqp::shift($iter);
                    unless nqp::istype($p.type, $!Any) {
                        return 0;
                    }
                }
                return 1;
            } else {
                return 0;
            }
            return 0;
        }

        # we may be able to unfold a junction at compile time.
        if $*LEVEL >= 2 && is_outer_foldable() && nqp::istype($op[0], QAST::Op) {
            my $proceed := 0;
            my $exp-side;
            if $op[0].op eq "chain" {
                $exp-side := self.can_chain_junction_be_warped($op[0]);
                $proceed := $exp-side != -1 && chain_handles_Any($op[0].name) == 1
            } elsif $op[0].op eq 'callmethod' && $op[0].name eq 'ACCEPTS' {
                $exp-side := self.can_chain_junction_be_warped($op[0]);
                # we should only ever find the 0nd child (the invocant) to be a junction anyway.
                $proceed := $exp-side == 0;
            }
            if $proceed {
                # TODO chain_handles_Any may get more cleverness to check only the parameters that actually have
                # a junction passed to them, so that in some cases the unfolding may still happen.
                my str $juncop := $op[0][$exp-side].name eq '&infix:<&>' ?? 'if' !! 'unless';
                my str $juncname := %!foldable_junction{$op[0][$exp-side].name};
                my str $chainop := $op[0].op;
                my str $chainname := $op[0].name;
                my $values := $op[0][$exp-side];
                my $ovalue := $op[0][1 - $exp-side];

                # the first time $valop is refered to, create a bind op for a
                # local var, next time create a reference var op.
                my %reference;
                sub refer_to($valop) {
                    my $id := nqp::where($valop);
                    if nqp::existskey(%reference, $id) {
                        QAST::Var.new(:name(%reference{$id}), :scope);
                    } else {
                        %reference{$id} := $op.unique('junction_unfold');
                        QAST::Op.new(:op,
                                     QAST::Var.new(:name(%reference{$id}),
                                                   :scope,
                                                   :decl),
                                     $valop);
                    }
                }

                # create a comparison operation for the inner comparisons
                sub chain($value) {
                    if $exp-side == 0 {
                        QAST::Op.new(:op($chainop), :name($chainname),
                                     $value,
                                     refer_to($ovalue));
                    } else {
                        QAST::Op.new(:op($chainop), :name($chainname),
                                     refer_to($ovalue),
                                     $value);
                    }
                }

                # create a chain of outer logical junction operators with inner comparisons
                sub create_junc() {
                    my $junc := QAST::Op.new(:name($juncname), :op($juncop));

                    $junc.push(chain($values.shift()));

                    if +$values.list > 1 {
                        $junc.push(create_junc());
                    } else {
                        $junc.push(chain($values.shift()));
                    }
                    return $junc;
                }

                $op.shift;
                $op.unshift(create_junc());
                #say($op.dump);
                return self.visit_op($op);
            }
        }
        
        # Visit the children.
        {
            my $*VOID_CONTEXT := 0;
            self.visit_children($op);
        }
        
        # Calls are especially interesting as we may wish to do some
        # kind of inlining.
        if $optype eq 'call' && $op.name ne '' {
            # See if we can find the thing we're going to call.
            my $obj;
            my int $found := 0;
            try {
                $obj := self.find_lexical($op.name);
                $found := 1;
            }
            if $found {
                # Pure operators can be constant folded.
                if nqp::can($obj, 'IS_PURE') && $obj.IS_PURE {
                    # First ensure we're not in void context; warn if so.
                    sub widen($m) {
                        my int $from := $m.from;
                        my int $to   := $m.to;
                        for $m.list {
                            $from := $_.from if $_.from < $from;
                            $to   := $_.to   if $_.to   > $to;
                        }
                        nqp::substr($m.orig, $from, $to - $from);
                    }
                    if $op.node && $*VOID_CONTEXT && !$*IN_DECLARATION {
                        my str $op_txt := nqp::escape($op.node.Str);
                        my str $expr   := nqp::escape(widen($op.node));
                        self.add_worry($op, qq[Useless use of "$op_txt" in expression "$expr" in sink context]);
                    }
                    # check if all arguments are known at compile time
                    my int $all_args_known := 1;
                    my @args := [];
                    for @($op) {
                        if nqp::istype($_, QAST::Node)
                                && $_.has_compile_time_value
                                && !$_.named {
                            nqp::push(@args, $_.compile_time_value);
                        }
                        else {
                            $all_args_known := 0;
                            last;
                        }
                    }
                    
                    # If so, attempt to constant fold.
                    if $all_args_known {
                        my int $survived := 0;
                        my $ret_value;
                        try {
                            $ret_value := $obj(|@args);
                            $survived  := 1 ;
                            CONTROL {
                                $survived := 0;
                            }
                        }
                        if $survived {
                            return $NULL if $*VOID_CONTEXT && !$*IN_DECLARATION;
                            $*W.add_object($ret_value);
                            my $wval := QAST::WVal.new(:value($ret_value));
                            if $op.named {
                                $wval.named($op.named);
                            }
                            # if it's an Int, Num or Str, we can create a Want
                            # from it with an int, num or str value.
                            my $want;
                            if nqp::istype($ret_value, self.find_in_setting("Int")) && !nqp::isbig_I(nqp::decont($ret_value)) {
                                $want := QAST::Want.new($wval,
                                    "Ii", QAST::IVal.new(:value(nqp::unbox_i($ret_value))));
                            } elsif nqp::istype($ret_value, self.find_in_setting("Num")) {
                                $want := QAST::Want.new($wval,
                                    "Nn", QAST::NVal.new(:value(nqp::unbox_n($ret_value))));
                            } elsif nqp::istype($ret_value, self.find_in_setting("Str")) {
                                $want := QAST::Want.new($wval,
                                    "Ss", QAST::SVal.new(:value(nqp::unbox_s($ret_value))));
                            }
                            if nqp::defined($want) {
                                if $op.named {
                                    $want.named($op.named);
                                }
                                return $want;
                            }
                            return $wval;
                        }
                    }
                }
                # If it's an onlystar proto, we have a couple of options.
                # The first is that we may be able to work out what to
                # call at compile time. Failing that, we can at least inline
                # the proto.
                my $dispatcher;
                try { if $obj.is_dispatcher { $dispatcher := 1 } }
                if $dispatcher && $obj.onlystar {
                    # Try to do compile-time multi-dispatch. Need to consider
                    # both the proto and the multi candidates.
                    my @ct_arg_info := self.analyze_args_for_ct_call($op);
                    if +@ct_arg_info {
                        my @types := @ct_arg_info[0];
                        my @flags := @ct_arg_info[1];
                        my $ct_result_proto := nqp::p6trialbind($obj.signature, @types, @flags);
                        my @ct_result_multi := $obj.analyze_dispatch(@types, @flags);
                        if $ct_result_proto == 1 && @ct_result_multi[0] == 1 {
                            my $chosen := @ct_result_multi[1];
                            if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
                            if $*LEVEL >= 2 {
                                return nqp::can($chosen, 'inline_info') && nqp::istype($chosen.inline_info, QAST::Node)
                                    ?? self.inline_call($op, $chosen)
                                    !! self.call_ct_chosen_multi($op, $obj, $chosen);
                            }
                        }
                        elsif $ct_result_proto == -1 || @ct_result_multi[0] == -1 {
                            self.report_inevitable_dispatch_failure($op, @types, @flags, $obj,
                                :protoguilt($ct_result_proto == -1));
                        }
                    }
                    if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
                }
                elsif !$dispatcher && nqp::can($obj, 'signature') {
                    # If we know enough about the arguments, do a "trial bind".
                    my @ct_arg_info := self.analyze_args_for_ct_call($op);
                    if +@ct_arg_info {
                        my @types := @ct_arg_info[0];
                        my @flags := @ct_arg_info[1];
                        my $ct_result := nqp::p6trialbind($obj.signature, @types, @flags);
                        if $ct_result == 1 {
                            if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
                            #say("# trial bind worked!");
                            if $*LEVEL >= 2 {
                                if nqp::can($obj, 'inline_info') && nqp::istype($obj.inline_info, QAST::Node) {
                                    return self.inline_call($op, $obj);
                                }
                                copy_returns($op, $obj);
                            }
                        }
                        elsif $ct_result == -1 {
                            self.report_inevitable_dispatch_failure($op, @types, @flags, $obj);
                        }
                    }
                }

                # If we get here, no inlining or compile-time decision was
                # possible, but we may still be able to make it a callstatic,
                # which is cheaper on some backends.
                my $scopes := self.scopes_in($op.name);
                if $scopes == 0 || $scopes == 1 && nqp::can($obj, 'soft') && !$obj.soft {
                    $op.op('callstatic');
                }
            }
            else {
                # We really should find routines; failure to do so is a CHECK
                # time error. Check that it's not just compile-time unknown,
                # however (shows up in e.g. sub foo(&x) { x() }).
                unless self.is_lexical_declared($op.name) {
                    self.add_deadly($op, "Undefined routine '" ~ $op.name ~ "' called");
                }
            }
        }
        
        # If it's a private method call, we can sometimes resolve it at
        # compile time. If so, we can reduce it to a sub call in some cases.
        elsif $*LEVEL >= 3 && $op.op eq 'callmethod' && $op.name eq 'dispatch:' {
            if $op[1].has_compile_time_value && nqp::istype($op[1], QAST::Want) && $op[1][1] eq 'Ss' {
                my str $name := $op[1][2].value; # get raw string name
                my $pkg  := $op[2].returns;  # actions always sets this
                my $meth := $pkg.HOW.find_private_method($pkg, $name);
                if $meth {
                    try {
                        $*W.get_ref($meth); # may fail, thus the try; verifies it's in SC
                        my $call := QAST::WVal.new( :value($meth) );
                        my $inv  := $op.shift;
                        $op.shift; $op.shift; # name, package (both pre-resolved now)
                        $op.unshift($inv);
                        $op.unshift($call);
                        $op.op('call');
                        $op.name(NQPMu);
                    }
                }
                else {
                    self.add_deadly($op, "Undefined private method '" ~ $name ~ "' called");
                }
            }
        }
        
        # If we end up here, just leave op as is.
        if $op.op eq 'chain' {
            $!chain_depth := $!chain_depth - 1;
        }
        $op
    }
    
    # Handles visiting a QAST::Op :op('handle').
    method visit_handle($op) {
        my $*VOID_CONTEXT := 0;
        self.visit_children($op, :skip_selectors);
        $op
    }
    
    # Handles visiting a QAST::Want node.
    method visit_want($want) {
        # Any literal in void context deserves a warning.
        if $*VOID_CONTEXT && !$*IN_DECLARATION
                && +@($want) == 3 && $want.node {

            my str $warning;
            if $want[1] eq 'Ss' && nqp::istype($want[2], QAST::SVal) {
                $warning := qq[Useless use of constant string "]
                         ~ nqp::escape($want[2].value)
                         ~ qq[" in sink context];
            }
            elsif $want[1] eq 'Ii' && nqp::istype($want[2], QAST::IVal) {
                $warning := qq[Useless use of constant integer ]
                         ~ ~$want[2].value
                         ~ qq[ in sink context];
            }
            elsif $want[1] eq 'Nn' && nqp::istype($want[2], QAST::NVal) {
                $warning := qq[Useless use of constant floating-point number ]
                         ~ ~$want[2].value
                         ~ qq[ in sink context];
            }
            if $warning {
                self.add_worry($want, $warning);
                return $NULL;
            }
        }

        # If it's the sink context void node, then only visit the first
        # child. Otherwise, see all.
        if +@($want) == 3 && $want[1] eq 'v' {
            self.visit_children($want, :first);
        }
        else {
            self.visit_children($want, :skip_selectors);
        }
        $want;
    }
    
    # Handles visit a variable node.
    method visit_var($var) {
        if  $*VOID_CONTEXT && !$*IN_DECLARATION && $var.name && !$var {
            # stuff like Nil is also stored in a QAST::Var, but
            # we certainly don't want to warn about that one.
            my str $sigil := nqp::substr($var.name, 0, 1);
            if $sigil eq '$' || $sigil eq '@' || $sigil eq '%' {
                self.add_worry($var, "Useless use of variable " ~ $var.name ~ " in sink context");
                return $NULL;
            }
        }
        $var;
    }
    
    # Checks arguments to see if we're going to be able to do compile
    # time analysis of the call.
    my @allo_map := ['', 'Ii', 'Nn', 'Ss'];
    my %allo_rev := nqp::hash('Ii', 1, 'Nn', 2, 'Ss', 3);
    method analyze_args_for_ct_call($op) {
        my @types;
        my @flags;
        my @allomorphs;
        my int $num_prim := 0;
        my int $num_allo := 0;
        
        # Initial analysis.
        for @($op) {
            # Can't cope with flattening or named.
            if $_.flat || $_.named ne '' {
                return [];
            }
            
            # See if we know the node's type; if so, check it.
            my $type := $_.returns();
            my $ok_type := 0;
            try $ok_type := nqp::istype($type, $!Mu);
            if $ok_type {
                my $prim := nqp::objprimspec($type);
                my str $allo := $_.has_compile_time_value && nqp::istype($_, QAST::Want)
                    ?? $_[1] !! '';
                @types.push($type);
                @flags.push($prim);
                @allomorphs.push($allo);
                $num_prim := $num_prim + 1 if $prim;
                $num_allo := $num_allo + 1 if $allo;
            }
            else {
                return [];
            }
        }
        
        # See if we have an allomorphic constant that may allow us to do
        # a native dispatch with it; takes at least one declaratively
        # native argument to make this happen.
        if @types == 2 && $num_prim == 1 && $num_allo == 1 {
            my int $prim_flag := @flags[0] || @flags[1];
            my int $allo_idx := @allomorphs[0] ?? 0 !! 1;
            if @allomorphs[$allo_idx] eq @allo_map[$prim_flag] {
                @flags[$allo_idx] := $prim_flag;
            }
        }
        
        # Alternatively, a single arg that is allomorphic will prefer
        # the literal too.
        if @types == 1 && $num_allo == 1 {
            @flags[0] := %allo_rev{@allomorphs[0]} // 0;
        }
        
        [@types, @flags]
    }
    
    method report_inevitable_dispatch_failure($op, @types, @flags, $obj, :$protoguilt) {
        my @arg_names;
        my int $i := 0;
        while $i < +@types {
            @arg_names.push(
                @flags[$i] == 1 ?? 'int' !!
                @flags[$i] == 2 ?? 'num' !!
                @flags[$i] == 3 ?? 'str' !!
                @types[$i].HOW.name(@types[$i]));
            $i := $i + 1;
        }
        self.add_deadly($op,
            ($protoguilt ?? "Calling proto of '" !! "Calling '") ~ 
            $obj.name ~ "' " ~
            (+@arg_names == 0
              ?? "requires arguments"
              !! "will never work with argument types (" ~ join(', ', @arg_names) ~ ")"),
            $obj.is_dispatcher && !$protoguilt ??
                multi_sig_list($obj) !!
                ["    Expected: " ~ try $obj.signature.perl ]);
    }
    
    # Signature list for multis.
    sub multi_sig_list($dispatcher) {
        my @sigs := ["    Expected any of:"];
        for $dispatcher.dispatchees {
            @sigs.push("    " ~ $_.signature.perl);
        }
        @sigs
    }
    
    # Visits all of a nodes children, and dispatches appropriately.
    method visit_children($node, :$skip_selectors, :$resultchild, :$first) {
        my int $r := $resultchild // -1;
        my int $i := 0;
        my int $n := +@($node);
        while $i < $n {
            my $outer_void := $*VOID_CONTEXT;
            my $outer_decl := $*IN_DECLARATION;
            unless $skip_selectors && $i % 2 {
                my $*VOID_CONTEXT   := $outer_void || ($r != -1 && $i != $r);
                my $*IN_DECLARATION := $outer_decl || ($i == 0 && nqp::istype($node, QAST::Block));
                my $visit := $node[$i];
                if nqp::istype($visit, QAST::Op) {
                    $node[$i] := self.visit_op($visit)
                }
                elsif nqp::istype($visit, QAST::Want) {
                    $node[$i] := self.visit_want($visit);
                }
                elsif nqp::istype($visit, QAST::Var) {
                    $node[$i] := self.visit_var($visit);
                }
                elsif nqp::istype($visit, QAST::Block) {
                    $node[$i] := self.visit_block($visit);
                }
                elsif nqp::istype($visit, QAST::Stmts) {
                    self.visit_children($visit, :resultchild($visit.resultchild // +@($visit) - 1));
                }
                elsif nqp::istype($visit, QAST::Stmt) {
                    self.visit_children($visit, :resultchild($visit.resultchild // +@($visit) - 1));
                } elsif nqp::istype($visit, QAST::Regex) {
                    QRegex::Optimizer.new().optimize($visit, @!block_stack[+@!block_stack - 1], |%!adverbs);
                }
            }
            $i := $first ?? $n !! $i + 1;
        }
    }
    
    # Locates a lexical symbol and returns its compile time value. Dies if
    # it does not exist.
    method find_lexical($name) {
        my int $i := +@!block_stack;
        while $i > 0 {
            $i := $i - 1;
            my $block := @!block_stack[$i];
            my %sym := $block.symbol($name);
            if +%sym {
                if nqp::existskey(%sym, 'value') {
                    return %sym;
                }
                else {
                    nqp::die("Optimizer: No lexical compile time value for $name");
                }
            }
        }
        nqp::die("Optimizer: No lexical $name found");
    }
    
    # Checks if a given lexical is declared, though it needn't have a compile
    # time known value.
    method is_lexical_declared($name) {
        my int $i := +@!block_stack;
        while $i > 0 {
            $i := $i - 1;
            my $block := @!block_stack[$i];
            my %sym := $block.symbol($name);
            if +%sym {
                return 1;
            }
        }
        0
    }
    
    # Works out how many scopes in from the outermost a given name is. A 0
    # from this means the nearest declaration is from the setting; a 1 means
    # it is in the mainline, etc.
    method scopes_in($name) {
        my int $i := +@!block_stack;
        while $i > 0 {
            $i := $i - 1;
            my $block := @!block_stack[$i];
            my %sym := $block.symbol($name);
            if +%sym {
                return $i;
            }
        }
        nqp::die("Symbol $name not found");
    }
    
    # Inlines an immediate block.
    method inline_immediate_block($block, $outer) {
        # Sanity check.
        return $block if +@($block) != 2;

        # Extract interesting parts of block.
        my $decls := $block.shift;
        my $stmts := $block.shift;

        # Turn block into an "optimized out" stub (deserialization
        # or fixup will still want it to be there).
        $block.blocktype('declaration');
        $block[0] := QAST::Op.new( :op('die_s'),
            QAST::SVal.new( :value('INTERNAL ERROR: Execution of block eliminated by optimizer') ) );
        $outer[0].push($block);
        
        # Copy over interesting stuff in declaration section.
        for @($decls) {
            if nqp::istype($_, QAST::Op) && ($_.op eq 'p6bindsig' || 
                    $_.op eq 'bind' && $_[0].name eq 'call_sig') {
                # Don't copy this binder call or setup.
            }
            elsif nqp::istype($_, QAST::Op) && $_.op eq 'bind' && $_[0].name eq '$_' {
                # Don't copy the $_ initialization from outer.
            }
            elsif nqp::istype($_, QAST::Var) && ($_.name eq '$/' || $_.name eq '$!' ||
                    $_.name eq '$_' || $_.name eq '$*DISPATCHER') {
                # Don't copy this variable node.
            }
            elsif nqp::istype($_, QAST::Op) && $_.op eq 'takedispatcher' {
                # Don't copy the dispatcher take, since the $*DISPATCHER is
                # also not copied.
            }
            else {
                $outer[0].push($_);
            }
        }

        # Hand back the statements, but be sure to preserve $_
        # around them.
        $!pres_topic_counter := $!pres_topic_counter + 1;
        $outer[0].push(QAST::Var.new( :scope('local'),
            :name("pres_topic_$!pres_topic_counter"), :decl('var') ));
        return QAST::Stmts.new(
            :resultchild(1),
            QAST::Op.new( :op('bind'),
                QAST::Var.new( :name("pres_topic_$!pres_topic_counter"), :scope('local') ),
                QAST::Var.new( :name('$_'), :scope('lexical') )
            ),
            $stmts,
            QAST::Op.new( :op('bind'),
                QAST::Var.new( :name('$_'), :scope('lexical') ),
                QAST::Var.new( :name("pres_topic_$!pres_topic_counter"), :scope('local') )
            )
        );
    }
    
    # Inlines a call to a sub.
    method inline_call($call, $code_obj) {
        # If the code object is marked soft, can't inline it.
        if nqp::can($code_obj, 'soft') && $code_obj.soft {
            return $call;
        }
        
        # Bind the arguments to temporaries.
        my $inlined := QAST::Stmts.new();
        my @subs;
        for $call.list {
            my $temp_name := '_inline_arg_' ~ ($!inline_arg_counter := $!inline_arg_counter + 1);
            my $temp_type := $_.returns;
            $inlined.push(QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name($temp_name), :scope('local'), :returns($temp_type), :decl('var') ),
                $_));
            nqp::push(@subs, QAST::Var.new( :name($temp_name), :scope('local'), :returns($temp_type) ));
        }
        
        # Now do the inlining.
        $inlined.push($code_obj.inline_info.substitute_inline_placeholders(@subs));
        if $call.named -> $name {
            $inlined.named($name);
        }
        $inlined.node($call.node);
        
        $inlined
    }
    
    # If we decide a dispatch at compile time, this emits the direct call.
    method call_ct_chosen_multi($call, $proto, $chosen) {
        my @cands := $proto.dispatchees();
        my int $idx := 0;
        for @cands {
            if $_ =:= $chosen {
                $call.unshift(QAST::Op.new(
                    :op('atpos'),
                    QAST::Var.new(
                        :name('$!dispatchees'), :scope('attribute'),
                        QAST::Var.new( :name($call.name), :scope('lexical') ),
                        QAST::WVal.new( :value(self.find_lexical('Routine')) )
                    ),
                    QAST::IVal.new( :value($idx) )
                ));
                $call.name(NQPMu);
                $call.op('call');
                #say("# Compile-time resolved a call to " ~ $proto.name);
                last;
            }
            $idx := $idx + 1;
        }
        $call := copy_returns($call, $chosen);
        $call
    }
    
    # Adds an entry to the list of things that would cause a check fail.
    method add_deadly($past_node, $message, @extras?) {
        self.add_memo($past_node, $message, @extras, :type);
    }
    # Adds an entry to the list of things that would just warn
    method add_worry($past_node, $message, @extras?) {
        self.add_memo($past_node, $message, @extras, :type);
    }

    method add_memo($past_node, $message, @extras?, :$type!) {
        my $mnode := $past_node.node;
        my $line := HLL::Compiler.lineof($mnode.orig, $mnode.from, :cache(1));
        my $key := $message ~ (+@extras ?? "\n" ~ join("\n", @extras) !! "");
        my %cont := $type eq 'deadly' ?? %!deadly !! %!worrying;
        unless %cont{$key} {
            %cont{$key} := [];
        }
        %cont{$key}.push($line);

    }
    
    my @prim_spec_ops := ['', 'p6box_i', 'p6box_n', 'p6box_s'];
    my @prim_spec_flags := ['', 'Ii', 'Nn', 'Ss'];
    sub copy_returns($to, $from) {
        if nqp::can($from, 'returns') {
            my $ret_type := $from.returns();
            if nqp::objprimspec($ret_type) -> $primspec {
                $to := QAST::Want.new(
                    :named($to.named),
                    QAST::Op.new( :op(@prim_spec_ops[$primspec]), $to ),
                    @prim_spec_flags[$primspec], $to);
            }
            $to.returns($ret_type);
        }
        $to
    }
}
rakudo-2013.12/src/Perl6/Pod.nqp0000664000175000017500000003560712224263172015640 0ustar  moritzmoritz# various helper methods for Pod parsing and processing
class Perl6::Pod {
    our sub document($/, $what, $with) {
        if ~$with ne '' {
            $*W.apply_trait($/, '&trait_mod:', $what, :docs($*DOCEE));
            # don't reset it if it already holds docs for another element
            if $*DECLARATOR_DOCS && $*DOC.to == $*DECLARATOR_DOCS.to {
                $*DECLARATOR_DOCS := '';
            }
        }
    }

    our sub any_block($/) {
        my @children := [];
        my $type;
        my $leveled;
        my $config := $.ast;

        if $.Str ~~ /^item \d*$/ {
            $type    := 'Pod::Item';
            $leveled := 1;
        } elsif $.Str ~~ /^head \d+$/ {
            $type    := 'Pod::Heading';
            $leveled := 1;
        } else {
            $type := 'Pod::Block::Named';
        }

        for $ {
            @children.push($_.ast);
        }

        my $content := serialize_array(@children);
        if $leveled {
            my $level := nqp::substr($.Str, 4);
            my $level_past;
            if $level ne '' {
                $level_past := $*W.add_constant(
                    'Int', 'int', +$level,
                ).compile_time_value;
            } else {
                $level_past := $*W.find_symbol(['Mu']);
            }

            my $past := serialize_object(
                $type, :level($level_past), :config($config),
                :content($content.compile_time_value)
            );
            return $past.compile_time_value;
        }

        my $name := $*W.add_constant('Str', 'str', $.Str);
        my $past := serialize_object(
            'Pod::Block::Named', :name($name.compile_time_value),
            :config($config), :content($content.compile_time_value),
        );
        return $past.compile_time_value;
    }

    our sub raw_block($/) {
        my $config := $.ast;
        my $str := $*W.add_constant('Str', 'str', ~$);
        my $content := serialize_array([$str.compile_time_value]);
        my $type := $.Str eq 'code' ?? 'Pod::Block::Code'
                                          !! 'Pod::Block::Comment';
        my $past := serialize_object(
            $type, :config($config),
            :content($content.compile_time_value),
        );
        return $past.compile_time_value;
    }

    our sub config($/) {
        my $type := $*W.add_constant('Str', 'str', ~$);
        return serialize_object(
            'Pod::Config', :type($type.compile_time_value),
            :config($.ast)
        ).compile_time_value
    }

    our sub make_config($/) {
        my @pairs;
        for $ -> $colonpair {
            my $key := $colonpair;
            my $val;
            # This is a cheaty and evil hack. This is also the only way
            # I can obtain this information without reimplementing
            #  entirely
            if $colonpair {
                $val := $colonpair;
                if $val {
                    $val := $*W.colonpair_nibble_to_str($/, $val);
                } else {
                    $val := ~$val;
                }
            } else {
                # and this is the worst hack of them all.
                # Hide your kids, hide your wife!
                my $truth := nqp::substr($colonpair, 1, 1) ne '!';

                $val := $*W.add_constant('Int', 'int', $truth).compile_time_value;
            }

            if $key eq "allow" {
                my $chars := nqp::chars($val);
                my $pos := 0;
                while $pos < $chars {
                    my $char := nqp::substr($val, $pos, 1);
                    if $char eq " " {
                        $pos := $pos + 1;
                    } else {
                        my $bitval := nqp::ord($char) - nqp::ord("A");
                        if $bitval >= 0 && $bitval <= 25 {
                            $*POD_ALLOW_FCODES := $*POD_ALLOW_FCODES +| (2 ** $bitval);
                        }
                        $pos := $pos + 2;
                    }
                }
            }

            $key := $*W.add_constant('Str', 'str', $key).compile_time_value;
            $val := $*W.add_constant('Str', 'str', $val).compile_time_value;
            @pairs.push(
                serialize_object(
                    'Pair', :key($key), :value($val)
                ).compile_time_value
            );
        }
        return serialize_object('Hash', |@pairs).compile_time_value;
    }

    our sub formatted_text($a) {
        my $r := subst($a, /\s+/, ' ', :global);
        $r    := subst($r, /^^\s*/, '');
        $r    := subst($r, /\s*$$/, '');
        return $r;
    }
    our sub table($/) {
        my $config := $.ast;

        my @rows := [];
        for $ {
            @rows.push($_.ast);
        }
        @rows := process_rows(@rows);
        # we need to know 3 things about the separators:
        #   is there more than one
        #   where is the first one
        #   are they different from each other
        # Given no separators, our table is just an ordinary, one-lined
        # table.
        # If there is one separator, the table has a header and
        # the actual content. If the first header is further than on the
        # second row, then the header is multi-lined.
        # If there's more than one separator, the table has a multi-line
        # header and a multi-line content.
        # Tricky, isn't it? Let's try to handle it sanely
        my $sepnum        := 0;
        my $firstsepindex := 0;
        my $differentseps := 0;
        my $firstsep;
        my $i := 0;
        while $i < +@rows {
            unless nqp::islist(@rows[$i]) {
                $sepnum := $sepnum + 1;
                unless $firstsepindex { $firstsepindex := $i }
                if $firstsep {
                    if $firstsep ne @rows[$i] { $differentseps := 1 }
                } else {
                    $firstsep := @rows[$i];
                }
            }
            $i := $i + 1;
        }

        my $headers := [];
        my $content := [];

        if $sepnum == 0 {
            # ordinary table, no headers, one-lined rows
            $content := @rows;
        } elsif $sepnum == 1 {
            if $firstsepindex == 1 {
                # one-lined header, one-lined rows
                $headers := @rows.shift;
                @rows.shift; # remove the separator
                $content := @rows;
            } else {
                # multi-line header, one-lined rows
                my $i := 0;
                my @hlines := [];
                while $i < $firstsepindex {
                    @hlines.push(@rows.shift);
                    $i := $i + 1;
                }
                $headers := merge_rows(@hlines);
                @rows.shift; # remove the separator
                $content := @rows;
            }
        } else {
            my @hlines := [];
            my $i := 0;
            if $differentseps {
                while $i < $firstsepindex {
                    @hlines.push(@rows.shift);
                    $i := $i + 1;
                }
                @rows.shift;
                $headers := merge_rows(@hlines);
            }
            # let's go through the rows and merge the multi-line ones
            my @newrows := [];
            my @tmp  := [];
            $i       := 0;
            while $i < +@rows {
                if nqp::islist(@rows[$i]) {
                    @tmp.push(@rows[$i]);
                } else {
                    @newrows.push(merge_rows(@tmp));
                    @tmp := [];
                }
                $i := $i + 1;
            }
            if +@tmp > 0 {
                @newrows.push(merge_rows(@tmp));
            }
            $content := @newrows;
        }

        my $past := serialize_object(
            'Pod::Block::Table', :config($config),
            :headers(serialize_aos($headers).compile_time_value),
            :content(serialize_aoaos($content).compile_time_value),
        );
        make $past.compile_time_value;
    }

    our sub process_rows(@rows) {
        # remove trailing blank lines
        @rows.pop while @rows[+@rows - 1] ~~ /^ \s* $/;
        # find the longest leading whitespace and strip it
        # from every row, also remove trailing \n
        my $w := -1; # the longest leading whitespace
        for @rows -> $row {
            next if $row ~~ /^^\s*$$/;
            my $match := $row ~~ /^^\s+/;
            my $n := $match.to;
            if $n < $w || $w == -1 {
                $w := $n;
            }
        }
        my $i := 0;
        while $i < +@rows {
            unless @rows[$i] ~~ /^^\s*$$/ {
                @rows[$i] := nqp::substr(@rows[$i], $w);
            }
            # chomp
            @rows[$i] := subst(@rows[$i], /\n$/, '');
            $i := $i + 1;
        }
        # split the row between cells
        my @res;
        $i := 0;
        while $i < +@rows {
            my $v := @rows[$i];
            if $v ~~ /^'='+ || ^'-'+ || ^'_'+ || ^\h*$/ {
                @res[$i] := $v;
            } elsif $v ~~ /\h'|'\h/ {
                my $m := $v ~~ /
                    :ratchet
                    ([ .]*)+
                    % [ [\h+ || ^^] '|' [\h || $$] ]
                /;
                @res[$i] := [];
                for $m[0] { @res[$i].push(formatted_text($_)) }
            } elsif $v ~~ /\h'+'\h/ {
                my $m := $v ~~ /
                    :ratchet ([ .]*)+
                    % [ [\h+ || ^^] '+' [\h+ || $$] ]
                /;
                @res[$i] := [];
                for $m[0] { @res[$i].push(formatted_text($_)) }
            } else {
                # now way to easily split rows
                return splitrows(@rows);
            }
            $i := $i + 1;
        }
        return @res;
    }

    our sub merge_rows(@rows) {
        my @result := @rows[0];
        my $i := 1;
        while $i < +@rows {
            my $j := 0;
            while $j < +@rows[$i] {
                if @rows[$i][$j] {
                    @result[$j] := formatted_text(
                        ~@result[$j] ~ ' ' ~ ~@rows[$i][$j]
                    );
                }
                $j := $j + 1;
            }
            $i := $i + 1;
        }
        return @result;
    }

    our sub merge_twines(@twines) {
        my @ret := @twines.shift.ast;
        for @twines {
            my @cur   := $_.ast;
            @ret.push(
                $*W.add_constant(
                    'Str', 'str',
                    nqp::unbox_s(@ret.pop) ~ ' ' ~ nqp::unbox_s(@cur.shift)
                ).compile_time_value,
            );
            nqp::splice(@ret, @cur, +@ret, 0);
        }
        return @ret;
    }

    our sub build_pod_string(@content) {
        sub push_strings(@strings, @where) {
            my $s := subst(nqp::join('', @strings), /\s+/, ' ', :global);
            my $t := $*W.add_constant(
                'Str', 'str', $s
            ).compile_time_value;
            @where.push($t);
        }

        my @res  := [];
        my @strs := [];
        for @content -> $elem {
            if nqp::isstr($elem) {
                # don't push the leading whitespace
                if +@res + @strs == 0 && $elem eq ' ' {

                } else {
                    @strs.push($elem);
                }
            } else {
                push_strings(@strs, @res);
                @strs := [];
                @res.push($elem);
            }
        }
        push_strings(@strs, @res);

        return @res;
    }


    # takes an array of strings (rows of a table)
    # returns array of arrays of strings (cells)
    our sub splitrows(@rows) {
        my @suspects := []; #positions that might be cell delimiters
                            # values: 1     - impossibru!
                            #         unset - mebbe

        my $i := 0;
        while $i < +@rows {
            unless @rows[$i] ~~ /^'='+ || ^'-'+ || ^'_'+ || ^\h*$ / {
                my @line := nqp::split('', @rows[$i]);
                my $j := 0;
                while $j < +@line {
                    unless @suspects[$j] {
                        if @line[$j] ne ' ' {
                            @suspects[$j] := 1;
                        }
                    }
                    $j := $j + 1;
                }
            }
            $i := $i + 1;
        }

        # now let's skip the single spaces
        $i := 0;
        while $i < +@suspects {
            unless @suspects[$i] {
                if @suspects[$i-1] && @suspects[$i+1] {
                    @suspects[$i] := 1;
                }
            }
            $i := $i + 1;
        }

        # now we're doing some magic which will
        # turn those positions into cell ranges
        # so for values: 13 14 15   30 31 32 33
        # we get [0, 13, 16, 30, 34, 0] (last 0 as a guard)

        my $wasone := 1;
        $i := 0;
        my @ranges := [];
        @ranges.push(0);

        while $i < +@suspects {
            if !$wasone && @suspects[$i] == 1 {
                @ranges.push($i);
                $wasone := 1;
            } elsif $wasone && @suspects[$i] != 1 {
                @ranges.push($i);
                $wasone := 0;
            }
            $i := $i + 1;
        }
        @ranges.push(0); # guard

        my @ret := [];
        for @rows -> $row {
            if $row ~~ /^'='+ || ^'-'+ || ^'_'+ || ^\h*$/ {
                @ret.push($row);
                next;
            }
            my @tmp := [];
            for @ranges -> $a, $b {
                next if $a > nqp::chars($row);
                if $b {
                    @tmp.push(
                        formatted_text(nqp::substr($row, $a, $b - $a))
                    );
                } else {
                    @tmp.push(
                        formatted_text(nqp::substr($row, $a))
                    );
                }
            }
            @ret.push(@tmp);
        }
        return @ret;
    }

    # serializes the given array
    our sub serialize_array(@arr) {
        return $*W.add_constant('Array', 'type_new', |@arr);
    }

    # serializes an array of strings
    our sub serialize_aos(@arr) {
        my @cells := [];
        for @arr -> $cell {
            my $p := $*W.add_constant('Str', 'str', ~$cell);
            @cells.push($p.compile_time_value);
        }
        return serialize_array(@cells);
    }

    # serializes an array of arrays of strings
    our sub serialize_aoaos(@rows) {
        my @content := [];
        for @rows -> $row {
            my $p := serialize_aos($row);
            @content.push($*W.scalar_wrap($p.compile_time_value));
        }
        return serialize_array(@content);
    }

    # serializes object of the given type
    our sub serialize_object($type, *@pos, *%named) {
        return $*W.add_constant($type, 'type_new', |@pos, |%named);
    }
}

# vim: ft=perl6
rakudo-2013.12/src/Perl6/World.nqp0000664000175000017500000027502412255230273016204 0ustar  moritzmoritzuse NQPHLL;
use QAST;
use Perl6::ModuleLoader;

# Binder constants.
# XXX Want constant syntax in NQP really.
my $SIG_ELEM_BIND_CAPTURE        := 1;
my $SIG_ELEM_BIND_PRIVATE_ATTR   := 2;
my $SIG_ELEM_BIND_PUBLIC_ATTR    := 4;
my $SIG_ELEM_SLURPY_POS          := 8;
my $SIG_ELEM_SLURPY_NAMED        := 16;
my $SIG_ELEM_SLURPY_LOL          := 32;
my $SIG_ELEM_INVOCANT            := 64;
my $SIG_ELEM_MULTI_INVOCANT      := 128;
my $SIG_ELEM_IS_RW               := 256;
my $SIG_ELEM_IS_COPY             := 512;
my $SIG_ELEM_IS_PARCEL           := 1024;
my $SIG_ELEM_IS_OPTIONAL         := 2048;
my $SIG_ELEM_ARRAY_SIGIL         := 4096;
my $SIG_ELEM_HASH_SIGIL          := 8192;
my $SIG_ELEM_DEFAULT_FROM_OUTER  := 16384;
my $SIG_ELEM_IS_CAPTURE          := 32768;
my $SIG_ELEM_UNDEFINED_ONLY      := 65536;
my $SIG_ELEM_DEFINED_ONLY        := 131072;
my $SIG_ELEM_NOMINAL_GENERIC     := 524288;
my $SIG_ELEM_DEFAULT_IS_LITERAL  := 1048576;
my $SIG_ELEM_NATIVE_INT_VALUE    := 2097152;
my $SIG_ELEM_NATIVE_NUM_VALUE    := 4194304;
my $SIG_ELEM_NATIVE_STR_VALUE    := 8388608;

sub p6ize_recursive($x) {
    if nqp::islist($x) {
        my @copy := [];
        for $x {
            nqp::push(@copy, p6ize_recursive($_));
        }
        return nqp::hllizefor(@copy, 'perl6');
    }
    elsif nqp::ishash($x) {
        my %copy := nqp::hash();
        for $x {
            %copy{$_.key} := p6ize_recursive($_.value);
        }
        return nqp::hllizefor(%copy, 'perl6').item;
    }
    nqp::hllizefor($x, 'perl6');
}

# this levenshtein implementation is used to suggest good alternatives
# when deriving from an unknown/typo'd class.
sub levenshtein($a, $b) {
    my %memo;
    my $alen := nqp::chars($a);
    my $blen := nqp::chars($b);

    return 0 if $alen eq 0 || $blen eq 0;

    # the longer of the two strings is an upper bound.
    #my $bound := $alen < $blen ?? $blen !! $alen;

    sub changecost($ac, $bc) {
        sub issigil($_) { nqp::index('$@%&|', $_) != -1 };
        return 0 if $ac eq $bc;
        return 0.5 if nqp::uc($ac) eq nqp::lc($bc);
        return 0.5 if issigil($ac) && issigil($bc);
        return 1;
    }

    sub levenshtein_impl($apos, $bpos, $estimate) {
        my $key := join(":", ($apos, $bpos));

        return %memo{$key} if nqp::existskey(%memo, $key);

        # if either cursor reached the end of the respective string,
        # the result is the remaining length of the other string.
        sub check($pos1, $len1, $pos2, $len2) {
            if $pos2 == $len2 {
                return $len1 - $pos1;
            }
            return -1;
        }

        my $check := check($apos, $alen, $bpos, $blen);
        return $check unless $check == -1;
        $check := check($bpos, $blen, $apos, $alen);
        return $check unless $check == -1;

        my $achar := nqp::substr($a, $apos, 1);
        my $bchar := nqp::substr($b, $bpos, 1);

        my $cost := changecost($achar, $bchar);

        # hyphens and underscores cost half when adding/deleting.
        my $addcost := 1;
        $addcost := 0.5 if $bchar eq "-" || $bchar eq "_";

        my $delcost := 1;
        $delcost := 0.5 if $achar eq "-" || $achar eq "_";

        my $ca := levenshtein_impl($apos+1, $bpos,   $estimate+$delcost) + $delcost; # what if we remove the current letter from A?
        my $cb := levenshtein_impl($apos,   $bpos+1, $estimate+$addcost) + $addcost; # what if we add the current letter from B?
        my $cc := levenshtein_impl($apos+1, $bpos+1, $estimate+$cost) + $cost; # what if we change/keep the current letter?

        # the result is the shortest of the three sub-tasks
        my $distance;
        $distance := $ca if $ca <= $cb && $ca <= $cc;
        $distance := $cb if $cb <= $ca && $cb <= $cc;
        $distance := $cc if $cc <= $ca && $cc <= $cb;

        # switching two letters costs only 1 instead of 2.
        if $apos + 1 <= $alen && $bpos + 1 <= $blen &&
           nqp::substr($a, $apos + 1, 1) eq $bchar &&
           nqp::substr($b, $bpos + 1, 1) eq $achar {
            my $cd := levenshtein_impl($apos+2, $bpos+2, $estimate+1) + 1;
            $distance := $cd if $cd < $distance;
        }

        %memo{$key} := $distance;
        return $distance;
    }

    my $result := levenshtein_impl(0, 0, 0);
    return $result;
}

sub make_levenshtein_evaluator($orig_name, @candidates) {
    my $Str-obj := $*W.find_symbol(["Str"]);
    my $find-count := 0;
    my $try-count := 0;
    sub inner($name, $object, $hash) {
        # difference in length is a good lower bound.
        $try-count := $try-count + 1;
        return 0 if $find-count > 20 || $try-count > 1000;
        my $parlen := nqp::chars($orig_name);
        my $lendiff := nqp::chars($name) - $parlen;
        $lendiff := -$lendiff if $lendiff < 0;
        return 1 if $lendiff >= $parlen * 0.3;

        my $dist := levenshtein($orig_name, $name) / $parlen;
        my $target := -1;
        $target := @candidates[0] if $dist <= 0.1;
        $target := @candidates[1] if 0.1 < $dist && $dist <= 0.2;
        $target := @candidates[2] if 0.2 < $dist && $dist <= 0.35;
        if $target != -1 {
            my $name-str := nqp::box_s($name, $Str-obj);
            nqp::push($target, $name-str);
            $find-count := $find-count + 1;
        }
        1;
    }
    return &inner;
}

sub levenshtein_candidate_heuristic(@candidates, $target) {
    # only take a few suggestions
    my $to-add := 5;
    for @candidates[0] {
        $target.push($_) if $to-add > 0;
        $to-add := $to-add - 1;
    }
    $to-add := $to-add - 1 if +@candidates[0] > 0;
    for @candidates[1] {
        $target.push($_) if $to-add > 0;
        $to-add := $to-add - 1;
    }
    $to-add := $to-add - 2 if +@candidates[1] > 0;
    for @candidates[2] {
        $target.push($_) if $to-add > 0;
        $to-add := $to-add - 1;
    }
}

# This builds upon the HLL::World to add the specifics needed by Rakudo Perl 6.
class Perl6::World is HLL::World {
    # The stack of lexical pads, actually as QAST::Block objects. The
    # outermost frame is at the bottom, the latest frame is on top.
    has @!BLOCKS;
    
    # The stack of code objects; phasers get attached to the top one.
    has @!CODES;
    
    # Mapping of sub IDs to their proto code objects; used for fixing
    # up in dynamic compilation.
    has %!sub_id_to_code_object;

    # Mapping of sub IDs to SC indexes of code stubs.
    has %!sub_id_to_sc_idx;
    
    # Mapping of QAST::Stmts node containing fixups, keyed by sub ID. If
    # we do dynamic compilation then we do the fixups immediately and
    # then clear this list.
    has %!code_object_fixup_list;
    
    # Array of stubs to check and the end of compilation.
    has @!stub_check;
    
    # Array of protos that can have their candidates pre-sorted at CHECK
    # time.
    has @!protos_to_sort;
    
    # Cached constants that we've built.
    has %!const_cache;
    
    # List of CHECK blocks to run.
    has @!CHECKs;
    
    # Clean-up tasks, to do after CHECK time.
    has @!cleanup_tasks;
    
    # Cache of container info and descriptor for magicals.
    has %!magical_cds;
    
    method BUILD(*%adv) {
        @!BLOCKS := [];
        @!CODES := [];
        @!stub_check := [];
        @!protos_to_sort := [];
        @!CHECKs := [];
        %!sub_id_to_code_object := {};
        %!sub_id_to_sc_idx := {};
        %!code_object_fixup_list := {};
        %!const_cache := {};
        @!cleanup_tasks := [];
        %!magical_cds := {};
    }
    
    # Creates a new lexical scope and puts it on top of the stack.
    method push_lexpad($/) {
        # Create pad, link to outer and add to stack.
        my $pad := QAST::Block.new( QAST::Stmts.new(), :node($/) );
        if +@!BLOCKS {
            $pad := @!BLOCKS[+@!BLOCKS - 1];
        }
        @!BLOCKS[+@!BLOCKS] := $pad;
        $pad
    }
    
    # Pops a lexical scope off the stack.
    method pop_lexpad() {
        @!BLOCKS.pop()
    }
    
    # Gets the top lexpad.
    method cur_lexpad() {
        @!BLOCKS[+@!BLOCKS - 1]
    }
    
    # Marks the current lexpad as being a signatured block.
    method mark_cur_lexpad_signatured() {
        @!BLOCKS[+@!BLOCKS - 1] := 1;
    }
    
    # Finds the nearest signatured block and checks if it declares
    # a certain symbol.
    method nearest_signatured_block_declares($symbol) {
        my $i := +@!BLOCKS;
        while $i > 0 {
            $i := $i - 1;
            if @!BLOCKS[$i] {
                return +@!BLOCKS[$i].symbol($symbol);
            }
        }
    }
    
    # Pushes a stub on the "stubs to check" list.
    method add_stub_to_check($stub) {
        nqp::push(@!stub_check, $stub);
    }
    
    # Adds a proto to be sorted at CHECK time.
    method add_proto_to_sort($proto) {
        nqp::push(@!protos_to_sort, $proto);
    }
    
    # Checks for any stubs that weren't completed.
    method assert_stubs_defined($/) {
        my @incomplete;
        for @!stub_check {
            unless $_.HOW.is_composed($_) {
                @incomplete.push($_.HOW.name($_));
            }
        }
        if +@incomplete {
            self.throw($/, 'X::Package::Stubbed', packages => @incomplete);
        }
    }
    
    # Sorts all protos.
    method sort_protos() {
        for @!protos_to_sort {
            if nqp::can($_, 'sort_dispatchees') {
                $_.sort_dispatchees();
            }
        }
    }
    
    # Loads a setting.
    method load_setting($/, $setting_name) {
        # Do nothing for the NULL setting.
        if $setting_name ne 'NULL' {    
            # Load it immediately, so the compile time info is available.
            # Once it's loaded, set it as the outer context of the code
            # being compiled.
            my $setting := %*COMPILING<%?OPTIONS>
                        := Perl6::ModuleLoader.load_setting($setting_name);
            
            # Add a fixup and deserialization task also.
            my $fixup := QAST::Stmt.new(
                self.perl6_module_loader_code(),
                QAST::Op.new(
                    :op('forceouterctx'),
                    QAST::BVal.new( :value($*UNIT_OUTER) ),
                    QAST::Op.new(
                        :op('callmethod'), :name('load_setting'),
                        QAST::Op.new(
                            :op('getcurhllsym'),
                            QAST::SVal.new( :value('ModuleLoader') )
                        ),
                        QAST::SVal.new( :value($setting_name) )
                    )
                )
            );
            self.add_load_dependency_task(:deserialize_past($fixup), :fixup_past($fixup));
            
            return nqp::ctxlexpad($setting);
        }
    }
    
    # Loads a module immediately, and also makes sure we load it
    # during the deserialization.
    method load_module($/, $module_name, %opts, $cur_GLOBALish) {
        # Immediate loading.
        my $line   := HLL::Compiler.lineof($/.orig, $/.from, :cache(1));
        my $module := nqp::gethllsym('perl6', 'ModuleLoader').load_module($module_name, %opts,
            $cur_GLOBALish, :$line);
        
        # During deserialization, ensure that we get this module loaded.
        if self.is_precompilation_mode() {
            my $opt_hash := QAST::Op.new( :op('hash') );
            for %opts {
                self.add_object($_.value);
                $opt_hash.push(QAST::SVal.new( :value($_.key) ));
                $opt_hash.push(QAST::WVal.new( :value($_.value) ));
            }
            self.add_load_dependency_task(:deserialize_past(QAST::Stmts.new(
                self.perl6_module_loader_code(),
                QAST::Op.new(
                   :op('callmethod'), :name('load_module'),
                   QAST::Op.new( :op('getcurhllsym'),
                        QAST::SVal.new( :value('ModuleLoader') ) ),
                   QAST::SVal.new( :value($module_name) ),
                   $opt_hash,
                   QAST::IVal.new(:value($line), :named('line'))
                ))));
        }

        return $module;
    }
    
    # Uses the NQP module loader to load Perl6::ModuleLoader, which
    # is a normal NQP module.
    method perl6_module_loader_code() {
        QAST::Stmt.new(
            QAST::Op.new(
                :op('loadbytecode'),
                QAST::VM.new(
                    :parrot(QAST::SVal.new( :value('ModuleLoader.pbc') )),
                    :jvm(QAST::SVal.new( :value('ModuleLoader.class') ))
                )),
            QAST::Op.new(
                :op('callmethod'), :name('load_module'),
                QAST::Op.new(
                    :op('gethllsym'),
                    QAST::SVal.new( :value('nqp') ),
                    QAST::SVal.new( :value('ModuleLoader') )
                ),
                QAST::SVal.new( :value('Perl6::ModuleLoader') )
            ))
    }
    
    # Imports symbols from the specified stash into the current lexical scope.
    method import($/, %stash, $source_package_name) {
        # What follows is a two-pass thing for historical reasons.
        my $target := self.cur_lexpad();
        
        # First pass: QAST::Block symbol table installation. Also detect any
        # outright conflicts, and handle any situations where we need to merge.
        my %to_install;
        my @clash;
        my @clash_onlystar;
        for %stash {
            if $target.symbol($_.key) -> %sym {
                # There's already a symbol. However, we may be able to merge
                # if both are multis and have onlystar dispatchers.
                my $installed := %sym;
                my $foreign := $_.value;
                if $installed =:= $foreign {
                    next;
                }
                if nqp::can($installed, 'is_dispatcher') && $installed.is_dispatcher
                && nqp::can($foreign, 'is_dispatcher') && $foreign.is_dispatcher {
                    # Both dispatchers, but are they onlystar? If so, we can
                    # go ahead and merge them.
                    if $installed.onlystar && $foreign.onlystar {
                        # Replace installed one with a derived one, to avoid any
                        # weird action at a distance.
                        $installed := self.derive_dispatcher($installed);
                        self.install_lexical_symbol($target, $_.key, $installed, :clone(1));
                        
                        # Incorporate dispatchees of foreign proto, avoiding
                        # duplicates.
                        my %seen;
                        for $installed.dispatchees {
                            %seen{$_.static_id} := $_;
                        }
                        for $foreign.dispatchees {
                            unless nqp::existskey(%seen, $_.static_id) {
                                self.add_dispatchee_to_proto($installed, $_);
                            }
                        }
                    }
                    else {
                        nqp::push(@clash_onlystar, $_.key);
                    }
                }
                else {
                    nqp::push(@clash, $_.key);
                }
            }
            else {
                $target.symbol($_.key, :scope('lexical'), :value($_.value));
                $target[0].push(QAST::Var.new(
                    :scope('lexical'), :name($_.key), :decl('static'), :value($_.value)
                ));
                %to_install{$_.key} := $_.value;
            }
        }

        if +@clash_onlystar {
            self.throw($/, 'X::Import::OnlystarProto',
                symbols             => @clash_onlystar,
                source-package-name => $source_package_name,
            );
        }

        if +@clash {
            self.throw($/, 'X::Import::Redeclaration',
                symbols             => @clash,
                source-package-name => $source_package_name,
            );
        }
        
        # Second pass: make sure installed things are in an SC and handle
        # categoricals.
        for %to_install {
            my $v := $_.value;
            if nqp::isnull(nqp::getobjsc($v)) { self.add_object($v); }
            my $categorical := match($_.key, /^ '&' (\w+) ':<' (.+) '>' $/);
            if $categorical {
                $/.CURSOR.add_categorical(~$categorical[0], ~$categorical[1],
                    ~$categorical[0] ~ ':sym<' ~$categorical[1] ~ '>',
                    $_.key, $_.value);
            }
        }
    }
    
    # Installs something package-y in the right place, creating the nested
    # pacakges as needed.
    method install_package($/, @name_orig, $scope, $pkgdecl, $package, $outer, $symbol) {
        if $scope eq 'anon' { return 1 }
        my @parts := nqp::clone(@name_orig);
        my $name  := @parts.pop();
        my $create_scope := $scope;
        my $cur_pkg := $package;
        my $cur_lex := $outer;
        
        # Can only install packages as our or my scope.
        unless $create_scope eq 'my' || $create_scope eq 'our' {
            self.throw($/, 'X::Declaration::Scope',
                scope       => $*SCOPE,
                declaration => $pkgdecl,
            );
        }
        
        # If we have a multi-part name, see if we know the opening
        # chunk already. If so, use it for that part of the name.
        if +@parts {
            try {
                $cur_pkg := $*W.find_symbol([@parts[0]]);
                $cur_lex := 0;
                $create_scope := 'our';
                @parts.shift();
            }
        }
        
        # Chase down the name, creating stub packages as needed.
        while +@parts {
            my $part := @parts.shift;
            if nqp::existskey($cur_pkg.WHO, $part) {
                $cur_pkg := ($cur_pkg.WHO){$part};
            }
            else {
                my $new_pkg := self.pkg_create_mo($/, %*HOW, :name($part));
                self.pkg_compose($new_pkg);
                if $create_scope eq 'my' || $cur_lex {
                    self.install_lexical_symbol($cur_lex, $part, $new_pkg);
                }
                if $create_scope eq 'our' {
                    self.install_package_symbol($cur_pkg, $part, $new_pkg);
                }
                $cur_pkg := $new_pkg;
                $create_scope := 'our';
                $cur_lex := 0;
            }
        }
        
        # Install final part of the symbol.
        if $create_scope eq 'my' || $cur_lex {
            self.install_lexical_symbol($cur_lex, $name, $symbol);
        }
        if $create_scope eq 'our' {
            if nqp::existskey($cur_pkg.WHO, $name) {
                self.steal_WHO($symbol, ($cur_pkg.WHO){$name});
            }
            self.install_package_symbol($cur_pkg, $name, $symbol);
        }
        
        1;
    }
    
    # If we declare class A::B { }, then class A { }, then A.WHO must be the
    # .WHO we already created for the stub package A.
    method steal_WHO($thief, $victim) {
        nqp::setwho($thief, $victim.WHO);
    }
    
    # Installs a lexical symbol. Takes a QAST::Block object, name and
    # the object to install. Does an immediate installation in the
    # compile-time block symbol table, and ensures that the installation
    # gets fixed up at runtime too.
    method install_lexical_symbol($block, $name, $obj, :$clone) {
        # Install the object directly as a block symbol.
        if nqp::isnull(nqp::getobjsc($obj)) {
            self.add_object($obj);
        }
        if $block.symbol($name) {
            for @($block[0]) {
                if nqp::istype($_, QAST::Var) && $_.name eq $name {
                    $_.decl('static');
                    $_.value($obj);
                    last;
                }
            }
        }
        else {
            $block[0].push(QAST::Var.new(
                :scope('lexical'), :name($name), :decl('static'), :value($obj)
            ));
        }
        $block.symbol($name, :scope('lexical'), :value($obj));
        
        # Add a clone if needed.
        if $clone {
            $block[0].push(QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name($name), :scope('lexical') ),
                QAST::Op.new(
                    :op('p6capturelex'),
                    QAST::Op.new(
                        :op('callmethod'), :name('clone'),
                        QAST::Var.new( :name($name), :scope('lexical') )
                    ))));
        }
    }
    
    # Installs a lexical symbol. Takes a QAST::Block object, name and
    # the type of container to install.
    method install_lexical_container($block, $name, %cont_info, $descriptor, :$scope, :$package) {
        # Add to block, if needed. Note that it doesn't really have
        # a compile time value.
        my $var;
        if $block.symbol($name) {
            for @($block[0]) {
                if nqp::istype($_, QAST::Var) && $_.name eq $name {
                    $var := $_;
                    last;
                }
            }
        }
        else {
            $var := QAST::Var.new(
                :scope('lexical'), :name($name), :decl('var'),
                :returns(%cont_info)
            );
            $block[0].push($var);
        }
        $block.symbol($name, :scope('lexical'), :type(%cont_info), :descriptor($descriptor));
            
        # If it's a native type, no container as we inline natives straight
        # into registers. Do need to take care of initial value though.
        my $prim := nqp::objprimspec($descriptor.of);
        if $prim {
            if $scope eq 'state' { nqp::die("Natively typed state variables not yet implemented") }
            if $prim == 1 {
                $block[0].push(QAST::Op.new( :op('bind'),
                    QAST::Var.new( :scope('lexical'), :name($name) ),
                    QAST::IVal.new( :value(0) ) ))
            }
            elsif $prim == 2 {
                $block[0].push(QAST::Op.new( :op('bind'),
                    QAST::Var.new( :scope('lexical'), :name($name) ),
                    QAST::Op.new( :op('nan') )));
            }
            elsif $prim == 3 {
                $block[0].push(QAST::Op.new( :op('bind'),
                    QAST::Var.new( :scope('lexical'), :name($name) ),
                    QAST::SVal.new( :value('') ) ))
            }
            return nqp::null();
        }
        
        # Build container.
        my $cont := nqp::create(%cont_info);
        nqp::bindattr($cont, %cont_info, '$!descriptor', $descriptor);
        if nqp::existskey(%cont_info, 'scalar_value') {
            nqp::bindattr($cont, %cont_info, '$!value',
                %cont_info);
        }
        self.add_object($cont);
        $block.symbol($name, :value($cont));
        self.install_package_symbol($package, $name, $cont) if $scope eq 'our';
        
        # Tweak var to have container.
        $var.value($cont);
        $var.decl($scope eq 'state' ?? 'statevar' !! 'contvar');
        
        # Evaluate to the container.
        $cont
    }
    
    # Creates a new container descriptor and adds it to the SC.
    method create_container_descriptor($of, $rw, $name, $default = $of, $dynamic = nqp::chars($name) > 2 && nqp::substr($name, 1, 1) eq "*") {
        my $cd_type := self.find_symbol(['ContainerDescriptor']);
        my $cd := $cd_type.new( :$of, :$rw, :$name, :$default, :$dynamic );
        self.add_object($cd);
        $cd
    }
    
    # Installs one of the magical lexicals ($_, $/ and $!). Uses a cache to
    # avoid massive duplication of container descriptors.
    method install_lexical_magical($block, $name) {
        my %info;
        my $desc;
        
        if nqp::existskey(%!magical_cds, $name) {
            %info := %!magical_cds{$name}[0];
            $desc := %!magical_cds{$name}[1];
        }
        else {
            my $Mu     := self.find_symbol(['Mu']);
            my $Nil    := self.find_symbol(['Nil']);
            my $Scalar := self.find_symbol(['Scalar']);
            
            %info := nqp::hash(
                'container_base',  $Scalar,
                'container_type',  $Scalar,
                'bind_constraint', $Mu,
                'value_type',      $Mu,
                'default_value',   $Nil,
                'scalar_value',    $Nil,
            );
            $desc := self.create_container_descriptor($Mu, 1, $name, $Nil, 1);

            %!magical_cds{$name} := [%info, $desc];
        }
        
        self.install_lexical_container($block, $name, %info, $desc);
    }
    
    # Builds PAST that constructs a container.
    method build_container_past(%cont_info, $descriptor) {
        # Create container and set descriptor.
        my $tmp := QAST::Node.unique('cont');
        my $cont_code := QAST::Stmts.new(
            :resultchild(0),
            QAST::Op.new(
                :op('bind'),
                QAST::Var.new( :name($tmp), :scope('local'), :decl('var') ),
                QAST::Op.new(
                    :op('create'),
                    QAST::WVal.new( :value(%cont_info) ))),
            QAST::Op.new(
                :op('bindattr'),
                QAST::Var.new( :name($tmp), :scope('local') ),
                QAST::WVal.new( :value(%cont_info) ),
                QAST::SVal.new( :value('$!descriptor') ),
                QAST::WVal.new( :value($descriptor) )));
        
        # Default contents, if applicable (note, slurpy param as we can't
        # use definedness here, as it's a type object we'd be checking).
        if nqp::existskey(%cont_info, 'scalar_value') {
            $cont_code.push(QAST::Op.new(
                :op('bindattr'),
                QAST::Var.new( :name($tmp), :scope('local') ),
                QAST::WVal.new( :value(%cont_info) ),
                QAST::SVal.new( :value('$!value') ),
                QAST::WVal.new( :value(%cont_info) )));
        }
        
        $cont_code
    }
    
    # Hunts through scopes to find the type of a lexical.
    method find_lexical_container_type($name) {
        my int $i := +@!BLOCKS;
        while $i > 0 {
            $i := $i - 1;
            my %sym := @!BLOCKS[$i].symbol($name);
            if +%sym {
                if nqp::existskey(%sym, 'type') {
                    return %sym;
                }
                else {
                    $i := 0;
                }
            }
        }
        nqp::die("Could not find container descriptor for $name");
    }
    
    # Installs a symbol into the package.
    method install_package_symbol($package, $name, $obj) {
        ($package.WHO){$name} := $obj;
        1;
    }
    
    # Creates a parameter object.
    method create_parameter(%param_info) {
        # Create parameter object now.
        my $par_type  := self.find_symbol(['Parameter']);
        my $parameter := nqp::create($par_type);
        self.add_object($parameter);
        
        # Calculate flags.
        my int $flags := 0;
        if %param_info {
            $flags := $flags + $SIG_ELEM_IS_OPTIONAL;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_INVOCANT;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_MULTI_INVOCANT;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_IS_RW;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_IS_COPY;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_IS_PARCEL;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_IS_CAPTURE;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_UNDEFINED_ONLY;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_DEFINED_ONLY;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_SLURPY_POS;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_SLURPY_NAMED;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_SLURPY_LOL;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_BIND_PRIVATE_ATTR;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_BIND_PUBLIC_ATTR;
        }
        if %param_info eq '@' {
            $flags := $flags + $SIG_ELEM_ARRAY_SIGIL;
        }
        elsif %param_info eq '%' {
            $flags := $flags + $SIG_ELEM_HASH_SIGIL;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_DEFAULT_FROM_OUTER;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_NOMINAL_GENERIC;
        }
        if %param_info {
            $flags := $flags + $SIG_ELEM_DEFAULT_IS_LITERAL;
        }
        my $primspec := nqp::objprimspec(%param_info);
        if $primspec == 1 {
            $flags := $flags + $SIG_ELEM_NATIVE_INT_VALUE;
        }
        elsif $primspec == 2 {
            $flags := $flags + $SIG_ELEM_NATIVE_NUM_VALUE;
        }
        elsif $primspec == 3 {
            $flags := $flags + $SIG_ELEM_NATIVE_STR_VALUE;
        }
        
        # Populate it.
        if nqp::existskey(%param_info, 'variable_name') {
            nqp::bindattr_s($parameter, $par_type, '$!variable_name', %param_info);
        }
        nqp::bindattr($parameter, $par_type, '$!nominal_type', %param_info);
        nqp::bindattr_i($parameter, $par_type, '$!flags', $flags);
        if %param_info {
            my @names := %param_info;
            nqp::bindattr($parameter, $par_type, '$!named_names', @names);
        }
        if %param_info {
            my @type_names := %param_info;
            nqp::bindattr($parameter, $par_type, '$!type_captures', @type_names);
        }
        if %param_info {
            nqp::bindattr($parameter, $par_type, '$!post_constraints',
                %param_info);
        }
        if nqp::existskey(%param_info, 'default_value') {
            nqp::bindattr($parameter, $par_type, '$!default_value', %param_info);
        }
        if nqp::existskey(%param_info, 'container_descriptor') {
            nqp::bindattr($parameter, $par_type, '$!container_descriptor', %param_info);
        }
        if nqp::existskey(%param_info, 'attr_package') {
            nqp::bindattr($parameter, $par_type, '$!attr_package', %param_info);
        }
        if nqp::existskey(%param_info, 'sub_signature') {
            nqp::bindattr($parameter, $par_type, '$!sub_signature', %param_info);
        }

        # Return created parameter.
        $parameter
    }
    
    # Creates a signature object from a set of parameters.
    method create_signature(%signature_info) {
        # Create signature object now.
        my $sig_type   := self.find_symbol(['Signature']);
        my $signature  := nqp::create($sig_type);
        my @parameters := %signature_info;
        self.add_object($signature);
        
        # Set parameters.
        nqp::bindattr($signature, $sig_type, '$!params', @parameters);
        if nqp::existskey(%signature_info, 'returns') {
            nqp::bindattr($signature, $sig_type, '$!returns', %signature_info);
        }
        
        # Return created signature.
        $signature
    }

    method compile_time_evaluate($/, $ast) {
        return $ast.compile_time_value if $ast.has_compile_time_value;
        my $thunk := self.create_thunk($/, $ast);
        $thunk();
    }

    # Turn a QAST tree into a code object, to be called immediately.
    method create_thunk($/, $to_thunk) {
        my $block := self.push_lexpad($/);
        $block.push($to_thunk);
        self.pop_lexpad();
        self.create_simple_code_object($block, 'Code');
    }

    # Creates a simple code object with an empty signature
    method create_simple_code_object($block, $type) {
        self.cur_lexpad()[0].push($block);
        my $sig := self.create_signature(nqp::hash('parameters', []));
        return self.create_code_object($block, $type, $sig);
    }
    
    # Creates a code object of the specified type, attached the passed signature
    # object and sets up dynamic compilation thunk.
    method create_code_object($code_past, $type, $signature, $is_dispatcher = 0, :$yada) {
        my $code := self.stub_code_object($type);
        self.attach_signature($code, $signature);
        self.finish_code_object($code, $code_past, $is_dispatcher, :yada($yada));
        self.add_phasers_handling_code($code, $code_past);
        $code
    }

    method create_lazy($/, $code) {
        my $type      := self.find_symbol(['LazyScalar']);
        my $container := $type.new($code);
        self.add_object($container);
        QAST::WVal.new( :value($container) )
    }
    
    # Stubs a code object of the specified type.
    method stub_code_object($type) {
        my $type_obj := self.find_symbol([$type]);
        my $code     := nqp::create($type_obj);
        @!CODES[+@!CODES] := $code;
        self.add_object($code);
        $code
    }
    
    # Attaches a signature to a code object, and gives the
    # signature its backlink to the code object.
    method attach_signature($code, $signature) {
        my $code_type := self.find_symbol(['Code']);
        my $sig_type := self.find_symbol(['Signature']);
        nqp::bindattr($code, $code_type, '$!signature', $signature);
        nqp::bindattr($signature, $sig_type, '$!code', $code);
    }
    
    # Takes a code object and the QAST::Block for its body. Finalizes the
    # setup of the code object, including populated the $!compstuff array.
    # This contains 3 elements:
    #   0 = the QAST::Block object
    #   1 = the compiler thunk
    #   2 = the clone callback
    method finish_code_object($code, $code_past, $is_dispatcher = 0, :$yada) {
        my $fixups := QAST::Stmts.new();
        my $des    := QAST::Stmts.new();
        
        # Remove it from the code objects stack.
        @!CODES.pop();
                
        # Locate various interesting symbols.
        my $code_type    := self.find_symbol(['Code']);
        my $routine_type := self.find_symbol(['Routine']);
        
        # Attach code object to QAST node.
        $code_past := $code;
        
        # Stash it under the QAST block unique ID.
        %!sub_id_to_code_object{$code_past.cuid()} := $code;
        
        # Create the compiler stuff array and stick it in the code object.
        # Also add clearup task to remove it again later.
        my @compstuff;
        nqp::bindattr($code, $code_type, '$!compstuff', @compstuff);
        nqp::push(@!cleanup_tasks, sub () {
            nqp::bindattr($code, $code_type, '$!compstuff', nqp::null());
        });
        
        # For now, install stub that will dynamically compile the code if
        # we ever try to run it during compilation.
        my $precomp;
        my $compiler_thunk := {
            # Fix up GLOBAL.
            nqp::bindhllsym('perl6', 'GLOBAL', $*GLOBALish);
            
            # Compile the block.
            $precomp := self.compile_in_context($code_past, $code_type);

            # Also compile the candidates if this is a proto.
            if $is_dispatcher {
                for nqp::getattr($code, $routine_type, '$!dispatchees') {
                    my $past := nqp::getattr($_, $code_type, '$!compstuff')[0];
                    if $past {
                        self.compile_in_context($past, $code_type);
                    }
                }
            }
        };
        my $stub := nqp::freshcoderef(sub (*@pos, *%named) {
            unless $precomp {
                $compiler_thunk();
            }
            $precomp(|@pos, |%named);
        });
        @compstuff[1] := $compiler_thunk;
        nqp::setcodename($stub, $code_past.name);
        nqp::bindattr($code, $code_type, '$!do', $stub);
        
        # Tag it as a static code ref and add it to the root code refs set.
        nqp::markcodestatic($stub);
        nqp::markcodestub($stub);
        my $code_ref_idx := self.add_root_code_ref($stub, $code_past);
        %!sub_id_to_sc_idx{$code_past.cuid()} := $code_ref_idx;
        
        # If we clone the stub, need to mark it as a dynamic compilation
        # boundary.
        if self.is_precompilation_mode() {
            @compstuff[2] := sub ($orig, $clone) {
                my $do := nqp::getattr($clone, $code_type, '$!do');
                nqp::markcodestub($do);
                nqp::push(@!cleanup_tasks, sub () {
                    nqp::bindattr($clone, $code_type, '$!compstuff', nqp::null());
                });
            };
        }
        
        # Fixup will install the real thing, unless we're in a role, in
        # which case pre-comp will have sorted it out.
        unless $*PKGDECL eq 'role' {
            unless self.is_precompilation_mode() {
                $fixups.push(QAST::Stmts.new(
                    self.set_attribute($code, $code_type, '$!do', QAST::BVal.new( :value($code_past) )),
                    QAST::Op.new(
                        :op('setcodeobj'),
                        QAST::BVal.new( :value($code_past) ),
                        QAST::WVal.new( :value($code) )
                    )));
                
                # If we clone the stub, then we must remember to do a fixup
                # of it also.
                @compstuff[2] := sub ($orig, $clone) {
                    self.add_object($clone);
                    nqp::push(@!cleanup_tasks, sub () {
                        nqp::bindattr($clone, $code_type, '$!compstuff', nqp::null());
                    });
                    my $tmp := $fixups.unique('tmp_block_fixup');
                    $fixups.push(QAST::Stmt.new(
                        QAST::Op.new(
                            :op('bind'),
                            QAST::Var.new( :name($tmp), :scope('local'), :decl('var') ),
                            QAST::Op.new( :op('clone'), QAST::BVal.new( :value($code_past) ) )
                        ),
                        self.set_attribute($clone, $code_type, '$!do',
                            QAST::Var.new( :name($tmp), :scope('local') )),
                        QAST::Op.new(
                            :op('setcodeobj'),
                            QAST::Var.new( :name($tmp), :scope('local') ),
                            QAST::WVal.new( :value($clone) )
                        )));
                };
                
                # Also stash fixups so we can know not to do them if we
                # do dynamic compilation.
                %!code_object_fixup_list{$code_past.cuid} := $fixups;
            }

            # Stash the QAST block in the comp stuff.
            @compstuff[0] := $code_past;
        }
        
        # If this is a dispatcher, install dispatchee list that we can
        # add the candidates too.
        if $is_dispatcher {
            nqp::bindattr($code, $routine_type, '$!dispatchees', []);
        }
        
        # Set yada flag if needed.
        if $yada {
            nqp::bindattr_i($code, $routine_type, '$!yada', 1);
        }

        # Deserialization also needs to give the Parrot sub its backlink.
        if self.is_precompilation_mode() {
            $des.push(QAST::Op.new(
                :op('setcodeobj'),
                QAST::BVal.new( :value($code_past) ),
                QAST::WVal.new( :value($code) )));
        }

        # If it's a routine, store the package to make backtraces nicer.
        if nqp::istype($code, $routine_type) {
            nqp::bindattr($code, $routine_type, '$!package', $*PACKAGE);
        }
            
        self.add_fixup_task(:deserialize_past($des), :fixup_past($fixups));
        $code;
    }

    method add_quasi_fixups($quasi_ast, $block) {
        $quasi_ast := nqp::decont($quasi_ast);
        self.add_object($quasi_ast);
        unless $quasi_ast.is_quasi_ast {
            return "";
        }
        my $fixups := QAST::Op.new(:op,
           QAST::BVal.new(:value($block)),
           QAST::Op.new(
                :op,
                QAST::Var.new(
                    :scope,
                    :name<$!quasi_context>,
                    QAST::WVal.new( :value($quasi_ast) ),
                    QAST::WVal.new( :value(self.find_symbol(['AST'])) )
                )
           )
        );
        self.add_fixup_task(:fixup_past($fixups), :deserialize_past($fixups));
    }
    
    # Generates code for running phasers.
    method run_phasers_code($code, $block_type, $type) {
        QAST::Op.new(
            :op('for'),
            QAST::Op.new(
                :op('atkey'),
                QAST::Var.new(
                    :scope('attribute'), :name('$!phasers'),
                    QAST::WVal.new( :value($code) ),
                    QAST::WVal.new( :value($block_type) )
                ),
                QAST::SVal.new( :value($type) )
            ),
            QAST::Block.new(
                :blocktype('immediate'),
                QAST::Op.new(
                    :op('call'),
                    QAST::Var.new( :scope('lexical'), :name('$_'), :decl('param') )
                )))
    }
    
    # Adds any extra code needing for handling phasers.
    method add_phasers_handling_code($code, $code_past) {
        my $block_type := self.find_symbol(['Block']);
        if nqp::istype($code, $block_type) {
            my %phasers := nqp::getattr($code, $block_type, '$!phasers');
            unless nqp::isnull(%phasers) {
                if nqp::existskey(%phasers, 'PRE') {
                    $code_past[0].push(QAST::Op.new( :op('p6setpre') ));
                    $code_past[0].push(self.run_phasers_code($code, $block_type, 'PRE'));
                    $code_past[0].push(QAST::Op.new( :op('p6clearpre') ));
                }
                if nqp::existskey(%phasers, 'FIRST') {
                    $code_past[0].push(QAST::Op.new(
                        :op('if'),
                        QAST::Op.new( :op('p6takefirstflag') ),
                        self.run_phasers_code($code, $block_type, 'FIRST')));
                }
                if nqp::existskey(%phasers, 'ENTER') {
                    $code_past[0].push(self.run_phasers_code($code, $block_type, 'ENTER'));
                }
                if nqp::existskey(%phasers, '!LEAVE-ORDER') || nqp::existskey(%phasers, 'POST') {
                    $code_past[+@($code_past) - 1] := QAST::Op.new(
                        :op('p6return'),
                        $code_past[+@($code_past) - 1]);
                    $code_past.has_exit_handler(1);
                }
            }
        }
    }
    
    # Gives the current block what's needed for "let"/"temp" support.
    method give_cur_block_let($/) {
        my $block := self.cur_lexpad();
        unless $block.symbol('!LET-RESTORE') {
            self.setup_let_or_temp($/, '!LET-RESTORE', 'UNDO');
        }
    }
    method give_cur_block_temp($/) {
        my $block := self.cur_lexpad();
        unless $block.symbol('!TEMP-RESTORE') {
            self.setup_let_or_temp($/, '!TEMP-RESTORE', 'LEAVE');
        }
    }
    method setup_let_or_temp($/, $value_stash, $phaser) {
        # Add variable to current block.
        my $block := self.cur_lexpad();
        $block[0].push(QAST::Op.new(
            :op('bind'),
            QAST::Var.new( :name($value_stash), :scope('lexical'), :decl('var') ),
            QAST::Op.new( :op('list') )));
        $block.symbol($value_stash, :scope('lexical'));
        
        # Create a phaser block that will do the restoration.
        my $phaser_block := self.push_lexpad($/);
        self.pop_lexpad();
        $phaser_block.push(QAST::Op.new(
            :op('while'),
            QAST::Var.new( :name($value_stash), :scope('lexical') ),
            QAST::Op.new(
                :op('p6store'),
                QAST::Op.new(
                    :op('shift'),
                    QAST::Var.new( :name($value_stash), :scope('lexical') )
                ),
                QAST::Op.new(
                    :op('shift'),
                    QAST::Var.new( :name($value_stash), :scope('lexical') )
                ))));
        
        # Add as phaser.
        $block[0].push($phaser_block);
        self.add_phaser($/, $phaser,
            self.create_code_object($phaser_block, 'Code', self.create_signature(nqp::hash('parameters', []))));
    }
    
    # Adds a multi candidate to a proto/dispatch.
    method add_dispatchee_to_proto($proto, $candidate) {
        $proto.add_dispatchee($candidate);
    }
    
    # Derives a proto to get a dispatch.
    method derive_dispatcher($proto) {
        # Immediately do so and add to SC.
        my $derived := $proto.derive_dispatcher();
        self.add_object($derived);
        return $derived;
    }
    
    # Helper to make PAST for setting an attribute to a value. Value should
    # be a PAST tree.
    method set_attribute($obj, $class, $name, $value_past) {
        QAST::Op.new(
            :op('bind'),
            QAST::Var.new(
                :name($name), :scope('attribute'),
                QAST::WVal.new( :value($obj) ),
                QAST::WVal.new( :value($class) )
            ),
            $value_past
        )
    }

    # Wraps a value in a scalar container
    method scalar_wrap($obj) {
        my $scalar_type := self.find_symbol(['Scalar']);
        my $scalar      := nqp::create($scalar_type);
        self.add_object($scalar);
        nqp::bindattr($scalar, $scalar_type, '$!value', $obj);
        $scalar;
    }
    
    # Takes a QAST::Block and compiles it for running during "compile time".
    # We need to do this for BEGIN but also for things that get called in
    # the compilation process, like user defined traits.
    method compile_in_context($past, $code_type) {
        # Ensure that we have the appropriate op libs loaded and correct
        # HLL.
        my $wrapper := QAST::Block.new(QAST::Stmts.new(), $past);
        self.add_libs($wrapper);
        
        # Create outer lexical contexts with all symbols visible. Maybe 
        # we can be a bit smarter here some day. But for now we just make a
        # single frame and copy all the visible things into it.
        $past := 1;
        my %seen;
        my $mu        := try { self.find_symbol(['Mu']) };
        my $cur_block := $past;
        while $cur_block {
            my %symbols := $cur_block.symtable();
            for %symbols {
                unless %seen{$_.key} {
                    # Add symbol.
                    my %sym := $_.value;
                    my $value := nqp::existskey(%sym, 'value') ?? %sym !! $mu;
                    try {
                        if nqp::isnull(nqp::getobjsc($value)) {
                            self.add_object($value);
                        }
                        CATCH {
                            $value := $mu;
                        }
                    }
                    $wrapper[0].push(QAST::Var.new(
                        :name($_.key), :scope('lexical'),
                        :decl(%sym ?? 'statevar' !! 'static'), :$value
                    ));
                    $wrapper.symbol($_.key, :scope('lexical'));
                    
                }
                %seen{$_.key} := 1;
            }
            $cur_block := $cur_block;
        }
        
        # Compile it, set wrapper's static lexpad, then invoke the wrapper,
        # which fixes up the lexicals.
        my $compunit := QAST::CompUnit.new(
            :hll('perl6'),
            :sc(self.sc()),
            :compilation_mode(0),
            $wrapper
        );
        my $comp := nqp::getcomp('perl6');
        my $precomp := $comp.compile($compunit, :from, :compunit_ok(1),
             :lineposcache($*LINEPOSCACHE));
        my $mainline := $comp.backend.compunit_mainline($precomp);
        $mainline();
        
        # Fix up Code object associations (including nested blocks).
        # We un-stub any code objects for already-compiled inner blocks
        # to avoid wasting re-compiling them, and also to help make
        # parametric role outer chain work out. Also set up their static
        # lexpads, if they have any.
        my @coderefs := $comp.backend.compunit_coderefs($precomp);
        my int $num_subs := nqp::elems(@coderefs);
        my int $i := 0;
        my $result;
        while $i < $num_subs {
            my $subid := nqp::getcodecuid(@coderefs[$i]);
            if nqp::existskey(%!sub_id_to_code_object, $subid) {
                my $code_obj := %!sub_id_to_code_object{$subid};
                nqp::setcodeobj(@coderefs[$i], $code_obj);
                nqp::bindattr($code_obj, $code_type, '$!do', @coderefs[$i]);
                nqp::bindattr($code_obj, $code_type, '$!compstuff', nqp::null());
            }
            if nqp::existskey(%!sub_id_to_sc_idx, $subid) {
                nqp::markcodestatic(@coderefs[$i]);
                self.update_root_code_ref(%!sub_id_to_sc_idx{$subid}, @coderefs[$i]);
            }
            if nqp::existskey(%!code_object_fixup_list, $subid) {
                my $fixups := %!code_object_fixup_list{$subid};
                $fixups.pop() while $fixups.list;
            }
            if $subid eq $past.cuid {
                $result := @coderefs[$i];
            }
            $i := $i + 1;
        }
        
        # Flag block as dynamically compiled.
        $past := 1;
        
        # Return the VM coderef that maps to the thing we were originally
        # asked to compile.
        $result
    }
    
    # Adds a constant value to the constants table. Returns PAST to do
    # the lookup of the constant.
    method add_constant($type, $primitive, :$nocache, *@value, *%named) {
        # If we already built this, find it in the cache and
        # just return that.
        my str $cache_key;
        if !$nocache {
            my str $namedkey := '';
            for %named {
                $namedkey := $namedkey ~ $_.key ~ ',' ~ $_.value ~ ';'
                    if nqp::defined($_.value);
            }
            if $primitive eq 'bigint' {
                $cache_key := "$type,bigint," ~ nqp::tostr_I(@value[0]);
            } else {
                $cache_key := "$type,$primitive,"
                    ~ join(',', @value)
                    ~ $namedkey;
            }
            if nqp::existskey(%!const_cache, $cache_key) {
                my $value := %!const_cache{$cache_key};
                return QAST::WVal.new( :value($value), :returns($value.WHAT) );
            }
        }
        
        # Find type object for the box typed we'll create.
        my $type_obj := self.find_symbol(nqp::split('::', $type));
        
        # Go by the primitive type we're boxing. Need to create
        # the boxed value and also code to produce it.
        my $constant;
        if $primitive eq 'int' {
            $constant := nqp::box_i(@value[0], $type_obj);
        }
        elsif $primitive eq 'str' {
            $constant := nqp::box_s(@value[0], $type_obj);
        }
        elsif $primitive eq 'num' {
            $constant := nqp::box_n(@value[0], $type_obj);
        }
        elsif $primitive eq 'bigint' {
            $constant := @value[0];
        }
        elsif $primitive eq 'type_new' {
            $constant := $type_obj.new(|@value, |%named);
        }
        else {
            nqp::die("Don't know how to build a $primitive constant");
        }
        
        # Add to SC.
        self.add_object($constant);
        
        # Build QAST for getting the boxed constant from the constants
        # table, but also annotate it with the constant itself in case
        # we need it. Add to cache.
        my $qast := QAST::WVal.new( :value($constant), :returns($constant.WHAT) );
        if !$nocache {
            %!const_cache{$cache_key} := $constant;
        }
        return $qast;
    }
    
    # Adds a numeric constant value (int or num) to the constants table.
    # Returns PAST to do  the lookup of the constant.
    method add_numeric_constant($/, $type, $value) {
        if $type eq 'Int' && (try $value.HOW.name($value)) eq 'Int' {
            if nqp::isbig_I($value) {
                # cannot unbox to int without loss of information
                return self.add_constant('Int', 'bigint', $value);
            }
            # since Int doesn't have any vtables yet (at least while compiling
            # the setting), it is inconvenient to work with, so unbox
            $value := nqp::unbox_i($value);
        }
        my $const := self.add_constant($type, nqp::lc($type), $value);
        my $past;
        if $type eq 'Int' {
            $past := QAST::Want.new($const, 'Ii', QAST::IVal.new( :value($value) ) );
        }
        else {
            $past := QAST::Want.new($const, 'Nn',
                $value eq 'Inf'  ?? QAST::Op.new( :op('inf') ) !!
                $value eq '-Inf' ?? QAST::Op.new( :op('neginf') ) !!
                $value eq 'NaN'  ?? QAST::Op.new( :op('nan') ) !!
                                    QAST::NVal.new( :value($value) ) );
        }
        $past.returns($const.returns);
        if $/ {
            $past.node($/);
        }
        $past;
    }
    
    # Adds a string constant value to the constants table.
    # Returns PAST to do the lookup of the constant.
    method add_string_constant($value) {
        my $const := self.add_constant('Str', 'str', $value);
        QAST::Want.new(
            $const, :returns($const.returns),
            'Ss', QAST::SVal.new( :value($value) ));
    }
    
    # Adds the result of a constant folding operation to the SC and
    # returns a reference to it.
    method add_constant_folded_result($r) {
        self.add_object($r);
        QAST::WVal.new( :value($r) )
    }
    
    # Takes a data structure of non-Perl 6 objects and wraps them up
    # recursively.
    method p6ize_recursive($data) {
        p6ize_recursive($data)
    }
    
    method nibble_to_str($/, $ast, $mkerr) {
        if $ast.has_compile_time_value {
            return nqp::unbox_s($ast.compile_time_value);
        }
        elsif nqp::istype($ast[0], QAST::Op) && $ast[0].name eq '&infix:<,>' {
            my @pieces;
            for @($ast[0]) {
                if $_.has_compile_time_value {
                    nqp::push(@pieces, nqp::unbox_s($_.compile_time_value));
                }
                else {
                    $/.CURSOR.panic($mkerr());
                }
            }
            return join(' ', @pieces);
        }
        else {
            $/.CURSOR.panic($mkerr());
        }
    }
    
    method colonpair_nibble_to_str($/, $nibble) {
        self.nibble_to_str($/, $nibble.ast,
            -> { "Colon pair value '$nibble' too complex to use in name" })
    }

    # Creates a meta-object for a package, adds it to the root objects and
    # returns the created object.
    method pkg_create_mo($/, $how, :$name, :$repr, *%extra) {
        # Create the meta-object and add to root objects.
        my %args;
        if nqp::defined($name) { %args := ~$name; }
        if nqp::defined($repr) { %args := ~$repr; }
        if nqp::existskey(%extra, 'base_type') {
            %args := %extra;
        }
        if nqp::existskey(%extra, 'group') {
            %args := %extra;
        }
        if nqp::existskey(%extra, 'signatured') {
            %args := %extra;
        }
        my $mo := $how.new_type(|%args);
        self.add_object($mo);

        # Result is just the object.
        return $mo;
    }
    
    # Constructs a meta-attribute and adds it to a meta-object. Expects to
    # be passed the meta-attribute type object, a set of literal named
    # arguments to pass and a set of name to object mappings to pass also
    # as named arguments, but where these passed objects also live in a
    # serialization context. The type would be passed in this way.
    method pkg_add_attribute($/, $obj, $meta_attr, %lit_args, %obj_args,
            %cont_info, $descriptor) {
        # Build container.
        my $cont := nqp::create(%cont_info);
        nqp::bindattr($cont, %cont_info, '$!descriptor', $descriptor);
        if nqp::existskey(%cont_info, 'scalar_value') {
            nqp::bindattr($cont, %cont_info, '$!value',
                %cont_info);
        }
        
        # Create meta-attribute instance and add right away. Also add
        # it to the SC.
        my $attr := $meta_attr.new(:auto_viv_container($cont), |%lit_args, |%obj_args);
        $obj.HOW.add_attribute($obj, $attr);
        self.add_object($attr);
        
        # Return attribute that was built.
        $attr
    }
    
    # Adds a method to the meta-object.
    method pkg_add_method($/, $obj, $meta_method_name, $name, $code_object) {
        self.ex-handle($/, {
                $obj.HOW."$meta_method_name"($obj, $name, $code_object)
            }
        )
    }
    
    # Handles setting the body block code for a role.
    method pkg_set_role_body_block($/, $obj, $code_object, $past) {
        # Add it to the compile time meta-object.
        $obj.HOW.set_body_block($obj, $code_object);

        # Compile it immediately (we always compile role bodies as
        # early as possible, but then assume they don't need to be
        # re-compiled and re-fixed up at startup).
        self.compile_in_context($past, self.find_symbol(['Code']));
    }
    
    # Adds a possible role to a role group.
    method pkg_add_role_group_possibility($/, $group, $role) {
        $group.HOW.add_possibility($group, $role);
    }
    
    # Composes the package, and stores an event for this action.
    method pkg_compose($obj) {
        $obj.HOW.compose($obj);
    }
    
    # Builds a curried role based on a parsed argument list.
    method parameterize_type($role, $arglist, $/) {
        # Build a list of compile time arguments to the role; whine if
        # we find something without one.
        my @pos_args;
        my %named_args;
        for @($arglist) {
            my $val;
            if $_.has_compile_time_value {
                $val := $_.compile_time_value;
            }
            else {
                $val := self.compile_time_evaluate($/, $_);
            }
            if $_.named {
                %named_args{$_.named} := $val;
            }
            else {
                @pos_args.push($val);
            }
        }
        
        self.parameterize_type_with_args($role, @pos_args, %named_args);
    }
    
    # Curries a role with the specified arguments.
    method parameterize_type_with_args($role, @pos_args, %named_args) {
        # Make the curry right away and add it to the SC.
        my $curried := $role.HOW.parameterize($role, |@pos_args, |%named_args);
        self.add_object($curried);
        return $curried;
    }
    
    # Creates a subset type meta-object/type object pair.
    method create_subset($how, $refinee, $refinement, :$name) {
        # Create the meta-object and add to root objects.
        my %args := hash(:refinee($refinee), :refinement($refinement));
        if nqp::defined($name) { %args := $name; }
        my $mo := $how.new_type(|%args);
        self.add_object($mo);
        return $mo;
    }
    
    # Adds a value to an enumeration.
    method create_enum_value($enum_type_obj, $key, $value) {
        # Create directly.
        my $val := nqp::rebless(nqp::clone($value), $enum_type_obj);
        nqp::bindattr($val, $enum_type_obj, '$!key', $key);
        nqp::bindattr($val, $enum_type_obj, '$!value', $value);
        self.add_object($val);
        
        # Add to meta-object.
        $enum_type_obj.HOW.add_enum_value($enum_type_obj, $val);

        # Result is the value.
        $val
    }

    method suggest_typename($name) {
        my %seen;
        %seen{$name} := 1;
        my @candidates := [[], [], []];
        my &inner-evaluator := make_levenshtein_evaluator($name, @candidates);
        my @suggestions;

        sub evaluator($name, $object, $hash) {
            # only care about type objects
            return 1 if nqp::isconcrete($object);
            return 1 if nqp::existskey(%seen, $name);

            %seen{$name} := 1;
            return &inner-evaluator($name, $object, $hash);
        }
        self.walk_symbols(&evaluator);

        levenshtein_candidate_heuristic(@candidates, @suggestions);

        return @suggestions;
    }

    # Applies a trait.
    method apply_trait($/, $trait_sub_name, *@pos_args, *%named_args) {
        my $trait_sub := self.find_symbol([$trait_sub_name]);
        my $ex;
        my $nok := 0;
        try {
            self.ex-handle($/, { $trait_sub(|@pos_args, |%named_args) });
            CATCH {
                $ex := $_;
                my $payload := nqp::getpayload($_);
                if nqp::istype($payload, self.find_symbol(["X", "Inheritance", "UnknownParent"])) {
                    my @suggestions := self.suggest_typename($payload.parent);
                    for @suggestions {
                        $payload.suggestions.push($_)
                    }
                }
                $nok := 1;
            }
        }
        if $nok {
            self.rethrow($/, $ex);
        }
    }

    # Some things get cloned many times with an outer lexical scope that
    # we never enter. This makes sure we capture them as needed.
    method create_lexical_capture_fixup() {
        # Create a list and put it in the SC.
        my class FixupList { has $!list }
        my $fixup_list := nqp::create(FixupList);
        self.add_object($fixup_list);
        nqp::bindattr($fixup_list, FixupList, '$!list', nqp::list());

        # Set up capturing code.
        my $capturer := self.cur_lexpad();
        $capturer[0].push(QAST::Op.new(
            :op('p6captureouters'),
            QAST::Var.new(
                :name('$!list'), :scope('attribute'),
                QAST::WVal.new( :value($fixup_list) ),
                QAST::WVal.new( :value(FixupList) ))));
        
        # Return a PAST node that we can push the dummy closure
        return QAST::Op.new(
            :op('push'),
            QAST::Var.new(
                :name('$!list'), :scope('attribute'),
                QAST::WVal.new( :value($fixup_list) ),
                QAST::WVal.new( :value(FixupList) )));
    }
    
    # Handles addition of a phaser.
    method add_phaser($/, $phaser, $block, $phaser_past?) {
        if $phaser eq 'BEGIN' {
            # BEGIN phasers get run immediately.
            my $result := $block();
            return self.add_constant_folded_result($result);
        }
        elsif $phaser eq 'CHECK' {
            my $result_node := QAST::Stmt.new( QAST::Var.new( :name('Nil'), :scope('lexical') ) );
            @!CHECKs := [] unless @!CHECKs;
            @!CHECKs.unshift([$block, $result_node]);
            return $result_node;
        }
        elsif $phaser eq 'INIT' {
            unless $*UNIT.symbol('!INIT_VALUES') {
                my $mu := self.find_symbol(['Mu']);
                my %info;
                %info := %info := self.find_symbol(['Hash']);
                %info := self.find_symbol(['Associative']);
                %info := $mu;
                self.install_lexical_container($*UNIT, '!INIT_VALUES', %info,
                    self.create_container_descriptor($mu, 1, '!INIT_VALUES'));
            }
            $*UNIT[0].push(QAST::Op.new(
                :op('callmethod'), :name('bind_key'),
                QAST::Var.new( :name('!INIT_VALUES'), :scope('lexical') ),
                QAST::SVal.new( :value($phaser_past.cuid) ),
                QAST::Op.new(
                    :op('call'),
                    QAST::WVal.new( :value($block) )
                )));
            return QAST::Op.new(
                :op('callmethod'), :name('at_key'),
                QAST::Var.new( :name('!INIT_VALUES'), :scope('lexical') ),
                QAST::SVal.new( :value($phaser_past.cuid) )
            );
        }
        elsif $phaser eq 'END' {
            $*UNIT[0].push(QAST::Op.new(
                :op('callmethod'), :name('unshift'),
                QAST::Op.new(
                    :op('getcurhllsym'),
                    QAST::SVal.new( :value('@END_PHASERS') ),
                ),
                QAST::WVal.new( :value($block) )
            ));
            return QAST::Var.new(:name('Nil'), :scope('lexical'));
        }
        elsif $phaser eq 'PRE' || $phaser eq 'POST' {
            my $what := self.add_string_constant($phaser);
            $what.named('phaser');
            my $condition := self.add_string_constant(~$/);
            $condition.named('condition');

            $phaser_past[1] := QAST::Op.new(
                :op('unless'),
                $phaser_past[1],
                QAST::Op.new(
                    :op('callmethod'), :name('throw'),
                    QAST::Op.new(
                        :op('callmethod'), :name('new'),
                        QAST::WVal.new( :value(self.find_symbol(['X', 'Phaser', 'PrePost'])) ),
                        $what,
                        $condition,
                    )
                ),
            );
            
            if $phaser eq 'POST' {
                # Needs $_ that can be set to the return value.
                $phaser_past.custom_args(1);
                $phaser_past[0].unshift(QAST::Op.new( :op('p6bindsig') ));
                if $phaser_past.symbol('$_') {
                    for @($phaser_past[0]) {
                        if nqp::istype($_, QAST::Op) && $_.op eq 'bind' && $_[0].name eq '$_' {
                            $_.op('null'); $_.shift(); $_.shift();
                        }
                    }
                }
                $phaser_past[0].unshift(QAST::Var.new( :name('$_'), :scope('lexical'), :decl('var') ));
                nqp::push(
                    nqp::getattr($block.signature, self.find_symbol(['Signature']), '$!params'),
                    self.create_parameter(hash(
                            variable_name => '$_', is_parcel => 1,
                            nominal_type => self.find_symbol(['Mu'])
                        )));
            }
            
            @!CODES[+@!CODES - 1].add_phaser($phaser, $block);
            return QAST::Var.new(:name('Nil'), :scope('lexical'));
        }
        else {
            @!CODES[+@!CODES - 1].add_phaser($phaser, $block);
            return QAST::Var.new(:name('Nil'), :scope('lexical'));
        }
    }
    
    # Runs the CHECK phasers and twiddles the QAST to look them up.
    method CHECK() {
        for @!CHECKs {
            my $result := $_[0]();
            $_[1][0] := self.add_constant_folded_result($result);
        }
    }
    
    # Does any cleanups needed after compilation.
    method cleanup() {
        for @!cleanup_tasks { $_() }
    }
    
    # Adds required libraries to a compilation unit.
    method add_libs($comp_unit) {
        $comp_unit.push(QAST::VM.new(
            loadlibs => ['nqp_group', 'nqp_ops', 'perl6_ops',
                         'bit_ops', 'math_ops', 'trans_ops', 'io_ops',
                         'obscure_ops', 'os', 'file', 'sys_ops',
                         'nqp_bigint_ops', 'nqp_dyncall_ops' ],
            jvm => QAST::Op.new( :op('null') )));
    }
    
    # Represents a longname after having parsed it.
    my class LongName {
        # a match object, so that error messages can get a proper line number
        has $!match;
        
        # Set of name components. Each one will be either a string
        # or a PAST node that represents an expresison to produce it.
        has @!components;
        
        # The colonpairs, if any.
        has @!colonpairs;
        
        # Flag for if the name ends in ::, meaning we need to emit a
        # .WHO on the end.
        has int $!get_who;
        
        # Gets the textual name of the value.
        method text() {
            ~$!match
        }
        
        # Gets the name, by default without any adverbs.
        method name(:$decl, :$dba = '', :$with_adverbs) {
            my @parts := self.type_name_parts($dba, :$decl);
            unless $decl && $decl eq 'routine' {
                @parts.shift() while self.is_pseudo_package(@parts[0]);
            }
            join('::', @parts)
                ~ ($with_adverbs ?? join('', @!colonpairs) !! '');
        }

        # returns a QAST tree that represents the name
        # currently needed for 'require ::($modulename) '
        # ignore adverbs for now
        method name_past() {
            if self.contains_indirect_lookup() {
                if @!components == 1 {
                    return @!components[0];
                }
                else {
                    my $past := QAST::Op.new(:op, :name('&infix:<,>'));
                    for @!components {
                        $past.push: $_ ~~ QAST::Node ?? $_ !! QAST::SVal.new(:value($_));
                    }
                    return QAST::Op.new(:op, :name,
                        $past,
                        QAST::SVal.new(:value<::>)
                    );
                }
            }
            else {
                my $value := join('::', @!components);
                QAST::SVal.new(:$value);
            }
        }
        
        # Gets the individual components, which may be PAST nodes for
        # unknown pieces.
        method components() {
            @!components
        }
        
        # Gets the individual components (which should be strings) but
        # taking a sigil and twigil and adding them to the last component.
        method variable_components($sigil, $twigil) {
            my @result;
            for @!components {
                @result.push($_);
            }
            @result[+@result - 1] := $sigil ~ $twigil ~ @result[+@result - 1];
            @result
        }
        
        # Checks if there is an indirect lookup required.
        method contains_indirect_lookup() {
            for @!components {
                if nqp::istype($_, QAST::Node) {
                    return 1;
                }
            }
            return 0;
        }
        
        # Fetches an array of components provided they are all known
        # or resolvable at compile time.
        method type_name_parts($dba, :$decl) {
            my @name;
            my int $beyond_pp;
            if $decl && $!get_who {
                my $name := self.text;
                nqp::die("Name $name ends with '::' and cannot be used as a $dba");
            }
            if +@!components == 1 && self.is_pseudo_package(@!components[0]) {
                my $c := @!components[0];
                if !$decl || ($decl eq 'routine') {
                    nqp::push(@name, $c);
                    return @name;
                }
                if $c eq 'GLOBAL' {
                    nqp::die("Cannot declare pseudo-package GLOBAL");
                }
                $*W.throw($!match, 'X::PseudoPackage::InDeclaration',
                    pseudo-package  => $c,
                    action          => $dba,
                );
            }
            for @!components {
                if nqp::istype($_, QAST::Node) {
                    if $_.has_compile_time_value {
                        for nqp::split('::', ~$_.compile_time_value) {
                            @name.push($_);
                        }
                    }
                    else {
                        my $name := self.text;
                        nqp::die("Name $name is not compile-time known, and can not serve as a $dba");
                    }
                }
                elsif $beyond_pp || !self.is_pseudo_package($_) {
                    nqp::push(@name, $_);
                    $beyond_pp := 1;
                }
                else {
                    if $decl {
                        if $_ ne 'GLOBAL' {
                            $*W.throw($!match, 'X::PseudoPackage::InDeclaration',
                                pseudo-package  => $_,
                                action          => $dba,
                            );
                        }
                    }
                    else {
                        nqp::push(@name, $_);
                    }
                }
            }
            @name
        }
        
        method colonpairs_hash($dba) {
            my %result;
            for @!colonpairs {
                if $_ {
                    my $pair := $*W.compile_time_evaluate($_, $_.ast);
                    %result{$pair.key} := $pair.value;
                }
                else {
                    $_.CURSOR.panic("Colonpair too complex in $dba");
                }
            }
            %result
        }
        
        method get_who() {
            $!get_who
        }

        # Checks if a name component is a pseudo-package.
        method is_pseudo_package($comp) {
            !nqp::istype($comp, QAST::Node) && (
            $comp eq 'CORE' || $comp eq 'SETTING' || $comp eq 'UNIT' ||
            $comp eq 'OUTER' || $comp eq 'MY' || $comp eq 'OUR' ||
            $comp eq 'PROCESS' || $comp eq 'GLOBAL' || $comp eq 'CALLER' ||
            $comp eq 'DYNAMIC' || $comp eq 'COMPILING' || $comp eq 'PARENT')
        }
    }
    
    # Takes a longname and turns it into an object representing the
    # name.
    method dissect_longname($longname) {
        # Set up basic info about the long name.
        my $result := nqp::create(LongName);
        nqp::bindattr($result, LongName, '$!match', $longname);

        # Pick out the pieces of the name.
        my @components;
        my $name := $longname;
        if $name {
            @components.push(~$name);
        }
        for $name {
            if $_ {
                @components.push(~$_);
            }
            elsif $_ {
                my $EXPR := $_.ast;
                @components.push($EXPR);
            }
            else {
                # Either it's :: as a name entirely, in which case it's anon,
                # or we're ending in ::, in which case it implies .WHO.
                if +@components {
                    nqp::bindattr_i($result, LongName, '$!get_who', 1);
                }
            }
        }
        nqp::bindattr($result, LongName, '@!components', @components);
        
        # Stash colon pairs with names; incorporate non-named one into
        # the last part of the name (e.g. for infix:<+>). Need to be a
        # little cheaty when compiling the setting due to bootstrapping.
        my @pairs;
        for $longname {
            if $_ && !$_ {
                my $cp_str;
                if %*COMPILING<%?OPTIONS> ne 'NULL' {
                    # Safe to evaluate it directly; no bootstrap issues.
                    $cp_str := ':<' ~ ~$*W.compile_time_evaluate($_, $_.ast) ~ '>';
                }
                else {
                    my $ast := $_.ast;
                    $cp_str := nqp::istype($ast, QAST::Want) && nqp::istype($ast[2], QAST::SVal)
                        ?? ':<' ~ $ast[2].value ~ '>'
                        !! ~$_;
                }
                @components[+@components - 1] := @components[+@components - 1] ~ $cp_str;
            }
            else {
                @pairs.push($_);
            }
        }
        nqp::bindattr($result, LongName, '@!colonpairs', @pairs);
        
        $result
    }
    method dissect_deflongname($deflongname) {
        # deflongname has the same capture structure as longname
        self.dissect_longname($deflongname);
    }
    
    # Checks if a name starts with a pseudo-package.
    method is_pseudo_package($comp) {
        LongName.is_pseudo_package($comp)
    }
    
    # Checks if a given symbol is declared.
    method is_name(@name) {
        my int $is_name := 0;
        if self.is_pseudo_package(@name[0]) {
            $is_name := 1;
        }
        else {
            try {
                # This throws if it's not a known name.
                self.find_symbol(@name);
                $is_name := 1;
            }
        }
        $is_name || +@name == 1 && self.is_lexical(@name[0])
    }

    method symbol_has_compile_time_value(@name) {
        my $has_ctv := 0;
        try {
            self.find_symbol(@name);
            $has_ctv := 1;
        }
        $has_ctv;
    }
    
    # Checks if a given symbol is declared and a type object.
    method is_type(@name) {
        my $is_name := 0;
        try {
            # This throws if it's not a known name.
            $is_name := !nqp::isconcrete(self.find_symbol(@name))
        }
        $is_name
    }
    
    # Checks if a symbol has already been declared in the current
    # scope, and thus may not be redeclared.
    method already_declared($scope, $curpackage, $curpad, @name) {
        if $scope eq 'my' && +@name == 1 {
            my %sym := $curpad.symbol(@name[0]);
            if %sym {
                return %sym.HOW.HOW.name(%sym.HOW) ne 'Perl6::Metamodel::PackageHOW';
            }
            return 0;
        }
        else {
            # Does the current lexpad or package declare the first
            # part of the name? If not, we're in the clear.
            my $first_sym;
            if $curpad.symbol(@name[0]) {
                $first_sym := $curpad.symbol(@name[0]);
            }
            elsif nqp::existskey($curpackage.WHO, @name[0]) {
                $first_sym := ($curpackage.WHO){@name[0]};
            }
            else {
                return 0;
            }
            
            # If we've more name, recursively check the next level
            # in the package. Otherwise, just go on if it's a
            # package or not.
            if +@name > 1 {
                my @restname := nqp::clone(@name);
                @restname.shift;
                return self.already_declared('our', $first_sym, QAST::Block.new(), @restname);
            }
            else {
                return $first_sym.HOW.HOW.name($first_sym.HOW) ne 'Perl6::Metamodel::PackageHOW';
            }
        }
    }
    
    # Checks if there is a regex in scope.
    method regex_in_scope($name) {
        my $result := 0;
        try {
            my $maybe_regex := self.find_symbol([$name]);
            $result := nqp::istype($maybe_regex, self.find_symbol(['Regex']));
        }
        $result
    }

    method walk_symbols($code) {
        # first, go through all lexical scopes
        sub walk_block($block) {
            my %symtable := $block.symtable();
            for %symtable -> $symp {
                if nqp::existskey($symp.value, 'value') {
                    my $val := $symp.value;
                    if (try nqp::istype($val, QAST::Block)) {
                        return 0 if walk_block($val) == 0;
                    } else {
                        return 0 if $code($symp.key, $val, $symp.value) == 0;
                    }
                }
            }
            1;
        }

        for @!BLOCKS {
            return 0 if walk_block($_) == 0;
        }
        for self.stash_hash($*GLOBALish) {
            return 0 if $code($_.key, $_.value, hash()) == 0;
        }
    }

    # Finds a symbol that has a known value at compile time from the
    # perspective of the current scope. Checks for lexicals, then if
    # that fails tries package lookup.
    method find_symbol(@name) {
        # Make sure it's not an empty name.
        unless +@name { nqp::die("Cannot look up empty name"); }

        # GLOBAL is current view of global.
        if +@name == 1 && @name[0] eq 'GLOBAL' {
            return $*GLOBALish;
        }

        # If it's a single-part name, look through the lexical
        # scopes.
        if +@name == 1 {
            my $final_name := @name[0];
            my int $i := +@!BLOCKS;
            while $i > 0 {
                $i := $i - 1;
                my %sym := @!BLOCKS[$i].symbol($final_name);
                if +%sym {
                    if nqp::existskey(%sym, 'value') {
                        return %sym;
                    }
                    else {
                        nqp::die("No compile-time value for $final_name");
                    }
                }
            }
        }
        
        # If it's a multi-part name, see if the containing package
        # is a lexical somewhere. Otherwise we fall back to looking
        # in GLOBALish.
        my $result := $*GLOBALish;
        if +@name >= 2 {
            my $first := @name[0];
            my int $i := +@!BLOCKS;
            while $i > 0 {
                $i := $i - 1;
                my %sym := @!BLOCKS[$i].symbol($first);
                if +%sym {
                    if nqp::existskey(%sym, 'value') {
                        $result := %sym;
                        @name := nqp::clone(@name);
                        @name.shift();
                        $i := 0;
                    }
                    else {
                        nqp::die("No compile-time value for $first");
                    }                    
                }
            }
        }
        
        # Try to chase down the parts of the name.
        for @name {
            if nqp::existskey($result.WHO, ~$_) {
                $result := ($result.WHO){$_};
            }
            else {
                nqp::die("Could not locate compile-time value for symbol " ~
                    join('::', @name));
            }
        }
        
        $result;
    }
    
    # Takes a name and compiles it to a lookup for the symbol.
    method symbol_lookup(@name, $/, :$package_only = 0, :$lvalue = 0) {
        # Catch empty names and die helpfully.
        if +@name == 0 { $/.CURSOR.panic("Cannot compile empty name"); }
        my $orig_name := join('::', @name);
        
        # Handle fetching GLOBAL.
        if +@name == 1 && @name[0] eq 'GLOBAL' {
            return QAST::Op.new( :op('getcurhllsym'),
                QAST::SVal.new( :value('GLOBAL') ) );
        }
        
        # Handle things starting with pseudo-package.
        if self.is_pseudo_package(@name[0]) && @name[0] ne 'GLOBAL' && @name[0] ne 'PROCESS' {
            my $lookup;
            for @name {
                if $lookup {
                    $lookup := QAST::Op.new( :op('who'), $lookup );
                }
                else {
                    # Lookups start at the :: root.
                    $lookup := QAST::Op.new(
                        :op('callmethod'), :name('new'),
                        QAST::WVal.new( :value($*W.find_symbol(['PseudoStash'])) )
                    );
                }
                $lookup := QAST::Op.new(
                    :op('call'), :name('&postcircumfix:<{ }>'),
                    $lookup,
                    self.add_string_constant($_));
            }
            return $lookup;
        }
        
        # If it's a single item, then go hunting for it through the
        # block stack.
        if +@name == 1 && !$package_only {
            my int $i := +@!BLOCKS;
            while $i > 0 {
                $i := $i - 1;
                my %sym := @!BLOCKS[$i].symbol(@name[0]);
                if +%sym {
                    return QAST::Var.new( :name(@name[0]), :scope(%sym) );
                }
            }
        }
        
        # The final lookup will always be just an at_key call on a Stash.
        my $final_name := @name.pop();
        my $lookup := QAST::Op.new(
            :op('callmethod'), :name('at_key'),
            self.add_constant('Str', 'str', $final_name));
        
        # If there's no explicit qualification, then look it up in the
        # current package, and fall back to looking in GLOBAL.
        if +@name == 0 {
            $lookup.unshift(QAST::Op.new(
                :op('who'),
                QAST::Var.new( :name('$?PACKAGE'), :scope('lexical') )
            ));
        }
        
        # Otherwise, see if the first part of the name is lexically
        # known. If not, it's in GLOBAL. Also, if first part is GLOBAL
        # then strip it off.
        else {
            my $path := self.is_lexical(@name[0]) ??
                QAST::Var.new( :name(@name.shift()), :scope('lexical') ) !!
                QAST::Op.new( :op('getcurhllsym'),
                    QAST::SVal.new( :value('GLOBAL') ) );
            if @name[0] eq 'GLOBAL' {
                @name := nqp::clone(@name);
                @name.shift();
            }
            for @name {
                $path := QAST::Op.new(
                    :op('callmethod'), :name('package_at_key'),
                    QAST::Op.new( :op('who'), $path ),
                    QAST::SVal.new( :value(~$_) ));
            }
            $lookup.unshift(QAST::Op.new(:op('who'), $path));
        }
        
        unless $lvalue {
            $lookup.push(QAST::WVal.new( 
                :value(self.find_symbol(['Bool', 'True'])),
                :named('global_fallback')
            ));
        }
        
        return $lookup;
    }

    # Checks if the given name is known anywhere in the lexpad
    # and with lexical scope.
    method is_lexical($name) {
        my int $i := +@!BLOCKS;
        while $i > 0 {
            $i := $i - 1;
            my %sym := @!BLOCKS[$i].symbol($name);
            if +%sym {
                return %sym eq 'lexical';
            }
        }
        0;
    }
    
    method suggest_lexicals($name) {
        my @suggestions;
        my @candidates := [[], [], []];
        my &inner-evaluator := make_levenshtein_evaluator($name, @candidates);
        my %seen;
        %seen{$name} := 1;
        sub evaluate($name, $value, $hash) {
            # the descriptor identifies variables.
            return 1 unless nqp::existskey($hash, "descriptor");
            return 1 if nqp::existskey(%seen, $name);
            %seen{$name} := 1;
            return &inner-evaluator($name, $value, $hash);
        }
        self.walk_symbols(&evaluate);

        levenshtein_candidate_heuristic(@candidates, @suggestions);
        return @suggestions;
    }

    method suggest_routines($name) {
        $name := "&"~$name unless nqp::substr($name, 0, 1) eq "&";
        my @suggestions;
        my @candidates := [[], [], []];
        my &inner-evaluator := make_levenshtein_evaluator($name, @candidates);
        my %seen;
        %seen{$name} := 1;
        sub evaluate($name, $value, $hash) {
            return 1 unless nqp::substr($name, 0, 1) eq "&";
            return 1 if nqp::existskey(%seen, $name);

            %seen{$name} := 1;
            return &inner-evaluator($name, $value, $hash);
        }
        self.walk_symbols(&evaluate);

        levenshtein_candidate_heuristic(@candidates, @suggestions);
        return @suggestions;
    }


    # Checks if the symbol is really an alias to an attribute.
    method is_attr_alias($name) {
        my int $i := +@!BLOCKS;
        while $i > 0 {
            $i := $i - 1;
            my %sym := @!BLOCKS[$i].symbol($name);
            if +%sym {
                return %sym;
            }
        }
    }
    
    # Checks if a symbol is lexically visible relative to a given scope.
    # Returns 0 if it's not, 1 if it is, 2 if it's a type.
    method is_lexically_visible($name, $scope) {
        my $cur_block := $scope;
        while $cur_block {
            my %symbols := $cur_block.symtable();
            if nqp::existskey(%symbols, $name) {
                my %sym := %symbols{$name};
                return nqp::existskey(%sym, 'value') && 
                    !nqp::isconcrete(%sym) ?? 2 !! 1;
            }
            $cur_block := $cur_block;
        }
    }

    # Adds various bits of initialization that must always be done early on.
    method add_initializations() {
        if self.is_precompilation_mode() {
            self.add_load_dependency_task(:deserialize_past(QAST::VM.new(
                :parrot(QAST::Stmts.new(
                    QAST::VM.new( :pirop('nqp_dynop_setup v') ),
                    QAST::VM.new( :pirop('nqp_bigint_setup v') ),
                    QAST::VM.new( :pirop('nqp_native_call_setup v') ),
                    QAST::VM.new( :pirop('rakudo_dynop_setup v') ),
                    QAST::Op.new(
                        :op('callmethod'), :name('hll_map'),
                        QAST::VM.new( :pirop('getinterp P') ),
                        QAST::VM.new( :pirop('get_class Ps'), QAST::SVal.new( :value('LexPad') ) ),
                        QAST::VM.new( :pirop('get_class Ps'), QAST::SVal.new( :value('NQPLexPad') ) )
                    )
                )),
                :jvm(QAST::Op.new( :op('null') ))
            )));
        }
    }

    # Constructs and immediately throws a typed exception. Note that if there
    # are extra sorrows or worries it will put them into a group.
    method throw($/, $ex_type, *%opts) {
        my $ex := self.typed_exception($/, $ex_type, |%opts);
        if @*SORROWS || @*WORRIES {
            $ex := self.group_exception($ex);
        }
        $ex.throw
    }
    
    # Builds an exception group.
    method group_exception(*@panic) {
        my %opts;
        %opts := @panic[0] if @panic;
        %opts := p6ize_recursive(@*SORROWS) if @*SORROWS;
        %opts := p6ize_recursive(@*WORRIES) if @*WORRIES;
        %opts := nqp::box_s(nqp::getlexdyn('$?FILES'), self.find_symbol(['Str']));
        try {
            my $group_type := self.find_symbol(['X', 'Comp', 'Group']);
            return $group_type.new(|%opts);
            CATCH {
                nqp::print("Error while constructing error object:");
                nqp::say($_);
            }
        }
    }
    
    # Tries to construct a typed exception, incorporating all available compile
    # time information (such as about location). Returns it provided it is able
    # to construct it. If that fails, dies right away.
    method typed_exception($/, $ex_type, *%opts) {
        my int $type_found := 1;
        my $ex;
        my $x_comp;
        try {
            CATCH {
                $type_found := 0;
                nqp::print("Error while constructing error object:");
                nqp::say($_);
            };
            $ex := self.find_symbol(nqp::islist($ex_type) ?? $ex_type !! nqp::split('::', $ex_type));
            my $x_comp := self.find_symbol(['X', 'Comp']);
            unless nqp::istype($ex, $x_comp) {
                $ex := $ex.HOW.mixin($ex, $x_comp);
            }
        };

        if $type_found {
            # If the highwater is beyond the current position, force the cursor to
            # that location.
            my $c := $/.CURSOR;
            my @expected;
            if %opts {
                @expected := %opts;
            }
            elsif $c.'!highwater'() >= $c.pos() {
                my @raw_expected := $c.'!highexpect'();
                $c.'!cursor_pos'($c.'!highwater'());
                my %seen;
                for @raw_expected {
                    unless %seen{$_} {
                        nqp::push(@expected, $_);
                        %seen{$_} := 1;
                    }
                }
            }
            
            # Try and better explain "Confused".
            my @locprepost := self.locprepost($c);
            if $ex.HOW.name($ex) eq 'X::Syntax::Confused' {
                my $next := nqp::substr(@locprepost[1], 0, 1);
                if $next ~~ /\)|\]|\}|\»/ {
                    %opts := "Unexpected closing bracket";
                    @expected := [];
                }
                else {
                    my $expected_infix := 0;
                    for @expected {
                        if nqp::index($_, "infix") >= 0 {
                            $expected_infix := 1;
                            last;
                        }
                    }
                    if $expected_infix {
                        %opts := "Two terms in a row";
                    }
                }
            }
            
            # Build and throw exception object.
            %opts            := HLL::Compiler.lineof($c.orig, $c.pos, :cache(1));
            %opts         := p6ize_recursive(@*MODULES // []);
            %opts
             := @locprepost[0];
            %opts            := @locprepost[1];
            %opts      := p6ize_recursive(@expected) if @expected;
            %opts := 1;
            for %opts -> $p {
                if nqp::islist($p.value) {
                    my @a := [];
                    for $p.value {
                        nqp::push(@a, nqp::hllizefor($_, 'perl6'));
                    }
                    %opts{$p.key} := nqp::hllizefor(@a, 'perl6');
                }
                else {
                    %opts{$p.key} := nqp::hllizefor($p.value, 'perl6');
                }
            }
            my $file        := nqp::getlexdyn('$?FILES');
            %opts := nqp::box_s(
                (nqp::isnull($file) ?? '' !! $file),
                self.find_symbol(['Str'])
            );
            try { return $ex.new(|%opts) };
        }
        my @err := ['Error while compiling, type ', join('::', $ex_type),  "\n"];
        for %opts -> $key {
            @err.push: '  ';
            @err.push: $key;
            @err.push: ': ';
            @err.push: %opts{$key};
            @err.push: "\n";
        }
        nqp::findmethod(HLL::Grammar, 'panic')($/.CURSOR, join('', @err));
    }
    
    method locprepost($c) {
        my $pos  := $c.pos;
        my $orig := $c.orig;

        my $prestart := $pos - 40;
        $prestart := 0 if $prestart < 0;
        my $pre := nqp::substr($orig, $prestart, $pos - $prestart);
        $pre    := subst($pre, /.*\n/, "", :global);
        $pre    := '' if $pre eq '';
        
        my $postchars := $pos + 40 > nqp::chars($orig) ?? nqp::chars($orig) - $pos !! 40;
        my $post := nqp::substr($orig, $pos, $postchars);
        $post    := subst($post, /\n.*/, "", :global);
        $post    := '' if $post eq '';
        
        [$pre, $post]
    }
    
    method stash_hash($pkg) {
        my $hash := $pkg.WHO;
        unless nqp::ishash($hash) {
            $hash := $hash.FLATTENABLE_HASH();
        }
        $hash
    }

    method ex-handle($/, $code) {
        my $res;
        my $ex;
        my int $nok;
        try {
            $res := $code();
            CATCH {
                $nok := 1;
                $ex  := $_;
            }
        }
        if $nok {
            $*W.rethrow($/, $ex);
        } else {
            $res;
        }
    }

    method rethrow($/, $err) {
        my int $success := 0;
        my $coercer;
        try { $coercer := self.find_symbol(['&COMP_EXCEPTION']); ++$success; };
        nqp::rethrow($err) unless $success;
        my $p6ex := $coercer($err);
        unless nqp::can($p6ex, 'SET_FILE_LINE') {
            try {
                my $x_comp := self.find_symbol(['X', 'Comp']);
                $p6ex.HOW.mixin($p6ex, $x_comp).BUILD_LEAST_DERIVED(nqp::hash());
            }
        }
        if nqp::can($p6ex, 'SET_FILE_LINE') {
            $p6ex.SET_FILE_LINE(
                nqp::box_s(nqp::getlexdyn('$?FILES'),
                    self.find_symbol(['Str'])),
                nqp::box_i(HLL::Compiler.lineof($/.orig, $/.from, :cache(1)),
                    self.find_symbol(['Int'])),
            );
        }
        $p6ex.rethrow();
    }
}
rakudo-2013.12/src/RESTRICTED.setting0000664000175000017500000000154212224263172016444 0ustar  moritzmoritzsub restricted($what) {
    die "$what is disallowed in restricted setting"
}

sub open(|)   { restricted('open') }
sub unlink(|) { restricted('unlink') }
sub shell(|)  { restricted('shell') }
sub run(|)    { restricted('run') }
sub QX(|)     { restricted('qx, qqx') }
sub mkdir(|)  { restricted('mkdir')   }
sub rmdir(|)  { restricted('rmdir') }
sub rename(|) { restricted('rename')  }
sub copy(|)   { restricted('copy')    }
sub spurt(|)  { restricted('spurt')   }
sub link(|)   { restricted('link')   }
sub symlink(|){ restricted('symlink') }
sub chmod(|)  { restricted('chmod')   }

my class RESTRICTED is Mu { 
    method FALLBACK(|) { restricted(self.^name) }  # NYI, but see S12
    method new(|)      { restricted(self.^name) }
    method gist(|)     { restricted(self.^name) }
}

my class IO::Handle is RESTRICTED { }
my class IO::Socket is RESTRICTED { }

rakudo-2013.12/src/vm/jvm/core/asyncops.pm0000664000175000017500000001305012250627156017742 0ustar  moritzmoritz# Waits for a promise to be kept or a channel to be able to receive a value
# and, once it can, unwraps or returns the result. This should be made more
# efficient by using continuations to suspend any task running in the thread
# pool that blocks; for now, this cheat gets the basic idea in place.

proto sub await(|) { * }
multi sub await(Promise $p) {
    $p.result
}
multi sub await(*@awaitables) {
    @awaitables.eager.map(&await)
}
multi sub await(Channel $c) {
    $c.receive
}

my constant $WINNER_KIND_DONE = 0;
my constant $WINNER_KIND_MORE = 1;

sub WINNER(@winner_args, *@pieces, :$wild_done, :$wild_more, :$wait, :$wait_time is copy) {
    my num $start_time = nqp::time_n();
    my Int $num_pieces = +@pieces div 3;
    my $timeout_promise;
    sub invoke_right(&block, $key, $value?) {
        my @names = map *.name, &block.signature.params;
        return do if @names eqv ['$k', '$v'] || @names eqv ['$v', '$k'] {
            &block(:k($key), :v($value));
        } elsif @names eqv ['$_'] || (+@names == 1 && &block.signature.params[0].positional)  {
            &block($value);
        } elsif @names eqv ['$k'] {
            &block(:k($key));
        } elsif @names eqv ['$v'] {
            &block(:v($value));
        } elsif +@names == 0 {
            return &block();
        } else {
            die "couldn't figure out how to invoke {&block.signature().perl}";
        }
    }
    # if we don't have a last block, we need to retry until we
    # have a winner.
    my $action;
    loop {
        my @promises_only;
        my Bool $has_channels = False;
        if $num_pieces > 0 {
            for (^$num_pieces).pick(*) -> $index {
                my ($kind, $arg, &block) = @pieces[$index * 3, $index * 3 + 1, $index * 3 + 2];
                if $kind == $WINNER_KIND_DONE {
                    if $arg ~~ Promise {
                        if $arg {
                            $action = { invoke_right(&block, $arg, $arg.result) };
                            last;
                        }
                        @promises_only.push: $arg;
                    } elsif $arg ~~ Channel {
                        if $arg.closed {
                            $action = { invoke_right(&block, $arg); }
                            last;
                        }
                        $has_channels = True;
                    } else {
                        die "Got a {$arg.WHAT.perl}, but expected a Channel or Promise.";
                    }
                } elsif $kind == $WINNER_KIND_MORE {
                    if $arg ~~ Channel {
                        if (my $val := $arg.poll) !~~ Nil {
                            $action = { invoke_right(&block, $arg, $val); }
                            last;
                        }
                        $has_channels = True;
                    } elsif $arg ~~ Promise {
                        die "cannot use 'more' on a Promise.";
                    } else {
                        die "Got a {$arg.WHAT.perl}, but expected a Channel or Promise.";
                    }
                }
            }
            last if $action;
            if $wait {
                $wait_time -= (nqp::time_n() - $start_time);
                if $wait_time <= 0 || $timeout_promise {
                    $action = $wait;
                    last;
                } elsif !$timeout_promise {
                    $timeout_promise = Promise.in($wait_time);
                    @promises_only.push: $timeout_promise;
                    $num_pieces++;
                    @pieces.push: 0;
                    @pieces.push: $timeout_promise;
                    @pieces.push: $wait;
                }
            }
        } else {
            for @winner_args.pick(*) {
                when Channel {
                    if (my $val := $_.poll()) !~~ Nil {
                        $action = { invoke_right($wild_more, $_, $val) };
                        last;
                    } elsif $_.closed {
                        $action = { invoke_right($wild_done, $_); }
                        last;
                    }
                    $has_channels = True;
                }
                when Promise {
                    if $_ eqv $timeout_promise && $_ {
                        $action = $wait;
                        last;
                    } elsif $_ {
                        $action = { invoke_right($wild_done, $_, $_.result); }
                        last;
                    }
                    @promises_only.push: $_;
                }
                default {
                    die "Got a {$_.WHAT.perl}, but expected a Channel or Promise.";
                }
            }
            last if $action;
            # when we hit this, none of the promises or channels
            # have given us a result. if we have a wait closure,
            # we immediately return, otherwise we block on any
            # of the promises of our args.
            if $wait {
                $wait_time -= (nqp::time_n() - $start_time);
                if $wait_time <= 0 || $timeout_promise {
                    return $wait();
                } elsif !$timeout_promise {
                    $timeout_promise = Promise.in($wait_time);
                    @promises_only.push: $timeout_promise;
                    $num_pieces++;
                    @winner_args.push: $timeout_promise;
                }
            }
            # if we only had promises, we can block on "anyof".
        }
        if $has_channels || (@promises_only == 0) {
            Thread.yield();
        } else {
            Promise.anyof(|@promises_only).result;
        }
    }
    $action()
}
rakudo-2013.12/src/vm/jvm/core/Channel.pm0000664000175000017500000000701112250627156017453 0ustar  moritzmoritz# A channel provides a thread-safe way to send a series of values from some
# producer(s) to some consumer(s).
my class X::Channel::SendOnClosed is Exception {
    method message() { "Cannot send a message on a closed channel" }
}
my class X::Channel::ReceiveOnClosed is Exception {
    method message() { "Cannot receive a message on a closed channel" }
}
my class Channel {
    # The queue of events moving through the channel.
    has Mu $!queue;
    
    # Promise that is triggered when all values are received, or an error is
    # received and the channel is thus closed.
    has $!closed_promise;
    
    # Closed promise's vow.
    has $!closed_promise_vow;
    
    # Flag for if the channel is closed to senders.
    has $!closed;
    
    # Magical objects for various ways a channel can end.
    my class CHANNEL_CLOSE { }
    my class CHANNEL_FAIL  { has $.error }
    
    my Mu $interop;
    submethod BUILD() {
        $interop := nqp::jvmbootinterop() unless nqp::isconcrete($interop);
        my \LinkedBlockingQueue := $interop.typeForName('java.util.concurrent.LinkedBlockingQueue');
        $!queue := LinkedBlockingQueue.'constructor/new/()V'();
        $!closed_promise = Promise.new;
        $!closed_promise_vow = $!closed_promise.vow;
    }
    
    method send(Channel:D: \item) {
        X::Channel::SendOnClosed.new.throw if $!closed;
        $!queue.add($interop.sixmodelToJavaObject(nqp::decont(item)))
    }
    
    method receive(Channel:D:) {
        my \msg := $interop.javaObjectToSixmodel($!queue.take());
        if nqp::istype(msg, CHANNEL_CLOSE) {
            $!closed_promise_vow.keep(Nil);
            X::Channel::ReceiveOnClosed.new.throw
        }
        elsif nqp::istype(msg, CHANNEL_FAIL) {
            $!closed_promise_vow.break(msg.error);
            die msg.error;
        }
        msg
    }
    
    method poll(Channel:D:) {
        my \fetched := $!queue.'method/poll/()Ljava/lang/Object;'();
        if nqp::jvmisnull(fetched) {
            Nil
        } else {
            my \msg := $interop.javaObjectToSixmodel(fetched);
            if nqp::istype(msg, CHANNEL_CLOSE) {
                $!closed_promise_vow.keep(Nil);
                Nil
            }
            elsif nqp::istype(msg, CHANNEL_FAIL) {
                $!closed_promise_vow.break(msg.error);
                Nil
            }
            else {
                msg
            }
        }
    }
    
    method !peek(Channel:D:) {
        my \fetched := $!queue.'method/peek/()Ljava/lang/Object;'();
        if nqp::jvmisnull(fetched) {
            Nil
        } else {
            my \msg := $interop.javaObjectToSixmodel(fetched);
            if nqp::istype(msg, CHANNEL_CLOSE) {
                $!closed_promise_vow.keep(Nil);
                Nil
            }
            elsif nqp::istype(msg, CHANNEL_FAIL) {
                $!closed_promise_vow.break(msg.error);
                Nil
            }
            else {
                msg
            }
        }
    }

    method list($self:) {
        map {
            winner $self {
              more * { $_ }
              done * { last }
            }
        }, *;
    }

    method close() {
        $!closed = 1;
        $!queue.add($interop.sixmodelToJavaObject(CHANNEL_CLOSE))
    }
    
    method fail($error is copy) {
        $!closed = 1;
        $error = X::AdHoc.new(payload => $error) unless nqp::istype($error, Exception);
        $!queue.add($interop.sixmodelToJavaObject(CHANNEL_FAIL.new(:$error)))
    }
    
    method closed() {
        self!peek();
        $!closed_promise
    }
}
rakudo-2013.12/src/vm/jvm/core/CurrentThreadScheduler.pm0000664000175000017500000000150712255230273022513 0ustar  moritzmoritz# Scheduler that always does things immediately, on the current thread.

my class CurrentThreadScheduler does Scheduler {
    method handle_uncaught($exception) {
        $exception.throw
    }

    method cue(&code, :$at, :$in, :$every, :$times = 1, :&catch is copy ) {
        die "Cannot specify :at and :in at the same time"
          if $at.defined and $in.defined;
        die "Cannot specify :every and :times at the same time"
          if $every.defined and $times > 1;
        die "Cannot specify :every in {self.HOW.name(self)}"
          if $every;

        my $delay = $at ?? $at - now !! $in;
        sleep $delay if $delay;
        &catch //=
          self.uncaught_handler // -> $ex { self.handle_uncaught($ex) };

        code() for 1 .. $times;
        CATCH { default { catch($_) } };
    }

    method loads() { 0 }
}
rakudo-2013.12/src/vm/jvm/core/IOAsyncFile.pm0000664000175000017500000000352312242026101020174 0ustar  moritzmoritz# Very basic asynchronous I/O support for files. Work in progress. Things that
# would nomally return something scalar-ish produce a Promise. Things that
# would normally return a (lazy) list produce a Channel.
my class IO::Async::File {
    has $!PIO;
    has $.chomp = Bool::True;
    has $.path;
    
    proto method open(|) { * }
    multi method open($path? is copy, :$r, :$w, :$a, :$bin, :$chomp = Bool::True,
            :enc(:$encoding) = 'utf8') {
        $path //= $!path;
        my $mode = $w ?? 'w' !! ($a ?? 'wa' !! 'r' );
        nqp::bindattr(self, IO::Async::File, '$!PIO',
             nqp::openasync(nqp::unbox_s($path.Str), nqp::unbox_s($mode))
        );
        $!path = $path;
        $!chomp = $chomp;
        nqp::setencoding($!PIO, $bin ?? 'binary' !! NORMALIZE_ENCODING($encoding));
        self;
    }

    method close() {
        nqp::closefh($!PIO);
        Bool::True;
    }
    
    method opened() {
        nqp::p6bool(nqp::istrue($!PIO));
    }
    
    method slurp(IO::Async::File:D: :$bin, :enc($encoding)) {
        self.open(:r, :$bin) unless self.opened;
        self.encoding($encoding) if $encoding.defined;

        if $bin {
            die "Asynchronous binary file reading NYI"
        }
        else {
            my $p = Promise.new;
            nqp::slurpasync($!PIO, Str,
                -> $str { $p.keep($str); self.close(); },
                -> $msg { $p.break($msg); try self.close(); });
            $p
        }
    }
    
    method lines(:enc($encoding)) {
        self.open(:r) unless self.opened;
        self.encoding($encoding) if $encoding.defined;

        my $c := Channel.new;
        nqp::linesasync($!PIO, Str, $.chomp ?? 1 !! 0,
            nqp::getattr($c, Channel, '$!queue'),
            -> { $c.close(); self.close() },
            -> $msg { $c.fail($msg); try self.close(); });
        $c
    }
}
rakudo-2013.12/src/vm/jvm/core/KeyReducer.pm0000664000175000017500000000465512242026101020140 0ustar  moritzmoritz# A KeyReducer provides a thread-safe way to compose a hash from multiple
# sources.
my class X::KeyReducer::ResultObtained is Exception {
    method message() { "Cannot contribute to a KeyReducer after the result has been obtained" }
}
my class KeyReducer {
    has $!initializer;
    has $!reducer;
    has %!result;
    has Mu $!lock;
    has $!exception;
    has $!obtained;
    
    method new($initializer, $reducer) {
        self.bless(:$initializer, :$reducer)
    }
    
    my Mu $interop;
    my Mu $ReentrantLock;
    submethod BUILD(:$!initializer, :$!reducer) {
        unless nqp::isconcrete($interop) {
            $interop := nqp::jvmbootinterop();
            $ReentrantLock := $interop.typeForName('java.util.concurrent.locks.ReentrantLock');
        }
        $!lock := $ReentrantLock.'constructor/new/()V'();
        $!obtained = False;
    }
    
    proto method contribute(|) { * }
    multi method contribute(KeyReducer:D: %h) {
        $!lock.lock();
        if $!exception {
            $!lock.unlock();
            return False;
        }
        if $!obtained {
            $!lock.unlock();
            X::KeyReducer::ResultObtained.new.throw
        }
        try {
            for %h.kv -> $k, $v {
                %!result{$k} = %!result.exists($k)
                    ?? $!reducer(%!result{$k}, $v)
                    !! $!initializer($v)
            }
            CATCH { default { $!exception := $_ } }
        }
        $!lock.unlock();
        True
    }
    multi method contribute(KeyReducer:D: Pair $p) {
        $!lock.lock();
        if $!exception {
            $!lock.unlock();
            return False;
        }
        if $!obtained {
            $!lock.unlock();
            X::KeyReducer::ResultObtained.new.throw
        }
        try {
            %!result{$p.key} = %!result.exists($p.key)
                    ?? $!reducer(%!result{$p.key}, $p.value)
                    !! $!initializer($p.value);
            CATCH { default { $!exception := $_ } }
        }
        $!lock.unlock();
        True
    }
    
    method snapshot(KeyReducer:D:) {
        $!lock.lock();
        if $!exception {
            $!lock.unlock();
            $!exception.throw;
        }
        my %snapshot = %!result;
        $!lock.unlock();
        %snapshot
    }
    
    method result(KeyReducer:D:) {
        $!lock.lock();
        $!obtained = True;
        $!lock.unlock();
        $!exception ?? $!exception.throw !! %!result
    }
}
rakudo-2013.12/src/vm/jvm/core/Lock.pm0000664000175000017500000000100212242026101016745 0ustar  moritzmoritz# A simple, reentrant lock mechanism.
my class Lock {
    has $!lock;

    submethod BUILD() {
        my \ReentrantLock := nqp::jvmbootinterop().typeForName('java.util.concurrent.locks.ReentrantLock');
        $!lock            := ReentrantLock.'constructor/new/()V'();
    }

    method lock() { $!lock.lock() }

    method unlock() { $!lock.unlock() }

    method protect(&code) {
        $!lock.lock();
        my \res := code();
        $!lock.unlock();
        CATCH { $!lock.unlock(); }
        res
    }
}
rakudo-2013.12/src/vm/jvm/core/Promise.pm0000664000175000017500000001402712253363744017531 0ustar  moritzmoritz# A promise is a synchronization mechanism for a piece of work that will
# produce a single result (keeping the promise) or fail (breaking the
# promise).
my enum PromiseStatus (:Planned(0), :Kept(1), :Broken(2));
my class X::Promise::Combinator is Exception {
    has $.combinator;
    method message() { "Can only use $!combinator to combine other Promise objects" }
}
my class X::Promise::CauseOnlyValidOnBroken is Exception {
    method message() { "Can only call cause on a broken promise" }
}
my class X::Promise::Vowed is Exception {
    method message() { "Access denied to keep/break this Promise; already vowed" }
}
my class Promise {
    has $.scheduler;
    has $.status;
    has $!result;
    has int $!vow_taken;
    has Mu $!ready_semaphore;
    has Mu $!lock;
    has @!thens;
    
    submethod BUILD(:$!scheduler = $*SCHEDULER) {
        my $interop       := nqp::jvmbootinterop();
        my \Semaphore     := $interop.typeForName('java.util.concurrent.Semaphore');
        my \ReentrantLock := $interop.typeForName('java.util.concurrent.locks.ReentrantLock');
        $!ready_semaphore := Semaphore.'constructor/new/(I)V'(-1);
        $!lock            := ReentrantLock.'constructor/new/()V'();
        $!status           = Planned;
    }
    
    # A Promise::Vow is used to enable the right to keep/break a promise
    # to be restricted to a given "owner". Taking the Vow for a Promise
    # prevents anybody else from getting hold of it.
    class Vow { ... }
    trusts Vow;
    class Vow {
        has $.promise;
        method keep(\result) {
            $!promise!Promise::keep(result)
        }
        method break(\exception) {
            $!promise!Promise::break(exception)
        }
    }
    method vow() {
        $!lock.lock();
        if $!vow_taken {
            $!lock.unlock();
            X::Promise::Vowed.new.throw
        }
        my $vow := nqp::create(Vow);
        nqp::bindattr($vow, Vow, '$!promise', self);
        $!vow_taken = 1;
        $!lock.unlock();
        $vow
    }

    method keep(Promise:D: $result) {
        self.vow.keep($result)
    }
    
    method !keep($!result) {
        $!status = Kept;
        $!ready_semaphore.'method/release/(I)V'(32768);
        self!schedule_thens();
        $!result
    }
    
    method break(Promise:D: $result) {
        self.vow.break($result)
    }
    
    method !break($result) {
        $!result = $result ~~ Exception ?? $result !! X::AdHoc.new(payload => $result);
        $!status = Broken;
        $!ready_semaphore.'method/release/(I)V'(32768);
        self!schedule_thens();
    }
    
    method !schedule_thens() {
        $!lock.lock();
        while @!thens {
            $!scheduler.cue(@!thens.shift, :catch(@!thens.shift))
        }
        $!lock.unlock();
    }
    
    method result(Promise:D:) {
        # One important missing optimization here is that if the promise is
        # not yet started, then the work can be done immediately by the
        # thing that is blocking on it.
        if $!status == Planned {
            $!ready_semaphore.'method/acquire/()V'();
        }
        if $!status == Kept {
            $!result
        }
        elsif $!status == Broken {
            $!result.throw
        }
    }
    
    method Bool(Promise:D:) {
        so $!status == any(Broken, Kept)
    }

    method cause(Promise:D:) {
        if $!status == Broken {
            $!result
        } else {
            X::Promise::CauseOnlyValidOnBroken.new.throw
        }
    }
    
    method then(Promise:D: &code) {
        $!lock.lock();
        if $!status == any(Broken, Kept) {
            # Already have the result, start immediately.
            $!lock.unlock();
            Promise.start( { code(self) }, :$!scheduler);
        }
        else {
            # Create a Promise, and push 2 entries to @!thens: something that
            # starts the then code, and something that handles its exceptions.
            # They will be sent to the scheduler when this promise is kept or
            # broken.
            my $then_promise = Promise.new(:$!scheduler);
            my $vow = $then_promise.vow;
            @!thens.push({ $vow.keep(code(self)) });
            @!thens.push(-> $ex { $vow.break($ex) });
            $!lock.unlock();
            $then_promise
        }
    }
    
    method start(Promise:U: &code, :$scheduler = $*SCHEDULER) {
        my $p   = Promise.new(:$scheduler);
        my $vow = $p.vow;
        $scheduler.cue(
            { $vow.keep(code()) },
            :catch(-> $ex { $vow.break($ex) }) );
        $p
    }
    
    method in(Promise:U: $seconds, :$scheduler = $*SCHEDULER) {
        my $p   = Promise.new(:$scheduler);
        my $vow = $p.vow;
        $scheduler.cue({ $vow.keep(True) }, :in($seconds));
        $p
    }
    
    method anyof(Promise:U: *@promises) {
        X::Promise::Combinator.new(combinator => 'anyof').throw
            unless @promises >>~~>> Promise;
        self!until_n_kept(@promises, 1)
    }
    
    method allof(Promise:U: *@promises) {
        X::Promise::Combinator.new(combinator => 'allof').throw
            unless @promises >>~~>> Promise;
        self!until_n_kept(@promises, @promises.elems)
    }
    
    my Mu $AtomicInteger;
    method !until_n_kept(@promises, Int $n) {
        once {
            $AtomicInteger := nqp::jvmbootinterop().typeForName('java.util.concurrent.atomic.AtomicInteger');
            Nil;
        }
        my Mu $c := $AtomicInteger.'constructor/new/(I)V'(nqp::decont($n));
        my $p   = Promise.new;
        my $vow = $p.vow;
        for @promises -> $cand {
            $cand.then({
                if .status == Kept {
                    if $c.'decrementAndGet'() == 0 {
                        $vow.keep(True)
                    }
                }
                else {
                    if $c.'getAndAdd'(-($n + 1)) > 0 {
                        $vow.break(.cause)
                    }
                }
            })
        }
        $p
    }
}

# Schedules a piece of asynchronous work using the current scheduler, and
# returns a Promise that represents it.
sub start(&code) { Promise.start(&code) }
rakudo-2013.12/src/vm/jvm/core/Scheduler.pm0000664000175000017500000000122012242026101017775 0ustar  moritzmoritz# Schedulers do this role. It mostly serves as an interface for the things
# that schedulers must do, as well as a way to factor out some common "sugar"
# and infrastructure.

my role Scheduler {
    has &.uncaught_handler is rw;

    method handle_uncaught($exception) {
        my $ch = &!uncaught_handler;
        if $ch {
            $ch($exception);
        }
        else {
            # No default handler, so terminate the application.
            note "Unhandled exception in code scheduled on thread " ~ $*THREAD.id;
            note $exception.gist;
            exit(1);
        }
    }

    method cue { ... }
    
    method loads() { ... }
}
rakudo-2013.12/src/vm/jvm/core/SupplyOperations.pm0000664000175000017500000001101712250627156021444 0ustar  moritzmoritz# Operations we can do on Supplies. Note, many of them need to compose
# the Supply role into classes they create along the way, so they must
# be declared outside of Supply.

my class SupplyOperations is repr('Uninstantiable') {
    # Private versions of the methods to relay events to subscribers, used in
    # implementing various operations.
    my role PrivatePublishing {
        method !more(\msg) {
            for self.tappers {
                .more().(msg)
            }
            Nil;
        }

        method !done() {
            for self.tappers {
                if .done { .done().() }
            }
            Nil;
        }

        method !quit($ex) {
            for self.tappers {
                if .quit { .quit().($ex) }
            }
            Nil;
        }
    }
    
    method for(*@values, :$scheduler = $*SCHEDULER) {
        my class ForSupply does Supply {
            has @!values;
            has $!scheduler;

            submethod BUILD(:@!values, :$!scheduler) {}

            method tap(|c) {
                my $sub = self.Supply::tap(|c);
                $!scheduler.cue(
                    {
                        for @!values -> \val {
                            $sub.more().(val);
                        }
                        if $sub.done -> $l { $l() }
                    },
                    :catch(-> $ex { if $sub.quit -> $t { $t($ex) } })
                );
                $sub
            }
        }
        ForSupply.new(:@values, :$scheduler)
    }

    method interval($interval, $delay = 0, :$scheduler = $*SCHEDULER) {
        my class IntervalSupply does Supply {
            has $!scheduler;
            has $!interval;
            has $!delay;

            submethod BUILD(:$!scheduler, :$!interval, :$!delay) {}

            method tap(|c) {
                my $sub = self.Supply::tap(|c);
                $!scheduler.cue(
                    {
                        state $i = 0;
                        $sub.more().($i++);
                    },
                    :every($!interval), :in($!delay)
                );
                $sub
            }
        }
        IntervalSupply.new(:$interval, :$delay, :$scheduler)
    }

    method do($a, &side_effect) {
        on -> $res {
            $a => sub (\val) { side_effect(val); $res.more(val) }
        }
    }
    
    method grep(Supply $a, &filter) {
        my class GrepSupply does Supply does PrivatePublishing {
            has $!source;
            has &!filter;
            
            submethod BUILD(:$!source, :&!filter) { }
            
            method tap(|c) {
                my $sub = self.Supply::tap(|c);
                my $tap = $!source.tap( -> \val {
                      if (&!filter(val)) { self!more(val) }
                  },
                  done => { self!done(); },
                  quit => -> $ex { self!quit($ex) }
                );
                $sub
            }
        }
        GrepSupply.new(:source($a), :&filter)
    }
    
    method map(Supply $a, &mapper) {
        my class MapSupply does Supply does PrivatePublishing {
            has $!source;
            has &!mapper;
            
            submethod BUILD(:$!source, :&!mapper) { }
            
            method tap(|c) {
                my $sub = self.Supply::tap(|c);
                my $tap = $!source.tap( -> \val {
                      self!more(&!mapper(val))
                  },
                  done => { self!done(); },
                  quit => -> $ex { self!quit($ex) });
                $sub
            }
        }
        MapSupply.new(:source($a), :&mapper)
    }
    
    method merge(Supply $a, Supply $b) {
        my $dones = 0;
        on -> $res {
            $a => {
                more => sub ($val) { $res.more($val) },
                done => {
                    $res.done() if ++$dones == 2;
                }
            },
            $b => {
                more => sub ($val) { $res.more($val) },
                done => {
                    $res.done() if ++$dones == 2;
                }
            }
        }
    }
    
    method zip(Supply $a, Supply $b, &with = &infix:<,>) {
        my @as;
        my @bs;
        on -> $res {
            $a => sub ($val) {
                @as.push($val);
                if @as && @bs {
                    $res.more(with(@as.shift, @bs.shift));
                }
            },
            $b => sub ($val) {
                @bs.push($val);
                if @as && @bs {
                    $res.more(with(@as.shift, @bs.shift));
                }
            }
        }
    }
}
rakudo-2013.12/src/vm/jvm/core/Supply.pm0000664000175000017500000001205112250627156017377 0ustar  moritzmoritz# Anything that can be subscribed to does this role. It provides the basic
# supply management infrastructure, as well as various coercions that
# turn Supply-like things into something else and convenience forms of calls
# to SupplyOperations.

my class SupplyOperations { ... }
my role Supply {
    my class Tap {
        has &.more;
        has &.done;
        has &.quit;
        has $.supply;
        method close() {
            $!supply.close(self)
        }
    }

    has @!tappers;
    has $!tappers_lock = Lock.new;

    method tap(&more, :&done, :&quit) {
        my $sub = Tap.new(:&more, :&done, :&quit, :supply(self));
        $!tappers_lock.protect({
            @!tappers.push($sub);
        });
        $sub
    }

    method close(Tap $t) {
        $!tappers_lock.protect({
            @!tappers .= grep(* !=== $t);
        });
    }

    method tappers() {
        # Shallow clone to provide safe snapshot.
        my @tappers;
        $!tappers_lock.protect({ @tappers = @!tappers });
        @tappers
    }

    method more(\msg) {
        for self.tappers -> $t {
            $t.more().(msg)
        }
        Nil;
    }

    method done() {
        for self.tappers -> $t {
            my $l = $t.done();
            $l() if $l;
        }
        Nil;
    }

    method quit($ex) {
        for self.tappers -> $t {
            my $f = $t.quit();
            $f($ex) if $f;
        }
        Nil;
    }

    method Channel() {
        my $c = Channel.new();
        self.tap( -> \val { $c.send(val) },
          done => { $c.close },
          quit => -> $ex { $c.quit($ex) });
        $c
    }

    method list() {
        # Use a Channel to handle any asynchrony.
        my $c = self.Channel;
        my $condition = False;
        (1..*).map(sub ($) {
            last if $condition;
            winner $c {
                more * { $_ }
                done * { $condition = False; Nil }
            }
        })
    }

    method for(|c)          { SupplyOperations.for(|c) }
    method interval(|c)     { SupplyOperations.interval(|c) }
    method do(&side_effect) { SupplyOperations.do(self, &side_effect) }
    method grep(&filter)    { SupplyOperations.grep(self, &filter) }
    method map(&mapper)     { SupplyOperations.map(self, &mapper) }
    method merge($s)        { SupplyOperations.merge(self, $s) }
    method zip($s, *@with)  { SupplyOperations.zip(self, $s, |@with) }
}

# The on meta-combinator provides a mechanism for implementing thread-safe
# combinators on Supplies. It subscribes to a bunch of sources, but will
# only let one of the specified callbacks to handle their more/done/quit run
# at a time. A little bit actor-like.
my class X::Supply::On::BadSetup is Exception {
    method message() {
        "on requires a callable that returns a list of pairs with Supply keys"
    }
}
my class X::Supply::On::NoMore is Exception {
    method message() {
        "on requires that more be specified for each supply"
    }
}
sub on(&setup) {
    my class OnSupply does Supply {
        has &!setup;
        
        submethod BUILD(:&!setup) { }

        method !add_source(
          $source, $lock, :&more, :&done is copy, :&quit is copy
        ) {
            unless defined &more {
                X::Supply::On::NoMore.new.throw;
            }
            unless defined &done {
                &done = { self.done }
            }
            unless defined &quit {
                &quit = -> $ex { self.quit($ex) }
            }
            $source.tap(
              -> \val {
                  $lock.protect({ more(val) });
                  CATCH { self.quit($_) }
              },
              done => {
                  $lock.protect({ done() });
                  CATCH { self.quit($_) }
              },
              quit => -> $ex {
                  $lock.protect({ quit($ex) });
                  CATCH { self.quit($_) }
              });
        }
        
        method tap(|c) {
            my $sub     = self.Supply::tap(|c);
            my @tappers = &!setup(self);
            my $lock    = Lock.new;

            for @tappers -> $tap {
                unless $tap ~~ Pair && $tap.key ~~ Supply {
                    X::Supply::On::BadSetup.new.throw;
                }
                given $tap.value {
                    when EnumMap {
                        self!add_source($tap.key, $lock, |$tap.value);
                    }
                    when Callable {
                        self!add_source($tap.key, $lock, more => $tap.value);
                    }
                    default {
                        X::Supply::On::BadSetup.new.throw;
                    }
                }
            }
            $sub
        }

        method more(\msg) {
            for self.tappers {
                .more().(msg)
            }
            Nil;
        }

        method done() {
            for self.tappers {
                if .done -> $l { $l() }
            }
            Nil;
        }

        method quit($ex) {
            for self.tappers {
                if .quit -> $t { $t($ex) }
            }
            Nil;
        }
    }

    OnSupply.new(:&setup)
}
rakudo-2013.12/src/vm/jvm/core/Thread.pm0000664000175000017500000000517012242026101017276 0ustar  moritzmoritz# This file contains early work on concurrency support for Rakudo on the JVM.
# The implementation is clearly VM specific, however the aim is to iterate
# towards a backend-independent API.

# Thread represents an OS-level thread. While it could be used directly, it
# is not the preferred way to work in Perl 6. It's a building block for the
# interesting things.
my class Thread {
    # This thread's underlying JVM thread object.
    has Mu $!jvm_thread;

    # Is the thread's lifetime bounded by that of the application, such
    # that when it exits, so does the thread?
    has Bool $.app_lifetime;

    # Thread's (user-defined) name.
    has Str $.name;

    submethod BUILD(:&code!, :$!app_lifetime as Bool = False, :$!name as Str = "") {
        my $interop   := nqp::jvmbootinterop();
        my \JVMThread := $interop.typeForName('java.lang.Thread');
        $!jvm_thread  := JVMThread."constructor/new/(Ljava/lang/Runnable;)V"(
            $interop.proxy('java.lang.Runnable', nqp::hash('run',
                {
                    my $*THREAD = self;
                    code();
                })));
        $!jvm_thread.setDaemon(1) if $!app_lifetime;
    }

    method start(&code, *%adverbs) {
        Thread.new(:&code, |%adverbs).jvm_start()
    }

    method jvm_start(Thread:D:) {
        $!jvm_thread.start();
        self
    }

    method id(Thread:D:) {
        $!jvm_thread.getId();
    }

    method finish(Thread:D:) {
        $!jvm_thread.'method/join/()V'();
        self
    }

    multi method Str(Thread:D:) {
        "Thread<$.id>($.name)"
    }

    method yield(Thread:U:) {
        nqp::jvmbootinterop().typeForName('java.lang.Thread').yield();
    }
}

{
    # This code is a little funky to avoid hitting jvmbootinterop at startup
    # even if we never use anything that needs it. This is because it carries
    # some cost and has a very bad interaction with the evalserver.
    my int $not_yet = 1;
    my $init_thread;
    PROCESS::<$THREAD> := Proxy.new(
        FETCH => -> | {
            unless nqp::isconcrete($init_thread) || $not_yet {
                my $interop   := nqp::jvmbootinterop();
                my \JVMThread := $interop.typeForName('java.lang.Thread');
                $init_thread  := nqp::create(Thread);
                nqp::bindattr($init_thread, Thread, '$!jvm_thread', JVMThread.currentThread());
                nqp::bindattr($init_thread, Thread, '$!app_lifetime', False);
                nqp::bindattr($init_thread, Thread, '$!name', 'Initial thread');
            }
            $init_thread
        },
        STORE => -> | {
            X::Assignment::RO.new.throw
        });
    $not_yet = 0;
}
rakudo-2013.12/src/vm/jvm/core/ThreadPoolScheduler.pm0000664000175000017500000001074712255230273022010 0ustar  moritzmoritz# The ThreadPoolScheduler is a straightforward scheduler that maintains a
# pool of threads and schedules work items in the order they are added
# using them.

my class ThreadPoolScheduler does Scheduler {
    # A concurrent work queue that blocks any worker threads that poll it
    # when empty until some work arrives.
    has Mu $!queue;
    
    # Semaphore to ensure we don't start more than the maximum number of
    # threads allowed.
    has Mu $!thread_start_semaphore;
    
    # Atomic integer roughly tracking outstanding work, used for rough
    # management of the pool size.
    has Mu $!loads;
    
    # Initial and maximum threads.
    has $!initial_threads;
    has $!max_threads;
    
    # Have we started any threads yet?
    has int $!started_any;
    
    # Timer for interval-scheduled things.
    has $!timer;

    # Adds a new thread to the pool, respecting the maximum.
    method !maybe_new_thread() {
        if $!thread_start_semaphore.'method/tryAcquire/(I)Z'(1) {
            my $interop := nqp::jvmbootinterop();
            $!started_any = 1;
            Thread.start(:app_lifetime, {
                loop {
                    my Mu $task := $interop.javaObjectToSixmodel($!queue.take());
                    try {
                        $task();
                        CATCH {
                            default {
                                self.handle_uncaught($_)
                            }
                        }
                    }
                    $!loads.decrementAndGet();
                }
            });
        }
    }
    
    submethod BUILD(:$!initial_threads = 0, :$!max_threads = 16) {
        die "Initial thread pool threads must be less than or equal to maximum threads"
            if $!initial_threads > $!max_threads;
    }
    
    method cue(&code, :$at, :$in, :$every, :$times = 1, :&catch ) {
        die "Cannot specify :at and :in at the same time"
          if $at.defined and $in.defined;
        die "Cannot specify :every and :times at the same time"
          if $every.defined and $times > 1;
        my $delay = $at ?? $at - now !! $in // 0;
        self!initialize unless $!started_any;

        # need repeating
        if $every {
            $!timer.'method/scheduleAtFixedRate/(Ljava/util/TimerTask;JJ)V'(
              nqp::jvmbootinterop().proxy(
                'java.util.TimerTask',
                nqp::hash( 'run', &catch
                  ?? -> { code(); CATCH { default { catch($_) } } }
                  !! -> { code() }
                )
              ),
              ($delay * 1000).Int,
              ($every * 1000).Int);
        }

        # only after waiting a bit or more than once
        elsif $delay or $times > 1 {
            my $todo :=nqp::hash( 'run', &catch
              ?? -> { code(); CATCH { default { catch($_) } } }
              !! -> { code() } );
            for 1 .. $times {
                $!timer.'method/schedule/(Ljava/util/TimerTask;J)V'(
                  nqp::jvmbootinterop().proxy('java.util.TimerTask', $todo),
                  ($delay * 1000).Int);
                $delay = 0;
            }
        }

        # just cue the code
        else {
            my &run := &catch 
               ?? -> { code(); CATCH { default { catch($_) } } }
               !! &code;
            my $loads = $!loads.incrementAndGet();
            self!maybe_new_thread()
                if !$!started_any || $loads > 1;
            $!queue.add(nqp::jvmbootinterop().sixmodelToJavaObject(&run));
        }
    }

    method loads() {
        $!loads.get()
    }

    method !initialize() {
        # Things we will use from the JVM.
        my $interop              := nqp::jvmbootinterop();
        my \LinkedBlockingQueue  := $interop.typeForName('java.util.concurrent.LinkedBlockingQueue');
        my \Semaphore            := $interop.typeForName('java.util.concurrent.Semaphore');
        my \AtomicInteger        := $interop.typeForName('java.util.concurrent.atomic.AtomicInteger');
        my \Timer                := $interop.typeForName('java.util.Timer');
        $!queue                  := LinkedBlockingQueue.'constructor/new/()V'();
        $!thread_start_semaphore := Semaphore.'constructor/new/(I)V'($!max_threads.Int);
        $!loads                  := AtomicInteger.'constructor/new/()V'();
        $!timer                  := Timer.'constructor/new/(Z)V'(True);
        self!maybe_new_thread() for 1..$!initial_threads;
    }
}

# This thread pool scheduler will be the default one.
$PROCESS::SCHEDULER = ThreadPoolScheduler.new();
rakudo-2013.12/src/vm/jvm/ModuleLoaderVMConfig.nqp0000664000175000017500000000677712255230273021317 0ustar  moritzmoritzrole Perl6::ModuleLoaderVMConfig {
    method vm_search_paths() {
        my @search_paths;
        for nqp::jvmclasspaths() -> $path {
            @search_paths.push($path);
        }
        @search_paths
    }
    
    # Locates files we could potentially load for this module.
    method locate_candidates($module_name, @prefixes, :$file) {
        # If its name contains a slash or dot treat is as a path rather than a package name.
        my @candidates;
        if nqp::defined($file) {
            $file := nqp::gethllsym('perl6', 'ModuleLoader').absolute_path($file);
            if nqp::stat($file, 0) {
                my %cand;
                %cand := $file;
                my $dot := nqp::rindex($file, '.');
                my $ext := $dot >= 0 ?? nqp::substr($file, $dot, nqp::chars($file) - $dot) !! '';
                if $ext eq 'class' || $ext eq 'jar' {
                    %cand := $file;
                }
                else {
                    %cand := $file;
                }
                @candidates.push(%cand);
            }
        }
        else {
            # Assemble various files we'd look for.
            my $base_path  := nqp::join('/', nqp::split('::', $module_name));
            my $class_path := $base_path ~ '.class';
            my $jar_path   := $base_path ~ '.jar';
            my $pm_path    := $base_path ~ '.pm';
            my $pm6_path   := $base_path ~ '.pm6';
            
            # Go through the prefixes and build a candidate list.
            for @prefixes -> $prefix {
                $prefix := nqp::gethllsym('perl6', 'ModuleLoader').absolute_path(~$prefix);
                my $have_pm    := nqp::stat("$prefix/$pm_path", 0);
                my $have_pm6   := nqp::stat("$prefix/$pm6_path", 0);
                my $have_class := nqp::stat("$prefix/$class_path", 0);
                my $have_jar   := nqp::stat("$prefix/$jar_path", 0);
                if $have_pm6 {
                    # if there are both .pm and .pm6 we assume that
                    # the former is a Perl 5 module and use the latter
                    $have_pm := 1;
                    $pm_path := $pm6_path;
                }
                if $have_jar {
                    # might be good to error here?
                    $have_class := 1;
                    $class_path := $jar_path;
                }
                if $have_pm {
                    my %cand;
                    %cand := "$prefix/$pm_path";
                    %cand  := "$prefix/$pm_path";
                    if $have_class && nqp::stat("$prefix/$class_path", 7)
                                    >= nqp::stat("$prefix/$pm_path", 7) {
                        %cand := "$prefix/$class_path";
                    }
                    @candidates.push(%cand);
                }
                elsif $have_class {
                    my %cand;
                    %cand  := "$prefix/$class_path";
                    %cand := "$prefix/$class_path";
                    @candidates.push(%cand);
                }
            }
        }
        @candidates
    }
    
    # Finds a setting to load.
    method find_setting($setting_name) {
        my $path := "$setting_name.setting.jar";
        my @prefixes := self.search_path();
        for @prefixes -> $prefix {
            $prefix := nqp::gethllsym('perl6', 'ModuleLoader').absolute_path(~$prefix);
            if nqp::stat("$prefix/$path", 0) {
                $path := "$prefix/$path";
                last;
            }
        }
        $path
    }
}
rakudo-2013.12/src/vm/jvm/Perl6/JavaModuleLoader.nqp0000664000175000017500000000254712255230273021507 0ustar  moritzmoritzclass Perl6::JavaModuleLoader {
    my $interop;
    my $interop_loader;
    
    method set_interop_loader($loader) {
        $interop_loader := $loader;
    }
    
    method load_module($module_name, %opts, *@GLOBALish, :$line, :$file) {
        # Load interop support if needed.
        $interop := $interop_loader() unless nqp::isconcrete($interop);
        
        # Try to get hold of the type.
        my @parts := nqp::split('::', $module_name);
        my $jname := nqp::join('.', @parts);
        my $type  := nqp::existskey(%opts, 'jar')
                        ?? $interop.typeForNameFromJAR($jname, nqp::decont(%opts))
                        !! $interop.typeForName($jname);
        if $type =:= NQPMu {
            nqp::die("Could not locate Java module $jname");
        }
        
        # Return unit-like thing with an EXPORT::DEFAULT.
        nqp::hash('EXPORT', make_package('EXPORT',
            nqp::hash('DEFAULT', make_package('DEFAULT',
                nqp::hash(@parts[nqp::elems(@parts) - 1], $type)))))
    }
    
    sub make_package($name, %who) {
        my $pkg := nqp::knowhow().new_type(:$name);
        $pkg.HOW.compose($pkg);
        nqp::setwho($pkg, %who);
        $pkg
    }
}

Perl6::ModuleLoader.register_language_module_loader('java', Perl6::JavaModuleLoader);
nqp::bindhllsym('perl6', 'JavaModuleLoader', Perl6::JavaModuleLoader);
rakudo-2013.12/src/vm/jvm/Perl6/Metamodel/JavaHOW.nqp0000664000175000017500000000046512224263172021474 0ustar  moritzmoritzclass Perl6::Metamodel::JavaHOW
    does Perl6::Metamodel::Naming
    does Perl6::Metamodel::Stashing
    does Perl6::Metamodel::TypePretense
{
    my $archetypes := Perl6::Metamodel::Archetypes.new( );
    method archetypes() {
        $archetypes
    }
    
    method is_composed($obj) {
        1
    }
}
rakudo-2013.12/src/vm/jvm/Perl6/Ops.nqp0000664000175000017500000002747412224263172017100 0ustar  moritzmoritzmy $ops := nqp::getcomp('QAST').operations;

# Type containing Perl 6 specific ops.
my $TYPE_P6OPS := 'Lorg/perl6/rakudo/RakOps;';

# Other types we'll refer to.
my $TYPE_OPS   := 'Lorg/perl6/nqp/runtime/Ops;';
my $TYPE_CSD   := 'Lorg/perl6/nqp/runtime/CallSiteDescriptor;';
my $TYPE_SMO   := 'Lorg/perl6/nqp/sixmodel/SixModelObject;';
my $TYPE_TC    := 'Lorg/perl6/nqp/runtime/ThreadContext;';
my $TYPE_CF    := 'Lorg/perl6/nqp/runtime/CallFrame;';
my $TYPE_STR   := 'Ljava/lang/String;';
my $TYPE_OBJ   := 'Ljava/lang/Object;';

# Exception categories.
my $EX_CAT_NEXT    := 4;
my $EX_CAT_REDO    := 8;
my $EX_CAT_LAST    := 16;

# Opcode types.
my $RT_OBJ  := 0;
my $RT_INT  := 1;
my $RT_NUM  := 2;
my $RT_STR  := 3;
my $RT_VOID := -1;

# Instruction constants.
my $ALOAD_1     := JAST::Instruction.new( :op('aload_1') );

# Perl 6 opcode specific mappings.
$ops.map_classlib_hll_op('perl6', 'p6box_i', $TYPE_P6OPS, 'p6box_i', [$RT_INT], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6box_n', $TYPE_P6OPS, 'p6box_n', [$RT_NUM], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6box_s', $TYPE_P6OPS, 'p6box_s', [$RT_STR], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6bigint', $TYPE_P6OPS, 'p6bigint', [$RT_NUM], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6parcel', $TYPE_P6OPS, 'p6parcel', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6listiter', $TYPE_P6OPS, 'p6listiter', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6list', $TYPE_P6OPS, 'p6list', [$RT_OBJ, $RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6listitems', $TYPE_P6OPS, 'p6listitems', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6recont_ro', $TYPE_P6OPS, 'p6recont_ro', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6store', $TYPE_P6OPS, 'p6store', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6var', $TYPE_P6OPS, 'p6var', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6reprname', $TYPE_P6OPS, 'p6reprname', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6definite', $TYPE_P6OPS, 'p6definite', [$RT_OBJ], $RT_OBJ, :tc);
$ops.add_hll_op('perl6', 'p6bindsig', :!inlinable, -> $qastcomp, $op {
    my $il := JAST::InstructionList.new();
    $il.append(JAST::Instruction.new( :op('aload_1') ));
    $il.append(JAST::Instruction.new( :op('aload'), 'csd' ));
    $il.append(JAST::Instruction.new( :op('aload'), '__args' ));
    $il.append(JAST::Instruction.new( :op('invokestatic'), $TYPE_P6OPS,
        "p6bindsig", $TYPE_CSD, $TYPE_TC, $TYPE_CSD, "[$TYPE_OBJ" ));
    $il.append(JAST::Instruction.new( :op('dup') ));
    
    my $natlbl := JAST::Label.new( :name('p6bindsig_no_autothread') );
    $il.append(JAST::Instruction.new( :op('ifnonnull'), $natlbl ));
    $il.append(JAST::Instruction.new( :op('aload'), 'cf' ));
    $il.append(JAST::Instruction.new( :op('invokevirtual'),
        $TYPE_CF, 'leave', 'Void' ));
    $il.append(JAST::Instruction.new( :op('return') ));
    $il.append($natlbl);
    
    $il.append(JAST::Instruction.new( :op('astore'), 'csd' ));
    $il.append(JAST::Instruction.new( :op('aload_1') ));
    $il.append(JAST::Instruction.new( :op('getfield'), $TYPE_TC, 'flatArgs', "[$TYPE_OBJ" ));
    $il.append(JAST::Instruction.new( :op('astore'), '__args' ));

    $ops.result($il, $RT_VOID);
});
$ops.map_classlib_hll_op('perl6', 'p6isbindable', $TYPE_P6OPS, 'p6isbindable', [$RT_OBJ, $RT_OBJ], $RT_INT, :tc);
$ops.map_classlib_hll_op('perl6', 'p6bindcaptosig', $TYPE_P6OPS, 'p6bindcaptosig', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6trialbind', $TYPE_P6OPS, 'p6trialbind', [$RT_OBJ, $RT_OBJ, $RT_OBJ], $RT_INT, :tc);
$ops.map_classlib_hll_op('perl6', 'p6typecheckrv', $TYPE_P6OPS, 'p6typecheckrv', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6decontrv', $TYPE_P6OPS, 'p6decontrv', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6capturelex', $TYPE_P6OPS, 'p6capturelex', [$RT_OBJ], $RT_OBJ, :tc, :!inlinable);
$ops.map_classlib_hll_op('perl6', 'p6bindassert', $TYPE_P6OPS, 'p6bindassert', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6stateinit', $TYPE_P6OPS, 'p6stateinit', [], $RT_INT, :tc, :!inlinable);
$ops.map_classlib_hll_op('perl6', 'p6setpre', $TYPE_P6OPS, 'p6setpre', [], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6clearpre', $TYPE_P6OPS, 'p6clearpre', [], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6inpre', $TYPE_P6OPS, 'p6inpre', [], $RT_INT, :tc);
$ops.map_classlib_hll_op('perl6', 'p6setfirstflag', $TYPE_P6OPS, 'p6setfirstflag', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6takefirstflag', $TYPE_P6OPS, 'p6takefirstflag', [], $RT_INT, :tc);
$ops.add_hll_op('perl6', 'p6return', :!inlinable, -> $qastcomp, $op {
    my $il := JAST::InstructionList.new();
    my $exprres := $qastcomp.as_jast($op[0], :want($RT_OBJ));
    $il.append($exprres.jast);
    $*STACK.obtain($il, $exprres);
    $il.append(JAST::Instruction.new( :op('dup') ));
    $il.append(JAST::Instruction.new( :op('aload'), 'cf' ));
    $il.append(JAST::Instruction.new( :op('invokestatic'), $TYPE_OPS,
        'return_o', 'Void', $TYPE_SMO, $TYPE_CF ));
    $il.append(JAST::Instruction.new( :op('aload'), 'cf' ));
    $il.append(JAST::Instruction.new( :op('getfield'), $TYPE_CF, 'outer', $TYPE_CF ));
    $il.append(JAST::Instruction.new( :op('iconst_1') ));
    $il.append(JAST::Instruction.new( :op('putfield'), $TYPE_CF, 'exitAfterUnwind', "Z" ));
    $il.append(JAST::Instruction.new( :op('aload'), 'cf' ));
    $il.append(JAST::Instruction.new( :op('invokevirtual'),
        $TYPE_CF, 'leave', 'Void' ));
    $il.append(JAST::Instruction.new( :op('return') ));
    $ops.result($il, $RT_OBJ);
});
$ops.map_classlib_hll_op('perl6', 'p6routinereturn', $TYPE_P6OPS, 'p6routinereturn', [$RT_OBJ], $RT_OBJ, :tc, :!inlinable);
$ops.map_classlib_hll_op('perl6', 'p6getouterctx', $TYPE_P6OPS, 'p6getouterctx', [$RT_OBJ], $RT_OBJ, :tc, :!inlinable);
$ops.map_classlib_hll_op('perl6', 'p6captureouters', $TYPE_P6OPS, 'p6captureouters', [$RT_OBJ], $RT_OBJ, :tc, :!inlinable);
$ops.add_hll_op('perl6', 'p6argvmarray', -> $qastcomp, $op {
    my $il := JAST::InstructionList.new();
    $il.append(JAST::Instruction.new( :op('aload_1') ));
    $il.append(JAST::Instruction.new( :op('aload'), 'csd' ));
    $il.append(JAST::Instruction.new( :op('aload'), '__args' ));
    $il.append(JAST::Instruction.new( :op('invokestatic'), $TYPE_P6OPS,
        "p6argvmarray", $TYPE_SMO, $TYPE_TC, $TYPE_CSD, "[$TYPE_OBJ" ));
    $ops.result($il, $RT_OBJ);
});
$ops.map_classlib_hll_op('perl6', 'p6bindattrinvres', $TYPE_P6OPS, 'p6bindattrinvres', [$RT_OBJ, $RT_OBJ, $RT_STR, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6finddispatcher', $TYPE_P6OPS, 'p6finddispatcher', [$RT_STR], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6argsfordispatcher', $TYPE_P6OPS, 'p6argsfordispatcher', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6shiftpush', $TYPE_P6OPS, 'p6shiftpush', [$RT_OBJ, $RT_OBJ, $RT_INT], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6arrfindtypes', $TYPE_P6OPS, 'p6arrfindtypes', [$RT_OBJ, $RT_OBJ, $RT_INT, $RT_INT], $RT_INT, :tc);
$ops.map_classlib_hll_op('perl6', 'p6decodelocaltime', $TYPE_P6OPS, 'p6decodelocaltime', [$RT_INT], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6setautothreader', $TYPE_P6OPS, 'p6setautothreader', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'tclc', $TYPE_P6OPS, 'tclc', [$RT_STR], $RT_STR, :tc);
$ops.map_classlib_hll_op('perl6', 'p6sort', $TYPE_P6OPS, 'p6sort', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('perl6', 'p6staticouter', $TYPE_P6OPS, 'p6staticouter', [$RT_OBJ], $RT_OBJ, :tc);
my $p6bool := -> $qastcomp, $op {
    my $il := JAST::InstructionList.new();
    my $exprres := $qastcomp.as_jast($op[0]);
    $il.append($exprres.jast);
    $*STACK.obtain($il, $exprres);
    
    my $cond_type := $exprres.type;
    if $cond_type == $RT_INT {
        $il.append(JAST::PushIVal.new( :value(0) ));
        $il.append(JAST::Instruction.new( :op('lcmp') ));
    }
    elsif $cond_type == $RT_NUM {
        $il.append(JAST::PushNVal.new( :value(0.0) ));
        $il.append(JAST::Instruction.new( :op('dcmpl') ));
    }
    elsif $cond_type == $RT_STR {
        $il.append(JAST::Instruction.new( :op('invokestatic'),
            $TYPE_OPS, 'istrue_s', 'Long', $TYPE_STR ));
        $il.append(JAST::PushIVal.new( :value(0) ));
        $il.append(JAST::Instruction.new( :op('lcmp') ));
    }
    else {
        $il.append(JAST::Instruction.new( :op('aload_1') ));
        $il.append(JAST::Instruction.new( :op('invokestatic'),
            $TYPE_OPS, 'istrue', 'Long', $TYPE_SMO, $TYPE_TC ));
        $il.append(JAST::PushIVal.new( :value(0) ));
        $il.append(JAST::Instruction.new( :op('lcmp') ));
    }
    $il.append(JAST::Instruction.new( :op('aload'), 'tc' ));
    $il.append(JAST::Instruction.new( :op('invokestatic'),
        $TYPE_P6OPS, 'booleanize', $TYPE_SMO, 'I', $TYPE_TC ));
    $ops.result($il, $RT_OBJ);
};
$ops.add_hll_op('perl6', 'p6bool', $p6bool);
$ops.map_classlib_hll_op('perl6', 'p6scalarfromdesc', $TYPE_P6OPS, 'p6scalarfromdesc', [$RT_OBJ], $RT_OBJ, :tc);
$ops.add_hll_op('perl6', 'p6invokehandler', -> $qastcomp, $op {
    $qastcomp.as_jast(QAST::Op.new( :op('call'), $op[0], $op[1] ));
});

$ops.add_hll_op('perl6', 'p6invokeflat', -> $qastcomp, $op {
    $op[1].flat(1);
    $qastcomp.as_jast(QAST::Op.new( :op('call'), $op[0], $op[1]));
});

# Make some of them also available from NQP land, since we use them in the
# metamodel and bootstrap.
$ops.add_hll_op('nqp', 'p6bool', $p6bool);
$ops.map_classlib_hll_op('nqp', 'p6init', $TYPE_P6OPS, 'p6init', [], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('nqp', 'p6settypes', $TYPE_P6OPS, 'p6settypes', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('nqp', 'p6var', $TYPE_P6OPS, 'p6var', [$RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('nqp', 'p6parcel', $TYPE_P6OPS, 'p6parcel', [$RT_OBJ, $RT_OBJ], $RT_OBJ, :tc);
$ops.map_classlib_hll_op('nqp', 'p6isbindable', $TYPE_P6OPS, 'p6isbindable', [$RT_OBJ, $RT_OBJ], $RT_INT, :tc);
$ops.map_classlib_hll_op('nqp', 'p6trialbind', $TYPE_P6OPS, 'p6trialbind', [$RT_OBJ, $RT_OBJ, $RT_OBJ], $RT_INT, :tc);
$ops.map_classlib_hll_op('nqp', 'p6inpre', $TYPE_P6OPS, 'p6inpre', [], $RT_INT, :tc);
$ops.map_classlib_hll_op('nqp', 'jvmrakudointerop', $TYPE_P6OPS, 'jvmrakudointerop', [], $RT_OBJ, :tc);

# Override defor to call defined method.
QAST::OperationsJAST.add_hll_op('perl6', 'defor', -> $qastcomp, $op {
    if +$op.list != 2 {
        nqp::die("Operation 'defor' needs 2 operands");
    }
    my $tmp := $op.unique('defined');
    $qastcomp.as_jast(QAST::Stmts.new(
        QAST::Op.new(
            :op('bind'),
            QAST::Var.new( :name($tmp), :scope('local'), :decl('var') ),
            $op[0]
        ),
        QAST::Op.new(
            :op('if'),
            QAST::Op.new(
                :op('callmethod'), :name('defined'),
                QAST::Var.new( :name($tmp), :scope('local') )
            ),
            QAST::Var.new( :name($tmp), :scope('local') ),
            $op[1]
        )))
});

# Boxing and unboxing configuration.
$ops.add_hll_box('perl6', $RT_INT, -> $qastcomp {
    my $il := JAST::InstructionList.new();
    $il.append($ALOAD_1);
    $il.append(JAST::Instruction.new( :op('invokestatic'), $TYPE_P6OPS,
        'p6box_i', $TYPE_SMO, 'Long', $TYPE_TC ));
    $il
});
$ops.add_hll_box('perl6', $RT_NUM, -> $qastcomp {
    my $il := JAST::InstructionList.new();
    $il.append($ALOAD_1);
    $il.append(JAST::Instruction.new( :op('invokestatic'), $TYPE_P6OPS,
        'p6box_n', $TYPE_SMO, 'Double', $TYPE_TC ));
    $il
});
$ops.add_hll_box('perl6', $RT_STR, -> $qastcomp {
    my $il := JAST::InstructionList.new();
    $il.append($ALOAD_1);
    $il.append(JAST::Instruction.new( :op('invokestatic'), $TYPE_P6OPS,
        'p6box_s', $TYPE_SMO, $TYPE_STR, $TYPE_TC ));
    $il
});
#$ops.force_return_boxing_for_hll('perl6');
rakudo-2013.12/src/vm/jvm/runtime/org/perl6/rakudo/Binder.java0000664000175000017500000014162612224263172023460 0ustar  moritzmoritzpackage org.perl6.rakudo;

import java.util.*;

import org.perl6.nqp.runtime.*;
import org.perl6.nqp.sixmodel.*;
import org.perl6.nqp.sixmodel.reprs.ContextRefInstance;

public final class Binder {
    /* Possible results of binding. */
    public static final int BIND_RESULT_OK       = 0;
    public static final int BIND_RESULT_FAIL     = 1;
    public static final int BIND_RESULT_JUNCTION = 2;
    
    /* Compile time trial binding result indicators. */
    public static final int TRIAL_BIND_NOT_SURE =  0;  /* Plausible, but need to check at runtime. */
    public static final int TRIAL_BIND_OK       =  1;  /* Bind will always work out. */
    public static final int TRIAL_BIND_NO_WAY   = -1;  /* Bind could never work out. */
    
    /* Flags. */
    private static final int SIG_ELEM_BIND_CAPTURE        = 1;
    private static final int SIG_ELEM_BIND_PRIVATE_ATTR   = 2;
    private static final int SIG_ELEM_BIND_PUBLIC_ATTR    = 4;
    private static final int SIG_ELEM_BIND_ATTRIBUTIVE    = (SIG_ELEM_BIND_PRIVATE_ATTR | SIG_ELEM_BIND_PUBLIC_ATTR);
    private static final int SIG_ELEM_SLURPY_POS          = 8;
    private static final int SIG_ELEM_SLURPY_NAMED        = 16;
    private static final int SIG_ELEM_SLURPY_LOL          = 32;
    private static final int SIG_ELEM_SLURPY              = (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED | SIG_ELEM_SLURPY_LOL);
    private static final int SIG_ELEM_INVOCANT            = 64;
    private static final int SIG_ELEM_MULTI_INVOCANT      = 128;
    private static final int SIG_ELEM_IS_RW               = 256;
    private static final int SIG_ELEM_IS_COPY             = 512;
    private static final int SIG_ELEM_IS_PARCEL           = 1024;
    private static final int SIG_ELEM_IS_OPTIONAL         = 2048;
    private static final int SIG_ELEM_ARRAY_SIGIL         = 4096;
    private static final int SIG_ELEM_HASH_SIGIL          = 8192;
    private static final int SIG_ELEM_DEFAULT_FROM_OUTER  = 16384;
    private static final int SIG_ELEM_IS_CAPTURE          = 32768;
    private static final int SIG_ELEM_UNDEFINED_ONLY      = 65536;
    private static final int SIG_ELEM_DEFINED_ONLY        = 131072;
    private static final int SIG_ELEM_DEFINEDNES_CHECK    = (SIG_ELEM_UNDEFINED_ONLY | SIG_ELEM_DEFINED_ONLY);
    private static final int SIG_ELEM_NOMINAL_GENERIC     = 524288;
    private static final int SIG_ELEM_DEFAULT_IS_LITERAL  = 1048576;
    private static final int SIG_ELEM_NATIVE_INT_VALUE    = 2097152;
    private static final int SIG_ELEM_NATIVE_NUM_VALUE    = 4194304;
    private static final int SIG_ELEM_NATIVE_STR_VALUE    = 8388608;
    private static final int SIG_ELEM_NATIVE_VALUE        = (SIG_ELEM_NATIVE_INT_VALUE | SIG_ELEM_NATIVE_NUM_VALUE | SIG_ELEM_NATIVE_STR_VALUE);
    
    /* Hints for Parameter attributes. */
    private static final int HINT_variable_name = 0;
    private static final int HINT_named_names = 1;
    private static final int HINT_type_captures = 2;
    private static final int HINT_flags = 3;
    private static final int HINT_nominal_type = 4;
    private static final int HINT_post_constraints = 5;
    private static final int HINT_coerce_type = 6;
    private static final int HINT_coerce_method = 7;
    private static final int HINT_sub_signature = 8;
    private static final int HINT_default_value = 9;
    private static final int HINT_container_descriptor = 10;
    private static final int HINT_attr_package = 11;
    
    /* Other hints. */
    private static final int HINT_ENUMMAP_storage = 0;
    private static final int HINT_CAPTURE_list = 0;
    private static final int HINT_CAPTURE_hash = 1;
    private static final int HINT_SIG_params = 0;

    private static SixModelObject createBox(ThreadContext tc, RakOps.GlobalExt gcx, Object arg, int flag) {
        switch (flag) {
            case CallSiteDescriptor.ARG_INT:
                return Ops.box_i((long)arg, gcx.Int, tc);
            case CallSiteDescriptor.ARG_NUM:
                return Ops.box_n((double)arg, gcx.Num, tc);
            case CallSiteDescriptor.ARG_STR:
                return Ops.box_s((String)arg, gcx.Str, tc);
            default:
                throw new RuntimeException("Impossible case reached in createBox");
        }
    }
    
    private static String arityFail(ThreadContext tc, RakOps.GlobalExt gcx, SixModelObject params,
            int numParams, int numPosArgs, boolean tooMany) {
        int arity = 0;
        int count = 0;
        String fail = tooMany ? "Too many" : "Not enough";

        /* Work out how many we could have been passed. */
        for (int i = 0; i < numParams; i++) {
            SixModelObject param = params.at_pos_boxed(tc, i);
            param.get_attribute_native(tc, gcx.Parameter, "$!flags", HINT_flags);
            int flags = (int)tc.native_i;
            SixModelObject namedNames = param.get_attribute_boxed(tc,
                gcx.Parameter, "$!named_names", HINT_named_names);

            if (namedNames != null)
                continue;
            if ((flags & SIG_ELEM_SLURPY_NAMED) != 0)
                continue;
            if ((flags & SIG_ELEM_SLURPY_POS) != 0) {
                count = -1;
            }
            else if ((flags & SIG_ELEM_IS_OPTIONAL) != 0) {
                count++;
            }
            else {
                count++;
                arity++;
            }
        }

        /* Now generate decent error. */
        if (arity == count)
            return String.format(
                "%s positional parameters passed; got %d but expected %d",
                fail, numPosArgs, arity);
        else if (count == -1)
            return String.format(
                "%s positional parameters passed; got %d but expected at least %d",
                fail, numPosArgs, arity);
        else
            return String.format(
                "%s positional parameters passed; got %d but expected between %d and %d",
                fail, numPosArgs, arity, count);
    }
    
    /* Returns an appropriate failure mode (junction fail or normal fail). */
    private static int junc_or_fail(RakOps.GlobalExt gcx, SixModelObject value) {
        if (value.st.WHAT == gcx.Junction)
            return BIND_RESULT_JUNCTION;
        else
            return BIND_RESULT_FAIL;
    }
    
    /* Binds any type captures. */
    public static void bindTypeCaptures(ThreadContext tc, SixModelObject typeCaps, CallFrame cf, SixModelObject type) {
        long elems = typeCaps.elems(tc);
        StaticCodeInfo sci = cf.codeRef.staticInfo;
        for (long i = 0; i < elems; i++) {
            String name = typeCaps.at_pos_boxed(tc, i).get_str(tc);
            cf.oLex[sci.oTryGetLexicalIdx(name)] = type;
        }
    }
    
    /* Assigns an attributive parameter to the desired attribute. */
    private static int assignAttributive(ThreadContext tc, CallFrame cf, String varName,
            int paramFlags, SixModelObject attrPackage, SixModelObject value, String[] error) {
        /* Find self. */
        StaticCodeInfo sci = cf.codeRef.staticInfo;
        Integer selfIdx = sci.oTryGetLexicalIdx("self");
        if (selfIdx == null) {
            if (error != null)
                error[0] = String.format(
                    "Unable to bind attributive parameter '%s' - could not find self",
                    varName);
            return BIND_RESULT_FAIL;
        }
        SixModelObject self = cf.oLex[selfIdx];

        /* If it's private, just need to fetch the attribute. */
        SixModelObject assignee;
        if ((paramFlags & SIG_ELEM_BIND_PRIVATE_ATTR) != 0) {
            assignee = self.get_attribute_boxed(tc, attrPackage, varName, STable.NO_HINT);
        }

        /* Otherwise if it's public, do a method call to get the assignee. */
        else {
            throw new RuntimeException("$.x parameters NYI");
        }

        RakOps.p6store(assignee, value, tc);
        return BIND_RESULT_OK;
    }
    
    /* Returns an appropriate failure mode (junction fail or normal fail). */
    private static int juncOrFail(ThreadContext tc, RakOps.GlobalExt gcx, SixModelObject value) {
        if (value.st.WHAT == gcx.Junction)
            return BIND_RESULT_JUNCTION;
        else
            return BIND_RESULT_FAIL;
    }
    
    /* Binds a single argument into the lexpad, after doing any checks that are
     * needed. Also handles any type captures. If there is a sub signature, then
     * re-enters the binder. Returns one of the BIND_RESULT_* codes. */
    private static final CallSiteDescriptor genIns = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    private static final CallSiteDescriptor ACCEPTS_o = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    private static final CallSiteDescriptor ACCEPTS_i = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_INT }, null);
    private static final CallSiteDescriptor ACCEPTS_n = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_NUM }, null);
    private static final CallSiteDescriptor ACCEPTS_s = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_STR }, null);
    private static int bindOneParam(ThreadContext tc, RakOps.GlobalExt gcx, CallFrame cf, SixModelObject param,
            Object origArg, byte origFlag, boolean noNomTypeCheck, String[] error) {
        /* Get parameter flags and variable name. */
        param.get_attribute_native(tc, gcx.Parameter, "$!flags", HINT_flags);
        int paramFlags = (int)tc.native_i;
        param.get_attribute_native(tc, gcx.Parameter, "$!variable_name", HINT_variable_name);
        String varName = tc.native_s;
        if (RakOps.DEBUG_MODE)
            System.err.println(varName);
        
        /* We'll put the value to bind into one of the following locals, and
         * flag will indicate what type of thing it is. */
        int flag;
        long arg_i = 0;
        double arg_n = 0.0;
        String arg_s = null;
        SixModelObject arg_o = null;
        
        /* Check if boxed/unboxed expections are met. */
        int desiredNative = paramFlags & SIG_ELEM_NATIVE_VALUE;
        int gotNative = origFlag & 7;
        if (desiredNative == 0 && gotNative == CallSiteDescriptor.ARG_OBJ) {
            flag = gotNative;
            arg_o = (SixModelObject)origArg;
        }
        else if (desiredNative == SIG_ELEM_NATIVE_INT_VALUE && gotNative == CallSiteDescriptor.ARG_INT) {
            flag = gotNative;
            arg_i = (long)origArg;
        }
        else if (desiredNative == SIG_ELEM_NATIVE_NUM_VALUE && gotNative == CallSiteDescriptor.ARG_NUM) {
            flag = gotNative;
            arg_n = (double)origArg;
        }
        else if (desiredNative == SIG_ELEM_NATIVE_STR_VALUE && gotNative == CallSiteDescriptor.ARG_STR) {
            flag = gotNative;
            arg_s = (String)origArg;
        }
        else if (desiredNative == 0) {
            /* We need to do a boxing operation. */
            flag = CallSiteDescriptor.ARG_OBJ;
            arg_o = createBox(tc, gcx, origArg, gotNative);
        }
        else {
            /* We need to do an unboxing opeation. */
            SixModelObject decontValue = Ops.decont((SixModelObject)origArg, tc);
            StorageSpec spec = decontValue.st.REPR.get_storage_spec(tc, decontValue.st);
            switch (desiredNative) {
                case SIG_ELEM_NATIVE_INT_VALUE:
                    if ((spec.can_box & StorageSpec.CAN_BOX_INT) != 0) {
                        flag = CallSiteDescriptor.ARG_INT;
                        arg_i = decontValue.get_int(tc);
                    }
                    else {
                        if (error != null)
                            error[0] = String.format(
                                "Cannot unbox argument to '%s' as a native int",
                                varName);
                        return BIND_RESULT_FAIL;
                    }
                    break;
                case SIG_ELEM_NATIVE_NUM_VALUE:
                    if ((spec.can_box & StorageSpec.CAN_BOX_NUM) != 0) {
                        flag = CallSiteDescriptor.ARG_NUM;
                        arg_n = decontValue.get_num(tc);
                    }
                    else {
                        if (error != null)
                            error[0] = String.format(
                                "Cannot unbox argument to '%s' as a native num",
                                varName);
                        return BIND_RESULT_FAIL;
                    }
                    break;
                case SIG_ELEM_NATIVE_STR_VALUE:
                    if ((spec.can_box & StorageSpec.CAN_BOX_STR) != 0) {
                        flag = CallSiteDescriptor.ARG_STR;
                        arg_s = decontValue.get_str(tc);
                    }
                    else {
                        if (error != null)
                            error[0] = String.format(
                                "Cannot unbox argument to '%s' as a native str",
                                varName);
                        return BIND_RESULT_FAIL;
                    }
                    break;
                default:
                    if (error != null)
                        error[0] = String.format(
                            "Cannot unbox argument to '%s' as a native type",
                            varName);
                    return BIND_RESULT_FAIL;
            }
        }
        
        /* By this point, we'll either have an object that we might be able to
         * bind if it passes the type check, or a native value that needs no
         * further checking. */
        SixModelObject decontValue = null;
        if (flag == CallSiteDescriptor.ARG_OBJ) {
            /* We need to work on the decontainerized value. */
            decontValue = Ops.decont(arg_o, tc);
            
            /* HLL map it as needed. */
            decontValue = Ops.hllize(decontValue, tc);
            
            /* Skip nominal type check if not needed. */
            if (!noNomTypeCheck) {
                /* Is the nominal type generic and in need of instantiation? (This
                 * can happen in (::T, T) where we didn't learn about the type until
                 * during the signature bind). */
                SixModelObject nomType = param.get_attribute_boxed(tc, gcx.Parameter,
                    "$!nominal_type", HINT_nominal_type);
                if ((paramFlags & SIG_ELEM_NOMINAL_GENERIC) != 0) {
                    SixModelObject HOW = nomType.st.HOW;
                    SixModelObject ig = Ops.findmethod(tc, HOW,
                        "instantiate_generic");
                    SixModelObject ContextRef = tc.gc.ContextRef;
                    SixModelObject cc = ContextRef.st.REPR.allocate(tc, ContextRef.st);
                    ((ContextRefInstance)cc).context = cf;
                    Ops.invokeDirect(tc, ig, genIns,
                        new Object[] { HOW, nomType, cc });
                    nomType = Ops.result_o(tc.curFrame);
                }

                /* If not, do the check. If the wanted nominal type is Mu, then
                 * anything goes. */
                if (nomType != gcx.Mu && Ops.istype_nodecont(decontValue, nomType, tc) == 0) {
                    /* Type check failed; produce error if needed. */
                    if (error != null) {
                        /* XXX include types */
                        error[0] = String.format(
                            "Nominal type check failed for parameter '%s'",
                            varName);
                    }
                
                    /* Report junction failure mode if it's a junction. */
                    return juncOrFail(tc, gcx, decontValue);
                }
            }
        }
        
        /* Type captures. */
        SixModelObject typeCaps = param.get_attribute_boxed(tc, gcx.Parameter,
            "$!type_captures", HINT_type_captures);
        if (typeCaps != null)
            bindTypeCaptures(tc, typeCaps, cf, decontValue.st.WHAT);
        
        /* Do a coercion, if one is needed. */
        SixModelObject coerceType = param.get_attribute_boxed(tc, gcx.Parameter,
            "$!coerce_type", HINT_coerce_type);
        if (coerceType != null) {
            /* Coercing natives not possible - nothing to call a method on. */
            if (flag != CallSiteDescriptor.ARG_OBJ) {
                if (error != null)
                    error[0] = String.format(
                        "Unable to coerce natively typed parameter '%s'",
                        varName);
                return BIND_RESULT_FAIL;
            }
            
            /* Only coerce if we don't already have the correct type. */
            if (Ops.istype(decontValue, coerceType, tc) == 0) {
                param.get_attribute_native(tc, gcx.Parameter, "$!coerce_method", HINT_coerce_method);
                String methName = tc.native_s;
                SixModelObject coerceMeth = Ops.findmethod(tc,
                    decontValue, methName);
                if (coerceMeth != null) {
                    Ops.invokeDirect(tc, coerceMeth,
                        Ops.invocantCallSite,
                        new Object[] { decontValue });
                    decontValue = Ops.decont(Ops.result_o(tc.curFrame), tc);
                }
                else {
                    if (error != null)
                        error[0] = String.format(
                            "Unable to coerce value for '%s' to %s; no coercion method defined",
                            varName, methName);
                    return BIND_RESULT_FAIL;
                }
            }
        }
        
        /* If it's not got attributive binding, we'll go about binding it into the
         * lex pad. */
        StaticCodeInfo sci = cf.codeRef.staticInfo;
        if ((paramFlags & SIG_ELEM_BIND_ATTRIBUTIVE) == 0 && varName != null) {
            /* Is it native? If so, just go ahead and bind it. */
            if (flag != CallSiteDescriptor.ARG_OBJ) {
                switch (flag) {
                    case CallSiteDescriptor.ARG_INT:
                        cf.iLex[sci.iTryGetLexicalIdx(varName)] = arg_i;
                        break;
                    case CallSiteDescriptor.ARG_NUM:
                        cf.nLex[sci.nTryGetLexicalIdx(varName)] = arg_n;
                        break;
                    case CallSiteDescriptor.ARG_STR:
                        cf.sLex[sci.sTryGetLexicalIdx(varName)] = arg_s;
                        break;
                }
            }
            
            /* Otherwise it's some objecty case. */
            else if ((paramFlags & SIG_ELEM_IS_RW) != 0) {
                /* XXX TODO Check if rw flag is set; also need to have a
                 * wrapper container that carries extra constraints. */
                cf.oLex[sci.oTryGetLexicalIdx(varName)] = arg_o;
            }
            else if ((paramFlags & SIG_ELEM_IS_PARCEL) != 0) {
                /* Just bind the thing as is into the lexpad. */
                cf.oLex[sci.oTryGetLexicalIdx(varName)] = arg_o;
            }
            else {
                /* If it's an array, copy means make a new one and store,
                 * and a normal bind is a straightforward binding plus
                 * adding a constraint. */
                if ((paramFlags & SIG_ELEM_ARRAY_SIGIL) != 0) {
                    SixModelObject bindee = decontValue;
                    if ((paramFlags & SIG_ELEM_IS_COPY) != 0) {
                        bindee = RakOps.p6list(gcx.EMPTYARR.clone(tc), gcx.Array, gcx.True, tc);
                        RakOps.p6store(bindee, decontValue, tc);
                    }
                    cf.oLex[sci.oTryGetLexicalIdx(varName)] = bindee;
                }
                
                /* If it's a hash, similar approach to array. */
                else if ((paramFlags & SIG_ELEM_HASH_SIGIL) != 0) {
                    SixModelObject bindee = decontValue;
                    if ((paramFlags & SIG_ELEM_IS_COPY) != 0) {
                        SixModelObject BOOTHash = tc.gc.BOOTHash;
                        bindee = gcx.Hash.st.REPR.allocate(tc, gcx.Hash.st);
                        bindee.bind_attribute_boxed(tc, gcx.EnumMap, "$!storage",
                            HINT_ENUMMAP_storage, BOOTHash.st.REPR.allocate(tc, BOOTHash.st));
                        RakOps.p6store(bindee, decontValue, tc);
                    }
                    cf.oLex[sci.oTryGetLexicalIdx(varName)] = bindee;
                }
                
                /* If it's a scalar, we always need to wrap it into a new
                 * container and store it, for copy or ro case (the rw bit
                 * in the container descriptor takes care of the rest). */
                else {
                    STable stScalar = gcx.Scalar.st;
                    SixModelObject new_cont = stScalar.REPR.allocate(tc, stScalar);
                    SixModelObject desc = param.get_attribute_boxed(tc, gcx.Parameter,
                        "$!container_descriptor", HINT_container_descriptor);
                    new_cont.bind_attribute_boxed(tc, gcx.Scalar, "$!descriptor",
                        RakudoContainerSpec.HINT_descriptor, desc);
                    new_cont.bind_attribute_boxed(tc, gcx.Scalar, "$!value",
                        RakudoContainerSpec.HINT_value, decontValue);
                    cf.oLex[sci.oTryGetLexicalIdx(varName)] = new_cont;
                }
            }
        }
        
        /* Is it the invocant? If so, also have to bind to self lexical. */
        if ((paramFlags & SIG_ELEM_INVOCANT) != 0)
            cf.oLex[sci.oTryGetLexicalIdx("self")] = decontValue;

        /* Handle any constraint types (note that they may refer to the parameter by
         * name, so we need to have bound it already). */
        SixModelObject postConstraints = param.get_attribute_boxed(tc, gcx.Parameter,
            "$!post_contraints", HINT_post_constraints);
        if (postConstraints != null) {
            long numConstraints = postConstraints.elems(tc);
            for (long i = 0; i < numConstraints; i++) {
                /* Check we meet the constraint. */
                SixModelObject consType = postConstraints.at_pos_boxed(tc, i);
                SixModelObject acceptsMeth = Ops.findmethod(consType, "ACCEPTS", tc);
                if (Ops.istype(consType, gcx.Code, tc) != 0)
                    RakOps.p6capturelex(consType, tc);
                switch (flag) {
                    case CallSiteDescriptor.ARG_INT:
                        Ops.invokeDirect(tc, acceptsMeth,
                            ACCEPTS_i, new Object[] { consType, arg_i });
                        break;
                    case CallSiteDescriptor.ARG_NUM:
                        Ops.invokeDirect(tc, acceptsMeth,
                            ACCEPTS_n, new Object[] { consType, arg_n });
                        break;
                    case CallSiteDescriptor.ARG_STR:
                        Ops.invokeDirect(tc, acceptsMeth,
                            ACCEPTS_s, new Object[] { consType, arg_s });
                        break;
                    default:
                        Ops.invokeDirect(tc, acceptsMeth,
                            ACCEPTS_o, new Object[] { consType, arg_o });
                        break;
                }
                long result = Ops.istrue(
                    Ops.result_o(tc.curFrame), tc);
                if (result == 0) {
                    if (error != null)
                        error[0] = "Constraint type check failed for parameter '" + varName + "'";
                    return BIND_RESULT_FAIL;
                }
            }
        }

        /* TODO: attributives. */
        if ((paramFlags & SIG_ELEM_BIND_ATTRIBUTIVE) != 0) {
            if (flag != CallSiteDescriptor.ARG_OBJ) {
                if (error != null)
                    error[0] = "Native attributive binding not yet implemented";
                return BIND_RESULT_FAIL;
            }
            int result = assignAttributive(tc, cf, varName, paramFlags,
                param.get_attribute_boxed(tc, gcx.Parameter, "$!attr_package", HINT_attr_package),
                decontValue, error);
            if (result != BIND_RESULT_OK)
                return result;
        }

        /* If it has a sub-signature, bind that. */
        SixModelObject subSignature = param.get_attribute_boxed(tc, gcx.Parameter,
            "$!sub_signature", HINT_sub_signature);
        if (subSignature != null && flag == CallSiteDescriptor.ARG_OBJ) {
            /* Turn value into a capture, unless we already have one. */
            SixModelObject capture = null;
            int result;
            if ((paramFlags & SIG_ELEM_IS_CAPTURE) != 0) {
                capture = decontValue;
            }
            else {
                SixModelObject meth = Ops.findmethod(decontValue, "Capture", tc);
                if (meth == null) {
                    if (error != null)
                        error[0] = "Could not turn argument into capture";
                    return BIND_RESULT_FAIL;
                }
                Ops.invokeDirect(tc, meth, Ops.invocantCallSite, new Object[] { decontValue });
                capture = Ops.result_o(tc.curFrame);
            }

            SixModelObject subParams = subSignature
                .get_attribute_boxed(tc, gcx.Signature, "$!params", HINT_SIG_params);
            /* Recurse into signature binder. */
            CallSiteDescriptor subCsd = explodeCapture(tc, gcx, capture);
            result = bind(tc, gcx, cf, subParams, subCsd, tc.flatArgs, noNomTypeCheck, error);
            if (result != BIND_RESULT_OK)
            {
                if (error != null) {
                    /* Note in the error message that we're in a sub-signature. */
                    error[0] += " in sub-signature";

                    /* Have we a variable name? */
                    if (varName != null) {
                        error[0] += " of parameter " + varName;
                    }
                }
                return result;
            }
        }

        if (RakOps.DEBUG_MODE)
            System.err.println("bindOneParam NYFI");
        
        return BIND_RESULT_OK;
    }

    private static final CallSiteDescriptor exploder = new CallSiteDescriptor(new byte[] {
        CallSiteDescriptor.ARG_OBJ | CallSiteDescriptor.ARG_FLAT,
            CallSiteDescriptor.ARG_OBJ | CallSiteDescriptor.ARG_FLAT | CallSiteDescriptor.ARG_NAMED
    }, null);
    public static CallSiteDescriptor explodeCapture(ThreadContext tc, RakOps.GlobalExt gcx, SixModelObject capture) {
        capture = Ops.decont(capture, tc);

        SixModelObject capType = gcx.Capture;
        SixModelObject list = capture.get_attribute_boxed(tc, capType, "$!list", HINT_CAPTURE_list);
        SixModelObject hash = capture.get_attribute_boxed(tc, capType, "$!hash", HINT_CAPTURE_hash);
        if (list == null)
            list = gcx.EMPTYARR;
        if (hash == null)
            hash = gcx.EMPTYHASH;

        return exploder.explodeFlattening(tc.curFrame, new Object[] { list, hash });
    }

    /* This takes a signature element and either runs the closure to get a default
     * value if there is one, or creates an appropriate undefined-ish thingy. */
    private static SixModelObject handleOptional(ThreadContext tc, RakOps.GlobalExt gcx, int flags, SixModelObject param, CallFrame cf) {
        /* Is the "get default from outer" flag set? */
        if ((flags & SIG_ELEM_DEFAULT_FROM_OUTER) != 0) {
            param.get_attribute_native(tc, gcx.Parameter, "$!variable_name", HINT_variable_name);
            String varName = tc.native_s;
            CallFrame curOuter = cf.outer;
            while (curOuter != null) {
                Integer idx = curOuter.codeRef.staticInfo.oTryGetLexicalIdx(varName);
                if (idx != null)
                    return curOuter.oLex[idx];
                curOuter = curOuter.outer;
            }
            return null;
        }

        /* Do we have a default value or value closure? */
        SixModelObject defaultValue = param.get_attribute_boxed(tc, gcx.Parameter,
            "$!default_value", HINT_default_value);
        if (defaultValue != null) {
            if ((flags & SIG_ELEM_DEFAULT_IS_LITERAL) != 0) {
                return defaultValue;
            }
            else {
                /* Thunk; run it to get a value. */
                Ops.invokeArgless(tc, defaultValue);
                return Ops.result_o(tc.curFrame);
            }
        }

        /* Otherwise, go by sigil to pick the correct default type of value. */
        else {
            if ((flags & SIG_ELEM_ARRAY_SIGIL) != 0) {
                return RakOps.p6list(null, gcx.Array, gcx.True, tc);
            }
            else if ((flags & SIG_ELEM_HASH_SIGIL) != 0) {
                SixModelObject res = gcx.Hash.st.REPR.allocate(tc, gcx.Hash.st);
                return res;
            }
            else {
                return param.get_attribute_boxed(tc, gcx.Parameter, "$!nominal_type", HINT_nominal_type);
            }
        }
    }
    
    /* Takes a signature along with positional and named arguments and binds them
     * into the provided callframe. Returns BIND_RESULT_OK if binding works out,
     * BIND_RESULT_FAIL if there is a failure and BIND_RESULT_JUNCTION if the
     * failure was because of a Junction being passed (meaning we need to auto-thread). */
    public static int bind(ThreadContext tc, RakOps.GlobalExt gcx, CallFrame cf, SixModelObject params,
            CallSiteDescriptor csd, Object[] args,
            boolean noNomTypeCheck, String[] error) {
        int bindFail = BIND_RESULT_OK;
        int curPosArg = 0;
        
        /* If we have a |$foo that's followed by slurpies, then we can suppress
         * any future arity checks. */
        boolean suppressArityFail = false;
        
        /* If we do have some named args, we want to make a clone of the hash
         * to work on. We'll delete stuff from it as we bind, and what we have
         * left over can become the slurpy hash or - if we aren't meant to be
         * taking one - tell us we have a problem. */
        HashMap namedArgsCopy = csd.nameMap == null
            ? null
            : new HashMap(csd.nameMap);
        
        /* Now we'll walk through the signature and go about binding things. */
        int numPosArgs = csd.numPositionals;
        long numParams = params.elems(tc);
        for (long i = 0; i < numParams; i++) {
            /* Get parameter, its flags and any named names. */
            SixModelObject param = params.at_pos_boxed(tc, i);
            param.get_attribute_native(tc, gcx.Parameter, "$!flags", HINT_flags);
            int flags = (int)tc.native_i;
            SixModelObject namedNames = param.get_attribute_boxed(tc,
                gcx.Parameter, "$!named_names", HINT_named_names);
            
            /* Is it looking for us to bind a capture here? */
            if ((flags & SIG_ELEM_IS_CAPTURE) != 0) {
                /* Capture the arguments from this point forwards into a Capture.
                 * Of course, if there's no variable name we can (cheaply) do pretty
                 * much nothing. */
                param.get_attribute_native(tc, gcx.Parameter, "$!variable_name", HINT_variable_name);
                if (tc.native_s == null) {
                   bindFail = BIND_RESULT_OK;
                }
                else {
                    SixModelObject posArgs = gcx.EMPTYARR.clone(tc);
                    for (int k = curPosArg; k < numPosArgs; k++) {
                        switch (csd.argFlags[k]) {
                        case CallSiteDescriptor.ARG_OBJ:
                            posArgs.push_boxed(tc, (SixModelObject)args[k]);
                            break;
                        case CallSiteDescriptor.ARG_INT:
                            posArgs.push_boxed(tc, RakOps.p6box_i((long)args[k], tc));
                            break;
                        case CallSiteDescriptor.ARG_NUM:
                            posArgs.push_boxed(tc, RakOps.p6box_n((double)args[k], tc));
                            break;
                        case CallSiteDescriptor.ARG_STR:
                            posArgs.push_boxed(tc, RakOps.p6box_s((String)args[k], tc));
                            break;
                        }
                    }                    
                    SixModelObject namedArgs = vmHashOfRemainingNameds(tc, gcx, namedArgsCopy, args);
                    
                    SixModelObject capType = gcx.Capture;
                    SixModelObject capSnap = capType.st.REPR.allocate(tc, capType.st);
                    capSnap.bind_attribute_boxed(tc, capType, "$!list", HINT_CAPTURE_list, posArgs);
                    capSnap.bind_attribute_boxed(tc, capType, "$!hash", HINT_CAPTURE_hash, namedArgs);
                    
                    bindFail = bindOneParam(tc, gcx, cf, param, capSnap, CallSiteDescriptor.ARG_OBJ,
                        noNomTypeCheck, error);               
                }
                if (bindFail != 0) {
                    return bindFail;
                }
                else if (i + 1 == numParams) {
                    /* Since a capture acts as "the ultimate slurpy" in a sense, if
                     * this is the last parameter in the signature we can return
                     * success right off the bat. */
                    return BIND_RESULT_OK;
                }
                else {
                    SixModelObject nextParam = params.at_pos_boxed(tc, i + 1);
                    nextParam.get_attribute_native(tc, gcx.Parameter, "$!flags", HINT_flags);
                    if (((int)tc.native_i & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED)) != 0)
                        suppressArityFail = true;
                }
            }
            
            /* Could it be a named slurpy? */
            else if ((flags & SIG_ELEM_SLURPY_NAMED) != 0) {
                SixModelObject slurpy = vmHashOfRemainingNameds(tc, gcx, namedArgsCopy, args);
                SixModelObject bindee = gcx.Hash.st.REPR.allocate(tc, gcx.Hash.st);
                bindee.bind_attribute_boxed(tc, gcx.EnumMap, "$!storage",
                    HINT_ENUMMAP_storage, slurpy);
                bindFail = bindOneParam(tc, gcx, cf, param, bindee, CallSiteDescriptor.ARG_OBJ,
                    noNomTypeCheck, error);
                if (bindFail != 0)
                    return bindFail;
                
                /* Nullify named arguments hash now we've consumed it, to mark all
                 * is well. */
                namedArgsCopy = null;
            }
            
            /* Otherwise, maybe it's a positional of some kind. */
            else if (namedNames == null) {
                /* Slurpy or LoL-slurpy? */
                if ((flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_LOL)) != 0) {
                    /* Create Perl 6 array, create VM array of all remaining things,
                     * then store it. */
                    SixModelObject slurpy = gcx.EMPTYARR.clone(tc);
                    while (curPosArg < numPosArgs) {
                        switch (csd.argFlags[curPosArg]) {
                        case CallSiteDescriptor.ARG_OBJ:
                            slurpy.push_boxed(tc, (SixModelObject)args[curPosArg]);
                            break;
                        case CallSiteDescriptor.ARG_INT:
                            slurpy.push_boxed(tc, RakOps.p6box_i((long)args[curPosArg], tc));
                            break;
                        case CallSiteDescriptor.ARG_NUM:
                            slurpy.push_boxed(tc, RakOps.p6box_n((double)args[curPosArg], tc));
                            break;
                        case CallSiteDescriptor.ARG_STR:
                            slurpy.push_boxed(tc, RakOps.p6box_s((String)args[curPosArg], tc));
                            break;
                        }
                        curPosArg++;
                    }
                    
                    SixModelObject bindee;
                    if ((flags & SIG_ELEM_SLURPY_POS) != 0) {
                        if ((flags & SIG_ELEM_IS_RW) != 0)
                            bindee = RakOps.p6list(slurpy, gcx.List, gcx.True, tc);
                        else
                            bindee = RakOps.p6list(slurpy, gcx.Array, gcx.True, tc);
                    }
                    else {
                        bindee = RakOps.p6list(slurpy, gcx.LoL, gcx.False, tc);
                    }
                    
                    bindFail = bindOneParam(tc, gcx, cf, param, bindee, CallSiteDescriptor.ARG_OBJ,
                        noNomTypeCheck, error);
                    if (bindFail != 0)
                        return bindFail;
                }
                
                /* Otherwise, a positional. */
                else {
                    /* Do we have a value?. */
                    if (curPosArg < numPosArgs) {
                        /* Easy - just bind that. */
                        bindFail = bindOneParam(tc, gcx, cf, param, args[curPosArg],
                            csd.argFlags[curPosArg], noNomTypeCheck, error);
                        if (bindFail != 0)
                            return bindFail;
                        curPosArg++;
                    }
                    else {
                        /* No value. If it's optional, fetch a default and bind that;
                         * if not, we're screwed. Note that we never nominal type check
                         * an optional with no value passed. */
                        if ((flags & SIG_ELEM_IS_OPTIONAL) != 0) {
                            bindFail = bindOneParam(tc, gcx, cf, param,
                                handleOptional(tc, gcx, flags, param, cf),
                                CallSiteDescriptor.ARG_OBJ, false, error);
                            if (bindFail != 0)
                                return bindFail;
                        }
                        else {
                            if (error != null)
                                error[0] = arityFail(tc, gcx, params, (int)numParams, numPosArgs, false);
                            return BIND_RESULT_FAIL;
                        }
                    }
                }
            }
            
            /* Else, it's a non-slurpy named. */
            else {
                /* Try and get hold of value. */
                Integer lookup = null;
                if (namedArgsCopy != null) {
                    long numNames = namedNames.elems(tc);
                    for (long j = 0; j < numNames; j++) {
                        String name = namedNames.at_pos_boxed(tc, j).get_str(tc);
                        lookup = namedArgsCopy.remove(name);
                        if (lookup != null)
                            break;
                    }
                }
                
                /* Did we get one? */
                if (lookup == null) {
                    /* Nope. We'd better hope this param was optional... */
                    if ((flags & SIG_ELEM_IS_OPTIONAL) != 0) {
                        bindFail = bindOneParam(tc, gcx, cf, param,
                            handleOptional(tc, gcx, flags, param, cf),
                            CallSiteDescriptor.ARG_OBJ, false, error);
                    }
                    else if (!suppressArityFail) {
                        if (error != null)
                            error[0] = "Required named parameter '" +
                                namedNames.at_pos_boxed(tc, 0).get_str(tc) +
                                "' not passed";
                        return BIND_RESULT_FAIL;
                    }
                }
                else {
                    bindFail = bindOneParam(tc, gcx, cf, param, args[lookup >> 3],
                        (byte)(lookup & 7), noNomTypeCheck, error);
                }

                /* If we got a binding failure, return it. */
                if (bindFail != 0)
                    return bindFail;
            }
        }
        
        /* Do we have any left-over args? */
        if (curPosArg < numPosArgs && !suppressArityFail) {
            /* Oh noes, too many positionals passed. */
            if (error != null)
                error[0] = arityFail(tc, gcx, params, (int)numParams, numPosArgs, true);
            return BIND_RESULT_FAIL;
        }
        if (namedArgsCopy != null && namedArgsCopy.size() > 0) {
            /* Oh noes, unexpected named args. */
            if (error != null) {
                int numExtra = namedArgsCopy.size();
                if (numExtra == 1) {
                    for (String name : namedArgsCopy.keySet())
                        error[0] = "Unexpected named parameter '" + name + "' passed";
                }
                else {
                    boolean first = true;
                    error[0] = numExtra + " unexpected named parameters passed (";
                    for (String name : namedArgsCopy.keySet()) {
                        if (!first)
                            error[0] += ", ";
                        else
                            first = false;
                        error[0] += name;
                    }
                    error[0] += ")";
                }
            }
            return BIND_RESULT_FAIL;
        }

        /* If we get here, we're done. */
        return BIND_RESULT_OK;
    }
    
    /* Takes any nameds we didn't capture yet and makes a VM Hash of them. */
    private static SixModelObject vmHashOfRemainingNameds(ThreadContext tc, RakOps.GlobalExt gcx, HashMap namedArgsCopy, Object[] args) {
        SixModelObject slurpy = gcx.Mu;
        if (namedArgsCopy != null) {
            SixModelObject BOOTHash = tc.gc.BOOTHash;
            slurpy = BOOTHash.st.REPR.allocate(tc, BOOTHash.st);
            for (String name : namedArgsCopy.keySet()) {
                int lookup = namedArgsCopy.get(name);
                switch (lookup & 7) {
                case CallSiteDescriptor.ARG_OBJ:
                    slurpy.bind_key_boxed(tc, name, (SixModelObject)args[lookup >> 3]);
                    break;
                case CallSiteDescriptor.ARG_INT:
                    slurpy.bind_key_boxed(tc, name, RakOps.p6box_i((long)args[lookup >> 3], tc));
                    break;
                case CallSiteDescriptor.ARG_NUM:
                    slurpy.bind_key_boxed(tc, name, RakOps.p6box_n((double)args[lookup >> 3], tc));
                    break;
                case CallSiteDescriptor.ARG_STR:
                    slurpy.bind_key_boxed(tc, name, RakOps.p6box_s((String)args[lookup >> 3], tc));
                    break;
                }
            }
        }
        return slurpy;
    }
    
    /* Compile time trial binding; tries to determine at compile time whether
     * certain binds will/won't work. */
    public static int trialBind(ThreadContext tc, RakOps.GlobalExt gcx, SixModelObject params,
            CallSiteDescriptor csd, Object[] args) {
        /* If there's a single capture parameter, then we're OK. (Worth
         * handling especially as it's the common case for protos). */
        int numParams = (int)params.elems(tc);
        if (numParams == 1) {
            SixModelObject param = params.at_pos_boxed(tc, 0);
            param.get_attribute_native(tc, gcx.Parameter, "$!flags", HINT_flags);
            int flags = (int)tc.native_i;
            if ((flags & SIG_ELEM_IS_CAPTURE) != 0)
                return TRIAL_BIND_OK;
        }
            
        /* Walk through the signature and consider the parameters. */
        int numPosArgs = csd.numPositionals;
        int curPosArg = 0;
        for (int i = 0; i < numParams; i++) {
            /* If the parameter is anything other than a boring old
             * positional parameter, we won't analyze it. */
            SixModelObject param = params.at_pos_boxed(tc, i);
            param.get_attribute_native(tc, gcx.Parameter, "$!flags", HINT_flags);
            int flags = (int)tc.native_i;
            if ((flags & ~(
                    SIG_ELEM_MULTI_INVOCANT | SIG_ELEM_IS_PARCEL |
                    SIG_ELEM_IS_COPY | SIG_ELEM_ARRAY_SIGIL |
                    SIG_ELEM_HASH_SIGIL | SIG_ELEM_NATIVE_VALUE |
                    SIG_ELEM_IS_OPTIONAL)) != 0)
                return TRIAL_BIND_NOT_SURE;
            SixModelObject namedNames = param.get_attribute_boxed(tc,
                gcx.Parameter, "$!named_names", HINT_named_names);
            if (namedNames != null)
                return TRIAL_BIND_NOT_SURE;
            SixModelObject postConstraints = param.get_attribute_boxed(tc,
                gcx.Parameter, "$!post_constraints", HINT_post_constraints);
            if (postConstraints != null)
                return TRIAL_BIND_NOT_SURE;
            SixModelObject typeCaptures = param.get_attribute_boxed(tc,
                gcx.Parameter, "$!type_captures", HINT_type_captures);
            if (typeCaptures != null)
                return TRIAL_BIND_NOT_SURE;

            /* Do we have an argument for this parameter? */
            if (curPosArg >= numPosArgs) {
                /* No; if it's not optional, fail.*/
                if ((flags & SIG_ELEM_IS_OPTIONAL) == 0)
                    return TRIAL_BIND_NO_WAY;
            }
            else {
                /* Yes, need to consider type. */
                int gotPrim = csd.argFlags[curPosArg];
                if ((flags & SIG_ELEM_NATIVE_VALUE) != 0) {
                    if (gotPrim == CallSiteDescriptor.ARG_OBJ) {
                        /* We got an object; if we aren't sure we can unbox, we can't
                         * be sure about the dispatch. */
                        SixModelObject arg = (SixModelObject)args[i];
                        StorageSpec spec = arg.st.REPR.get_storage_spec(tc, arg.st);
                        switch (flags & SIG_ELEM_NATIVE_VALUE) {
                            case SIG_ELEM_NATIVE_INT_VALUE:
                                if ((spec.can_box & StorageSpec.CAN_BOX_INT) == 0)
                                    return TRIAL_BIND_NOT_SURE;
                                break;
                            case SIG_ELEM_NATIVE_NUM_VALUE:
                                if ((spec.can_box & StorageSpec.CAN_BOX_NUM) == 0)
                                    return TRIAL_BIND_NOT_SURE;
                                break;
                            case SIG_ELEM_NATIVE_STR_VALUE:
                                if ((spec.can_box & StorageSpec.CAN_BOX_STR) == 0)
                                    return TRIAL_BIND_NOT_SURE;
                                break;
                            default:
                                /* WTF... */
                                return TRIAL_BIND_NOT_SURE;
                        }
                    }
                    else {
                        /* If it's the wrong type of native, there's no way it
                        * can ever bind. */
                        if (((flags & SIG_ELEM_NATIVE_INT_VALUE) != 0 && gotPrim != CallSiteDescriptor.ARG_INT) ||
                            ((flags & SIG_ELEM_NATIVE_NUM_VALUE) != 0 && gotPrim != CallSiteDescriptor.ARG_NUM) ||
                            ((flags & SIG_ELEM_NATIVE_STR_VALUE) != 0 && gotPrim != CallSiteDescriptor.ARG_STR))
                            return TRIAL_BIND_NO_WAY;
                    }
                }
                else {
                    /* Work out a parameter type to consider, and see if it matches. */
                    SixModelObject arg =
                        gotPrim == CallSiteDescriptor.ARG_OBJ ? (SixModelObject)args[curPosArg] :
                        gotPrim == CallSiteDescriptor.ARG_INT ? gcx.Int :
                        gotPrim == CallSiteDescriptor.ARG_NUM ? gcx.Num :
                                                                gcx.Str;
                    SixModelObject nominalType = param.get_attribute_boxed(tc,
                        gcx.Parameter, "$!nominal_type", HINT_nominal_type);
                    if (nominalType != gcx.Mu && Ops.istype(arg, nominalType, tc) == 0) {
                        /* If it failed because we got a junction, may auto-thread;
                         * hand back "not sure" for now. */
                        if (arg.st.WHAT == gcx.Junction)
                            return TRIAL_BIND_NOT_SURE;
                        
                        /* It failed to, but that doesn't mean it can't work at runtime;
                         * we perhaps want an Int, and the most we know is we have an Any,
                         * which would include Int. However, the Int ~~ Str case can be
                         * rejected now, as there's no way it'd ever match. Basically, we
                         * just flip the type check around. */
                        return Ops.istype(nominalType, arg, tc) != 0
                            ? TRIAL_BIND_NOT_SURE
                            : TRIAL_BIND_NO_WAY;
                    }
                }
            }

            /* Continue to next argument. */
            curPosArg++;
        }

        /* If we have any left over arguments, it's a binding fail. */
        if (curPosArg < numPosArgs)
            return TRIAL_BIND_NO_WAY;

        /* Otherwise, if we get there, all is well. */
        return TRIAL_BIND_OK;
    }
}
rakudo-2013.12/src/vm/jvm/runtime/org/perl6/rakudo/RakOps.java0000664000175000017500000010664412231261374023455 0ustar  moritzmoritzpackage org.perl6.rakudo;

import java.util.ArrayList;
import java.util.Arrays;
import java.util.Calendar;
import java.util.Comparator;
import org.perl6.nqp.runtime.*;
import org.perl6.nqp.sixmodel.*;
import org.perl6.nqp.sixmodel.reprs.CallCaptureInstance;
import org.perl6.nqp.sixmodel.reprs.ContextRefInstance;
import org.perl6.nqp.sixmodel.reprs.LexoticInstance;
import org.perl6.nqp.sixmodel.reprs.VMArrayInstance;

/**
 * Contains implementation of nqp:: ops specific to Rakudo Perl 6.
 */
public final class RakOps {
    public static final boolean DEBUG_MODE = false;

    public static class ThreadExt {
        public SixModelObject firstPhaserCodeBlock;
        public ArrayList prePhaserFrames = new ArrayList();
        public ThreadExt(ThreadContext tc) { }
    }

    public static class GlobalExt {
        public SixModelObject Mu;
        public SixModelObject Any;
        public SixModelObject Parcel;
        public SixModelObject Code;
        public SixModelObject Routine;
        public SixModelObject Signature;
        public SixModelObject Parameter;
        public SixModelObject Int;
        public SixModelObject Num;
        public SixModelObject Str;
        public SixModelObject List;
        public SixModelObject ListIter;
        public SixModelObject Array;
        public SixModelObject LoL;
        public SixModelObject Nil;
        public SixModelObject EnumMap;
        public SixModelObject Hash;
        public SixModelObject Junction;
        public SixModelObject Scalar;
        public SixModelObject Capture;
        public SixModelObject ContainerDescriptor;
        public SixModelObject False;
        public SixModelObject True;
        public SixModelObject AutoThreader;
        public SixModelObject EMPTYARR;
        public SixModelObject EMPTYHASH;
        public RakudoJavaInterop rakudoInterop;
        public SixModelObject JavaHOW;
        public SixModelObject defaultContainerDescriptor;
        boolean initialized;

        public GlobalExt(ThreadContext tc) {}
    }

    public static ContextKey key = new ContextKey< >(ThreadExt.class, GlobalExt.class);

    /* Parameter hints for fast lookups. */
    private static final int HINT_PARCEL_STORAGE = 0;
    private static final int HINT_CODE_DO = 0;
    private static final int HINT_CODE_SIG = 1;
    private static final int HINT_ROUTINE_RW = 7;
    private static final int HINT_SIG_PARAMS = 0;
    private static final int HINT_SIG_RETURNS = 1;
    private static final int HINT_SIG_CODE = 4;
    public static final int HINT_CD_OF = 0;
    public static final int HINT_CD_RW = 1;
    public static final int HINT_CD_NAME = 2;
    public static final int HINT_CD_DEFAULT = 3;
    private static final int HINT_LIST_items = 0;
    private static final int HINT_LIST_flattens = 1;
    private static final int HINT_LIST_nextiter = 2;
    private static final int HINT_LISTITER_reified = 0;
    private static final int HINT_LISTITER_nextiter = 1;
    private static final int HINT_LISTITER_rest = 2;
    private static final int HINT_LISTITER_list = 3;
    
    public static SixModelObject p6init(ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        if (!gcx.initialized) {
            tc.gc.contConfigs.put("rakudo_scalar", new RakudoContainerConfigurer());
            SixModelObject BOOTArray = tc.gc.BOOTArray;
            gcx.EMPTYARR = BOOTArray.st.REPR.allocate(tc, BOOTArray.st);
            SixModelObject BOOTHash = tc.gc.BOOTHash;
            gcx.EMPTYHASH = BOOTHash.st.REPR.allocate(tc, BOOTHash.st);
            gcx.rakudoInterop = new RakudoJavaInterop(tc.gc);
            gcx.initialized = true;
        }
        return null;
    }
    
    public static SixModelObject p6settypes(SixModelObject conf, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        gcx.Mu = conf.at_key_boxed(tc, "Mu");
        gcx.Any = conf.at_key_boxed(tc, "Any");
        gcx.Parcel = conf.at_key_boxed(tc, "Parcel");
        gcx.Code = conf.at_key_boxed(tc, "Code");
        gcx.Routine = conf.at_key_boxed(tc, "Routine");
        gcx.Signature = conf.at_key_boxed(tc, "Signature");
        gcx.Parameter = conf.at_key_boxed(tc, "Parameter");
        gcx.Int = conf.at_key_boxed(tc, "Int");
        gcx.Num = conf.at_key_boxed(tc, "Num");
        gcx.Str = conf.at_key_boxed(tc, "Str");
        gcx.List = conf.at_key_boxed(tc, "List");
        gcx.ListIter = conf.at_key_boxed(tc, "ListIter");
        gcx.Array = conf.at_key_boxed(tc, "Array");
        gcx.LoL = conf.at_key_boxed(tc, "LoL");
        gcx.Nil = conf.at_key_boxed(tc, "Nil");
        gcx.EnumMap = conf.at_key_boxed(tc, "EnumMap");
        gcx.Hash = conf.at_key_boxed(tc, "Hash");
        gcx.Junction = conf.at_key_boxed(tc, "Junction");
        gcx.Scalar = conf.at_key_boxed(tc, "Scalar");
        gcx.Capture = conf.at_key_boxed(tc, "Capture");
        gcx.ContainerDescriptor = conf.at_key_boxed(tc, "ContainerDescriptor");
        gcx.False = conf.at_key_boxed(tc, "False");
        gcx.True = conf.at_key_boxed(tc, "True");
        gcx.JavaHOW = conf.at_key_boxed(tc, "Metamodel").st.WHO.at_key_boxed(tc, "JavaHOW");
        
        SixModelObject defCD = gcx.ContainerDescriptor.st.REPR.allocate(tc,
            gcx.ContainerDescriptor.st);
        defCD.bind_attribute_boxed(tc, gcx.ContainerDescriptor,
            "$!of", HINT_CD_OF, gcx.Mu);
        tc.native_s = "";
        defCD.bind_attribute_native(tc, gcx.ContainerDescriptor,
            "$!name", HINT_CD_NAME);
        tc.native_i = 1;
        defCD.bind_attribute_native(tc, gcx.ContainerDescriptor,
            "$!rw", HINT_CD_RW);
        defCD.bind_attribute_boxed(tc, gcx.ContainerDescriptor,
            "$!default", HINT_CD_DEFAULT, gcx.Any);
        gcx.defaultContainerDescriptor = defCD;
        
        return conf;
    }
    
    public static SixModelObject p6setautothreader(SixModelObject autoThreader, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        gcx.AutoThreader = autoThreader;
        return autoThreader;
    }
    
    public static SixModelObject booleanize(int x, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        return x == 0 ? gcx.False : gcx.True;
    }
    
    public static SixModelObject p6definite(SixModelObject obj, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        obj = Ops.decont(obj, tc);
        return obj instanceof TypeObject ? gcx.False : gcx.True;
    }
    
    public static SixModelObject p6box_i(long value, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject res = gcx.Int.st.REPR.allocate(tc, gcx.Int.st);
        res.set_int(tc, value);
        return res;
    }
    
    public static SixModelObject p6box_n(double value, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject res = gcx.Num.st.REPR.allocate(tc, gcx.Num.st);
        res.set_num(tc, value);
        return res;
    }
    
    public static SixModelObject p6box_s(String value, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject res = gcx.Str.st.REPR.allocate(tc, gcx.Str.st);
        res.set_str(tc, value);
        return res;
    }
    
    public static SixModelObject p6list(SixModelObject arr, SixModelObject type, SixModelObject flattens, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject list = type.st.REPR.allocate(tc, type.st);
        if (arr != null) 
            list.bind_attribute_boxed(tc, gcx.List, "$!nextiter", HINT_LIST_nextiter,
                p6listiter(arr, list, tc));
        list.bind_attribute_boxed(tc, gcx.List, "$!flattens", HINT_LIST_flattens, flattens);
        return list;
    }
    
    public static SixModelObject p6listitems(SixModelObject list, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject items = list.get_attribute_boxed(tc, gcx.List, "$!items", HINT_LIST_items);
        if (!(items instanceof VMArrayInstance)) {
            items = gcx.EMPTYARR.clone(tc);
            list.bind_attribute_boxed(tc, gcx.List, "$!items", HINT_LIST_items, items);
        }
        return items;
    }
    
    public static long p6arrfindtypes(SixModelObject arr, SixModelObject types, long start, long last, ThreadContext tc) {
        int ntypes = (int)types.elems(tc);
        SixModelObject[] typeArr = new SixModelObject[ntypes];
        for (int i = 0; i < ntypes; i++)
            typeArr[i] = types.at_pos_boxed(tc, i);

        long elems = arr.elems(tc);
        if (elems < last)
            last = elems;

        long index;
        for (index = start; index < last; index++) {
            SixModelObject val = arr.at_pos_boxed(tc, index);
            if (val.st.ContainerSpec == null) {
                boolean found = false;
                for (int typeIndex = 0; typeIndex < ntypes; typeIndex++) {
                    if (Ops.istype(val, typeArr[typeIndex], tc) != 0) {
                        found = true;
                        break;
                    }
                }
                if (found)
                    break;
            }
        }

        return index;
    }
    
    public static SixModelObject p6shiftpush(SixModelObject a, SixModelObject b, long total, ThreadContext tc) {
        long count = total;
        long elems = b.elems(tc);
        if (count > elems)
            count = elems;

        if (a != null && total > 0) {
            long getPos = 0;
            long setPos = a.elems(tc);
            a.set_elems(tc, setPos + count);
            while (count > 0) {
                a.bind_pos_boxed(tc, setPos, b.at_pos_boxed(tc, getPos));
                count--;
                getPos++;
                setPos++;
            }
        }
        if (total > 0) {
            GlobalExt gcx = key.getGC(tc);
            b.splice(tc, gcx.EMPTYARR, 0, total);
        }
        
        return a;
    }
    
    public static SixModelObject p6listiter(SixModelObject arr, SixModelObject list, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject iter = gcx.ListIter.st.REPR.allocate(tc, gcx.ListIter.st);
        iter.bind_attribute_boxed(tc, gcx.ListIter, "$!rest", HINT_LISTITER_rest, arr);
        iter.bind_attribute_boxed(tc, gcx.ListIter, "$!list", HINT_LISTITER_list, list);
        return iter;
    }
    
    public static SixModelObject p6argvmarray(ThreadContext tc, CallSiteDescriptor csd, Object[] args) {
        SixModelObject BOOTArray = tc.gc.BOOTArray;
        SixModelObject res = BOOTArray.st.REPR.allocate(tc, BOOTArray.st);
        for (int i = 0; i < csd.numPositionals; i++) {
            SixModelObject toBind;
            switch (csd.argFlags[i]) {
                case CallSiteDescriptor.ARG_INT:
                    toBind = p6box_i((long)args[i], tc);
                    break;
                case CallSiteDescriptor.ARG_NUM:
                    toBind = p6box_n((double)args[i], tc);
                    break;
                case CallSiteDescriptor.ARG_STR:
                    toBind = p6box_s((String)args[i], tc);
                    break;
                default:
                    toBind = Ops.hllize((SixModelObject)args[i], tc);
                    break;
            }
            res.bind_pos_boxed(tc, i, toBind);
        }
        return res;
    }
    
    public static CallSiteDescriptor p6bindsig(ThreadContext tc, CallSiteDescriptor csd, Object[] args) {
        /* Do any flattening before processing begins. */
        CallFrame cf = tc.curFrame;
        if (csd.hasFlattening) {
            csd = csd.explodeFlattening(cf, args);
            args = tc.flatArgs;
        }
        cf.csd = csd;
        cf.args = args;

        /* Look up parameters to bind. */
        if (DEBUG_MODE) {
            if (cf.codeRef.name != null)
                System.err.println("Binding for " + cf.codeRef.name);
        }
        GlobalExt gcx = key.getGC(tc);
        SixModelObject sig = cf.codeRef.codeObject
            .get_attribute_boxed(tc, gcx.Code, "$!signature", HINT_CODE_SIG);
        SixModelObject params = sig
            .get_attribute_boxed(tc, gcx.Signature, "$!params", HINT_SIG_PARAMS);
        
        /* Run binder, and handle any errors. */
        String[] error = new String[1];
        switch (Binder.bind(tc, gcx, cf, params, csd, args, false, error)) {
            case Binder.BIND_RESULT_FAIL:
                throw ExceptionHandling.dieInternal(tc, error[0]);
            case Binder.BIND_RESULT_JUNCTION:
                /* Invoke the auto-threader. */
                csd = csd.injectInvokee(tc, args, cf.codeRef.codeObject);
                args = tc.flatArgs;
                Ops.invokeDirect(tc, gcx.AutoThreader, csd, args);
                Ops.return_o(
                    Ops.result_o(cf), cf);
                
                /* Return null to indicate immediate return to the routine. */
                return null;
        }

        /* The binder may, for a variety of reasons, wind up calling Perl 6 code and overwriting flatArgs, so it needs to be set at the end to return reliably */
        tc.flatArgs = args;
        return csd;
    }
    
    public static SixModelObject p6bindcaptosig(SixModelObject sig, SixModelObject cap, ThreadContext tc) {
        CallFrame cf = tc.curFrame;
        
        GlobalExt gcx = key.getGC(tc);
        CallSiteDescriptor csd = Binder.explodeCapture(tc, gcx, cap);
        SixModelObject params = sig.get_attribute_boxed(tc, gcx.Signature,
            "$!params", HINT_SIG_PARAMS);
        
        String[] error = new String[1];
        switch (Binder.bind(tc, gcx, cf, params, csd, tc.flatArgs, false, error)) {
            case Binder.BIND_RESULT_FAIL:
            case Binder.BIND_RESULT_JUNCTION:
                throw ExceptionHandling.dieInternal(tc, error[0]);
            default:
                return sig;
        }        
    }
    
    public static long p6isbindable(SixModelObject sig, SixModelObject cap, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        
        CallSiteDescriptor csd;
        Object[] args;
        if (cap instanceof CallCaptureInstance) {
            CallCaptureInstance cc = (CallCaptureInstance)cap;
            csd = cc.descriptor;
            args = cc.args;
        } else {
            csd = Binder.explodeCapture(tc, gcx, cap);
            args = tc.flatArgs;
        }
        
        SixModelObject params = sig.get_attribute_boxed(tc, gcx.Signature,
            "$!params", HINT_SIG_PARAMS);
        SixModelObject codeObj = sig.get_attribute_boxed(tc, gcx.Signature,
            "$!code", HINT_SIG_CODE);
        CodeRef cr = (CodeRef)codeObj.get_attribute_boxed(tc, gcx.Code,
            "$!do", HINT_CODE_DO);

        CallFrame cf = new CallFrame(tc, cr);
        try {
            switch (Binder.bind(tc, gcx, cf, params, csd, args, false, null)) {
                case Binder.BIND_RESULT_FAIL:
                    return 0;
                default:
                    return 1;
            }
        }
        finally {
            tc.curFrame = tc.curFrame.caller;
        }
    }
    
    public static long p6trialbind(SixModelObject sig, SixModelObject values, SixModelObject flags, ThreadContext tc) {
        /* Get signature and parameters. */
        GlobalExt gcx = key.getGC(tc);
        SixModelObject params = sig.get_attribute_boxed(tc, gcx.Signature, "$!params", HINT_SIG_PARAMS);

        /* Form argument array and call site descriptor. */
        int numArgs = (int)values.elems(tc);
        Object[] args = new Object[numArgs];
        byte[] argFlags = new byte[numArgs];
        for (int i = 0; i < numArgs; i++) {
            switch ((int)flags.at_pos_boxed(tc, i).get_int(tc)) {
                case CallSiteDescriptor.ARG_INT:
                    args[i] = 0;
                    argFlags[i] = CallSiteDescriptor.ARG_INT;
                    break;
                case CallSiteDescriptor.ARG_NUM:
                    args[i] = 0.0;
                    argFlags[i] = CallSiteDescriptor.ARG_NUM;
                    break;
                case CallSiteDescriptor.ARG_STR:
                    args[i] = "";
                    argFlags[i] = CallSiteDescriptor.ARG_STR;
                    break;
                default:
                    args[i] = values.at_pos_boxed(tc, i);
                    argFlags[i] = CallSiteDescriptor.ARG_OBJ;
                    break;
            }
        }

        /* Do trial bind. */
        return Binder.trialBind(tc, gcx, params, new CallSiteDescriptor(argFlags, null), args);
    }
    
    public static SixModelObject p6parcel(SixModelObject array, SixModelObject fill, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject parcel = gcx.Parcel.st.REPR.allocate(tc, gcx.Parcel.st);
        parcel.bind_attribute_boxed(tc, gcx.Parcel, "$!storage", HINT_PARCEL_STORAGE, array);

        if (fill != null) {
            long elems = array.elems(tc);
            for (long i = 0; i < elems; i++) {
                if (array.at_pos_boxed(tc, i) == null)
                    array.bind_pos_boxed(tc, i, fill);
            }
        }

        return parcel;
    }
    
    private static final CallSiteDescriptor STORE = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    private static final CallSiteDescriptor storeThrower = new CallSiteDescriptor(
        new byte[] { }, null);
    public static SixModelObject p6store(SixModelObject cont, SixModelObject value, ThreadContext tc) {
        ContainerSpec spec = cont.st.ContainerSpec;
        if (spec != null) {
            spec.store(tc, cont, Ops.decont(value, tc));
        }
        else {
            SixModelObject meth = Ops.findmethod(cont, "STORE", tc);
            if (meth != null) {
                Ops.invokeDirect(tc, meth,
                    STORE, new Object[] { cont, value });
            }
            else {
                SixModelObject thrower = getThrower(tc, "X::Assignment::RO");
                if (thrower == null)
                    ExceptionHandling.dieInternal(tc, "Cannot assign to a non-container");
                else
                    Ops.invokeDirect(tc, thrower,
                        storeThrower, new Object[] { });
            }
        }
        return cont;
    }
    
    public static SixModelObject p6decontrv(SixModelObject routine, SixModelObject cont, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        if (cont != null && isRWScalar(tc, gcx, cont)) {
            routine.get_attribute_native(tc, gcx.Routine, "$!rw", HINT_ROUTINE_RW);
            if (tc.native_i == 0) {
                /* Recontainerize to RO. */
                SixModelObject roCont = gcx.Scalar.st.REPR.allocate(tc, gcx.Scalar.st);
                roCont.bind_attribute_boxed(tc, gcx.Scalar, "$!value",
                    RakudoContainerSpec.HINT_value,
                    cont.st.ContainerSpec.fetch(tc, cont));
                return roCont;
            }
        }
        return cont;
    }
    
    public static SixModelObject p6scalarfromdesc(SixModelObject desc, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);

        if (desc == null || desc instanceof TypeObject)
            desc = gcx.defaultContainerDescriptor;
        SixModelObject defVal = desc.get_attribute_boxed(tc, gcx.ContainerDescriptor,
            "$!default", HINT_CD_DEFAULT);

        SixModelObject cont = gcx.Scalar.st.REPR.allocate(tc, gcx.Scalar.st);
        cont.bind_attribute_boxed(tc, gcx.Scalar, "$!descriptor",
            RakudoContainerSpec.HINT_descriptor, desc);
        cont.bind_attribute_boxed(tc, gcx.Scalar, "$!value", RakudoContainerSpec.HINT_value,
            defVal);

        return cont;
    }
    
    public static SixModelObject p6recont_ro(SixModelObject cont, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        if (isRWScalar(tc, gcx, cont)) {
            SixModelObject roCont = gcx.Scalar.st.REPR.allocate(tc, gcx.Scalar.st);
            roCont.bind_attribute_boxed(tc, gcx.Scalar, "$!value",
                RakudoContainerSpec.HINT_value,
                cont.st.ContainerSpec.fetch(tc, cont));
            return roCont;
        }
        return cont;
    }
    
    private static boolean isRWScalar(ThreadContext tc, GlobalExt gcx, SixModelObject check) {
        if (!(check instanceof TypeObject) && check.st.WHAT == gcx.Scalar) {
            SixModelObject desc = check.get_attribute_boxed(tc, gcx.Scalar, "$!descriptor",
                RakudoContainerSpec.HINT_descriptor);
            if (desc == null)
                return false;
            desc.get_attribute_native(tc, gcx.ContainerDescriptor, "$!rw", HINT_CD_RW);
            return tc.native_i != 0;
        }
        return false;
    }
    
    public static SixModelObject p6var(SixModelObject cont, ThreadContext tc) {
        if (cont != null && cont.st.ContainerSpec != null) {
            GlobalExt gcx = key.getGC(tc);
            SixModelObject wrapper = gcx.Scalar.st.REPR.allocate(tc, gcx.Scalar.st);
            wrapper.bind_attribute_boxed(tc, gcx.Scalar, "$!value",
                RakudoContainerSpec.HINT_value,
                cont);
            return wrapper;
        }
        else {
            return cont;
        }
    }

    public static SixModelObject p6reprname(SixModelObject obj, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        obj = Ops.decont(obj, tc);
        SixModelObject name = gcx.Str.st.REPR.allocate(tc, gcx.Str.st);
        name.set_str(tc, obj.st.REPR.name);
        return name;
    }
    
    private static final CallSiteDescriptor rvThrower = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    public static SixModelObject p6typecheckrv(SixModelObject rv, SixModelObject routine, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        SixModelObject sig = routine.get_attribute_boxed(tc, gcx.Code, "$!signature", HINT_CODE_SIG);
        SixModelObject rtype = sig.get_attribute_boxed(tc, gcx.Signature, "$!returns", HINT_SIG_RETURNS);
        if (rtype != null) {
            SixModelObject decontValue = Ops.decont(rv, tc);
            if (Ops.istype(decontValue, rtype, tc) == 0) {
                /* Straight type check failed, but it's possible we're returning
                 * an Int that can unbox into an int or similar. */
                StorageSpec spec = rtype.st.REPR.get_storage_spec(tc, rtype.st);
                if (spec.inlineable == 0 || Ops.istype(rtype, decontValue.st.WHAT, tc) == 0) {
                    SixModelObject thrower = getThrower(tc, "X::TypeCheck::Return");
                    if (thrower == null)
                        throw ExceptionHandling.dieInternal(tc,
                            "Type check failed for return value");
                    else
                        Ops.invokeDirect(tc, thrower,
                            rvThrower, new Object[] { decontValue, rtype });
                }
            }
        }
        return rv;
    }
    
    private static final CallSiteDescriptor baThrower = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    public static SixModelObject p6bindassert(SixModelObject value, SixModelObject type, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        if (type != gcx.Mu) {
            SixModelObject decont = Ops.decont(value, tc);
            if (Ops.istype(decont, type, tc) == 0) {
                SixModelObject thrower = getThrower(tc, "X::TypeCheck::Binding");
                if (thrower == null)
                    ExceptionHandling.dieInternal(tc,
                        "Type check failed in binding");
                else
                    Ops.invokeDirect(tc, thrower,
                        baThrower, new Object[] { value, type });
            }
        }
        return value;
    }
    
    public static SixModelObject p6capturelex(SixModelObject codeObj, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        CodeRef closure = (CodeRef)codeObj.get_attribute_boxed(tc,
                gcx.Code, "$!do", HINT_CODE_DO);
        StaticCodeInfo wantedStaticInfo = closure.staticInfo.outerStaticInfo;
        if (tc.curFrame.codeRef.staticInfo == wantedStaticInfo)
            closure.outer = tc.curFrame;
        else if (tc.curFrame.outer.codeRef.staticInfo == wantedStaticInfo)
            closure.outer = tc.curFrame.outer;
        return codeObj;
    }
    
    public static SixModelObject p6getouterctx(SixModelObject codeObj, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        codeObj = Ops.decont(codeObj, tc);
        CodeRef closure = (CodeRef)codeObj.get_attribute_boxed(tc,
                gcx.Code, "$!do", HINT_CODE_DO);
        SixModelObject ContextRef = tc.gc.ContextRef;
        SixModelObject wrap = ContextRef.st.REPR.allocate(tc, ContextRef.st);
        ((ContextRefInstance)wrap).context = closure.outer;
        return wrap;
    }
    
    public static SixModelObject p6captureouters(SixModelObject capList, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        CallFrame cf = tc.curFrame;
        long elems = capList.elems(tc);
        for (long i = 0; i < elems; i++) {
            SixModelObject codeObj = capList.at_pos_boxed(tc, i);
            CodeRef closure = (CodeRef)codeObj.get_attribute_boxed(tc,
                gcx.Code, "$!do", HINT_CODE_DO);
            CallFrame ctxToDiddle = closure.outer;
            ctxToDiddle.outer = tc.curFrame;
        }
        return capList;
    }
    
    public static SixModelObject p6bindattrinvres(SixModelObject obj, SixModelObject ch, String name, SixModelObject value, ThreadContext tc) {
        obj.bind_attribute_boxed(tc, Ops.decont(ch, tc),
            name, STable.NO_HINT, value);
        if (obj.sc != null)
            Ops.scwbObject(tc, obj);
        return obj;
    }
    
    public static SixModelObject getThrower(ThreadContext tc, String type) {
        SixModelObject exHash = Ops.gethllsym("perl6", "P6EX", tc);
        return exHash == null ? null : Ops.atkey(exHash, type, tc);
    }

    private static CallFrame find_common_ctx(CallFrame ctx1, CallFrame ctx2) {
        int depth1 = 0;
        int depth2 = 0;
        CallFrame ctx;

        for (ctx = ctx1; ctx != null; ctx = ctx.caller, depth1++)
            if (ctx == ctx2)
                return ctx;
        for (ctx = ctx2; ctx != null; ctx = ctx.caller, depth2++)
            if (ctx == ctx1)
                return ctx;
        for (; depth1 > depth2; depth2++)
            ctx1 = ctx1.caller;
        for (; depth2 > depth1; depth1++)
            ctx2 = ctx2.caller;
        while (ctx1 != ctx2) {
            ctx1 = ctx1.caller;
            ctx2 = ctx2.caller;
        }
        return ctx1;
    }

    private static SixModelObject getremotelex(CallFrame pad, String name) { /* use for sub_find_pad */
        CallFrame curFrame = pad;
        while (curFrame != null) {
            Integer found = curFrame.codeRef.staticInfo.oTryGetLexicalIdx(name);
            if (found != null)
                return curFrame.oLex[found];
            curFrame = curFrame.outer;
        }
        return null;
    }

    public static SixModelObject p6routinereturn(SixModelObject in, ThreadContext tc) {
        CallFrame ctx = tc.curFrame;
        SixModelObject cont = null;

        for (ctx = ctx.caller; ctx != null; ctx = ctx.caller) {
            cont = getremotelex(ctx, "RETURN");
            if (cont != null) break;
        }

        if (!(cont instanceof LexoticInstance)) {
            SixModelObject thrower = getThrower(tc, "X::ControlFlow::Return");
            if (thrower == null)
                ExceptionHandling.dieInternal(tc, "Attempt to return outside of any Routine");
            else
                Ops.invokeArgless(tc, thrower);
        }

        // rewinding is handled by finally blocks in the generated subs
        LexoticException throwee = tc.theLexotic;
        throwee.target = ((LexoticInstance)cont).target;
        throwee.payload = in;
        throw throwee;
    }
    
    public static String tclc(String in, ThreadContext tc) {
        if (in.length() == 0)
            return in;
        int first = in.codePointAt(0);
        return new String(Character.toChars(Character.toTitleCase(first)))
            + in.substring(Character.charCount(first)).toLowerCase();
    }
    
    private static final CallSiteDescriptor SortCSD = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    public static SixModelObject p6sort(SixModelObject indices, final SixModelObject comparator, final ThreadContext tc) {
        int elems = (int)indices.elems(tc);
        SixModelObject[] sortable = new SixModelObject[elems];
        for (int i = 0; i < elems; i++)
            sortable[i] = indices.at_pos_boxed(tc, i);
        Arrays.sort(sortable, new Comparator() {
            public int compare(SixModelObject a, SixModelObject b) {
                Ops.invokeDirect(tc, comparator, SortCSD,
                    new Object[] { a, b });
                return (int)Ops.result_i(tc.curFrame);
            }
        });
        for (int i = 0; i < elems; i++)
            indices.bind_pos_boxed(tc, i, sortable[i]);
        return indices;
    }
    
    public static long p6stateinit(ThreadContext tc) {
        return tc.curFrame.stateInit ? 1 : 0;
    }
    
    public static SixModelObject p6setfirstflag(SixModelObject codeObj, ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        ThreadExt tcx = key.getTC(tc);
        tcx.firstPhaserCodeBlock = codeObj.get_attribute_boxed(tc,
            gcx.Code, "$!do", HINT_CODE_DO);
        return codeObj;
    }
    
    public static long p6takefirstflag(ThreadContext tc) {
        ThreadExt tcx = key.getTC(tc);
        boolean matches = tcx.firstPhaserCodeBlock == tc.curFrame.codeRef;
        tcx.firstPhaserCodeBlock = null;
        return matches ? 1 : 0;
    }
    
    public static SixModelObject p6setpre(ThreadContext tc) {
        ThreadExt tcx = key.getTC(tc);
        tcx.prePhaserFrames.add(tc.curFrame);
        return null;
    }
    
    public static SixModelObject p6clearpre(ThreadContext tc) {
        ThreadExt tcx = key.getTC(tc);
        tcx.prePhaserFrames.remove(tc.curFrame);
        return null;
    }
    
    public static long p6inpre(ThreadContext tc) {
        ThreadExt tcx = key.getTC(tc);
        return tcx.prePhaserFrames.remove(tc.curFrame.caller) ? 1 : 0;
    }
    
    private static final CallSiteDescriptor dispVivifier = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ,
                     CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    private static final CallSiteDescriptor dispThrower = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_STR }, null);
    public static SixModelObject p6finddispatcher(String usage, ThreadContext tc) {
        SixModelObject dispatcher = null;
        
        CallFrame ctx = tc.curFrame;
        while (ctx != null) {
            /* Do we have a dispatcher here? */
            StaticCodeInfo sci = ctx.codeRef.staticInfo;
            Integer dispLexIdx = sci.oTryGetLexicalIdx("$*DISPATCHER");
            if (dispLexIdx != null) {
                SixModelObject maybeDispatcher = ctx.oLex[dispLexIdx];
                if (maybeDispatcher != null) {
                    dispatcher = maybeDispatcher;
                    if (dispatcher instanceof TypeObject) {
                        /* Need to vivify it. */
                        SixModelObject meth = Ops.findmethod(dispatcher, "vivify_for", tc);
                        SixModelObject p6sub = ctx.codeRef.codeObject;
                        
                        SixModelObject ContextRef = tc.gc.ContextRef;
                        SixModelObject wrap = ContextRef.st.REPR.allocate(tc, ContextRef.st);
                        ((ContextRefInstance)wrap).context = ctx;
                        
                        SixModelObject CallCapture = tc.gc.CallCapture;
                        CallCaptureInstance cc = (CallCaptureInstance)CallCapture.st.REPR.allocate(tc, CallCapture.st);
                        cc.descriptor = ctx.csd;
                        cc.args = ctx.args;
                        
                        Ops.invokeDirect(tc, meth,
                            dispVivifier, new Object[] { dispatcher, p6sub, wrap, cc });
                        dispatcher = Ops.result_o(tc.curFrame);
                        ctx.oLex[dispLexIdx] = dispatcher;
                    }
                    break;
                }
            }

            /* Follow dynamic chain. */
            ctx = ctx.caller;
        }
        
        if (dispatcher == null) {
            SixModelObject thrower = getThrower(tc, "X::NoDispatcher");
            if (thrower == null) {
                ExceptionHandling.dieInternal(tc,
                    usage + " is not in the dynamic scope of a dispatcher");
            } else {
                Ops.invokeDirect(tc, thrower,
                    dispThrower, new Object[] { usage });
            }
        }
        
        return dispatcher;
    }
    
    public static SixModelObject p6argsfordispatcher(SixModelObject disp, ThreadContext tc) {
        SixModelObject result = null;
        
        CallFrame ctx = tc.curFrame;
        while (ctx != null) {
            /* Do we have the dispatcher we're looking for? */
            StaticCodeInfo sci = ctx.codeRef.staticInfo;
            Integer dispLexIdx = sci.oTryGetLexicalIdx("$*DISPATCHER");
            if (dispLexIdx != null) {
                SixModelObject maybeDispatcher = ctx.oLex[dispLexIdx];
                if (maybeDispatcher == disp) {
                    /* Found; grab args. */
                    SixModelObject CallCapture = tc.gc.CallCapture;
                    CallCaptureInstance cc = (CallCaptureInstance)CallCapture.st.REPR.allocate(tc, CallCapture.st);
                    cc.descriptor = ctx.csd;
                    cc.args = ctx.args;
                    result = cc;
                    break;
                }
            }

            /* Follow dynamic chain. */
            ctx = ctx.caller;
        }
        
        if (result == null)
            throw ExceptionHandling.dieInternal(tc,
                "Could not find arguments for dispatcher");
        return result;
    }
    
    public static SixModelObject p6decodelocaltime(long sinceEpoch, ThreadContext tc) {
        // Get calendar for current local host's timezone.
        Calendar c = Calendar.getInstance();
        c.setTimeInMillis(sinceEpoch * 1000);
        
        // Populate result int array.
        SixModelObject BOOTIntArray = tc.gc.BOOTIntArray;
        SixModelObject result = BOOTIntArray.st.REPR.allocate(tc, BOOTIntArray.st);
        tc.native_i = c.get(Calendar.SECOND);
        result.bind_pos_native(tc, 0);
        tc.native_i = c.get(Calendar.MINUTE);
        result.bind_pos_native(tc, 1);
        tc.native_i = c.get(Calendar.HOUR_OF_DAY);
        result.bind_pos_native(tc, 2);
        tc.native_i = c.get(Calendar.DAY_OF_MONTH);
        result.bind_pos_native(tc, 3);
        tc.native_i = c.get(Calendar.MONTH) + 1;
        result.bind_pos_native(tc, 4);
        tc.native_i = c.get(Calendar.YEAR);
        result.bind_pos_native(tc, 5);
        
        return result;
    }
    
    public static SixModelObject p6staticouter(SixModelObject code, ThreadContext tc) {
        if (code instanceof CodeRef)
            return ((CodeRef)code).staticInfo.outerStaticInfo.staticCode;
        else
            throw ExceptionHandling.dieInternal(tc, "p6staticouter must be used on a CodeRef");
    }

    public static SixModelObject jvmrakudointerop(ThreadContext tc) {
        GlobalExt gcx = key.getGC(tc);
        return BootJavaInterop.RuntimeSupport.boxJava(gcx.rakudoInterop, gcx.rakudoInterop.getSTableForClass(RakudoJavaInterop.class));
    }
}
rakudo-2013.12/src/vm/jvm/runtime/org/perl6/rakudo/RakudoContainerConfigurer.java0000664000175000017500000000110512224263172027354 0ustar  moritzmoritzpackage org.perl6.rakudo;

import org.perl6.nqp.runtime.ThreadContext;
import org.perl6.nqp.sixmodel.*;

public class RakudoContainerConfigurer extends ContainerConfigurer {
    /* Sets this container spec in place for the specified STable. */ 
    public void setContainerSpec(ThreadContext tc, STable st) {
        st.ContainerSpec = new RakudoContainerSpec();
    }
    
    /* Configures the container spec with the specified info. */
    public void configureContainerSpec(ThreadContext tc, STable st, SixModelObject config) {
        /* Nothing to configure here. */
    }
}
rakudo-2013.12/src/vm/jvm/runtime/org/perl6/rakudo/RakudoContainerSpec.java0000664000175000017500000000761112224263172026153 0ustar  moritzmoritzpackage org.perl6.rakudo;

import org.perl6.nqp.runtime.*;
import org.perl6.nqp.sixmodel.*;

public class RakudoContainerSpec extends ContainerSpec {
    /* Container related hints. */
    public static final int HINT_descriptor = 0;
    public static final int HINT_value = 1;
    public static final int HINT_whence = 2;
    
    /* Callsite descriptor for WHENCEs. */
    private static final CallSiteDescriptor WHENCE = new CallSiteDescriptor(
        new byte[] { }, null);
    
    /* Fetches a value out of a container. Used for decontainerization. */
    public SixModelObject fetch(ThreadContext tc, SixModelObject cont) {
        return cont.get_attribute_boxed(tc, RakOps.key.getGC(tc).Scalar, "$!value", HINT_value);
    }
    
    /* Stores a value in a container. Used for assignment. */
    private static final CallSiteDescriptor storeThrower = new CallSiteDescriptor(
        new byte[] { CallSiteDescriptor.ARG_STR, CallSiteDescriptor.ARG_OBJ, CallSiteDescriptor.ARG_OBJ }, null);
    public void store(ThreadContext tc, SixModelObject cont, SixModelObject value) {
        RakOps.GlobalExt gcx = RakOps.key.getGC(tc);

        long rw = 0;
        SixModelObject desc = cont.get_attribute_boxed(tc, gcx.Scalar,
            "$!descriptor", HINT_descriptor);
        if (desc != null) {
            desc.get_attribute_native(tc, gcx.ContainerDescriptor, "$!rw", RakOps.HINT_CD_RW);
            rw = tc.native_i;
        }
        if (rw == 0)
            throw ExceptionHandling.dieInternal(tc,
                "Cannot assign to a readonly variable or a value");

        if (value.st.WHAT == gcx.Nil) {
            value = desc.get_attribute_boxed(tc,
                gcx.ContainerDescriptor, "$!default", RakOps.HINT_CD_DEFAULT);
        }
        else {
            SixModelObject of = desc.get_attribute_boxed(tc,
                gcx.ContainerDescriptor, "$!of", RakOps.HINT_CD_OF);
            long ok = Ops.istype(value, of, tc);
            if (ok == 0) {
                desc.get_attribute_native(tc, gcx.ContainerDescriptor, "$!name", RakOps.HINT_CD_NAME);
                String name = tc.native_s;
                SixModelObject thrower = RakOps.getThrower(tc, "X::TypeCheck::Assignment");
                if (thrower == null)
                    throw ExceptionHandling.dieInternal(tc,
                        "Type check failed in assignment to '" + name + "'");
                else
                    Ops.invokeDirect(tc, thrower,
                        storeThrower, new Object[] { name, value, of });
            }
        }

        SixModelObject whence = cont.get_attribute_boxed(tc, gcx.Scalar, "$!whence", HINT_whence);
        if (whence != null)
            Ops.invokeDirect(tc, whence,
                WHENCE, new Object[] { });
        
        cont.bind_attribute_boxed(tc, gcx.Scalar, "$!value", HINT_value, value);
    }
    
    /* Stores a value in a container, without any checking of it (this
     * assumes an optimizer or something else already did it). Used for
     * assignment. */
    public void storeUnchecked(ThreadContext tc, SixModelObject cont, SixModelObject obj) {
        SixModelObject Scalar = RakOps.key.getGC(tc).Scalar;
        SixModelObject whence = cont.get_attribute_boxed(tc, Scalar, "$!whence", HINT_whence);
        if (whence != null)
            Ops.invokeDirect(tc, whence,
                WHENCE, new Object[] { });
        
        cont.bind_attribute_boxed(tc, Scalar, "$!value", HINT_value, obj);
    }
    
    /* Name of this container specification. */
    public String name() {
        return "rakudo_scalar";
    }
    
    /* Serializes the container data, if any. */
    public void serialize(ThreadContext tc, STable st, SerializationWriter writer) {
        /* No data to serialize. */
    }
    
    /* Deserializes the container data, if any. */
    public void deserialize(ThreadContext tc, STable st, SerializationReader reader) {
        /* No data to deserialize. */
    }
}
rakudo-2013.12/src/vm/jvm/runtime/org/perl6/rakudo/RakudoJavaInterop.java0000664000175000017500000000116112224263172025632 0ustar  moritzmoritzpackage org.perl6.rakudo;

import org.perl6.nqp.runtime.*;
import org.perl6.nqp.sixmodel.STable;
import org.perl6.nqp.sixmodel.SixModelObject;

public class RakudoJavaInterop extends BootJavaInterop {
    public RakudoJavaInterop(GlobalContext gc) {
        super(gc);
    }
    
    protected SixModelObject computeHOW(ThreadContext tc, String name) {
        RakOps.GlobalExt gcx = RakOps.key.getGC(tc);
        SixModelObject mo = gcx.JavaHOW.st.REPR.allocate(tc, gcx.JavaHOW.st);
        mo.bind_attribute_boxed(tc, gcx.JavaHOW, "$!name", STable.NO_HINT,
            RakOps.p6box_s(name, tc));
        return mo;
    }
}
rakudo-2013.12/src/vm/parrot/guts/bind.c0000664000175000017500000015003012224263172017365 0ustar  moritzmoritz/*
$Id$
Copyright (C) 2009-2013, The Perl Foundation.
*/

#define PARROT_IN_EXTENSION
#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "pmc_callcontext.h"
#include "bind.h"
#include "container.h"
#include "types.h"
#include "sixmodelobject.h"

/* Cache of Parrot type IDs and some strings. */
static INTVAL smo_id            = 0;
static INTVAL qrpa_id           = 0;
static STRING *ACCEPTS          = NULL;
static STRING *HOW              = NULL;
static STRING *DO_str           = NULL;
static STRING *SELF_str         = NULL;
static STRING *NAME_str         = NULL;
static STRING *BLOCK_str        = NULL;
static STRING *CAPTURE_str      = NULL;
static STRING *STORAGE_str      = NULL;
static STRING *REST_str         = NULL;
static STRING *LIST_str         = NULL;
static STRING *HASH_str         = NULL;
static STRING *FLATTENS_str     = NULL;
static STRING *NEXTITER_str     = NULL;
static STRING *HASH_SIGIL_str   = NULL;
static STRING *ARRAY_SIGIL_str  = NULL;
static STRING *BANG_TWIGIL_str  = NULL;
static STRING *SCALAR_SIGIL_str = NULL;
static STRING *NAMED_str        = NULL;
static STRING *INSTANTIATE_GENERIC_str = NULL;

/* Initializes our cached versions of some strings and type IDs that we
 * use very commonly. For strings, this should mean we only compute their
 * hash value once, rather than every time we create and consume them. */
static void setup_binder_statics(PARROT_INTERP) {
    ACCEPTS          = Parrot_str_new_constant(interp, "ACCEPTS");
    HOW              = Parrot_str_new_constant(interp, "HOW");
    DO_str           = Parrot_str_new_constant(interp, "$!do");
    NAME_str         = Parrot_str_new_constant(interp, "name");
    SELF_str         = Parrot_str_new_constant(interp, "self");
    BLOCK_str        = Parrot_str_new_constant(interp, "Block");
    CAPTURE_str      = Parrot_str_new_constant(interp, "Capture");
    STORAGE_str      = Parrot_str_new_constant(interp, "$!storage");
    REST_str         = Parrot_str_new_constant(interp, "$!rest");
    LIST_str         = Parrot_str_new_constant(interp, "$!list");
    HASH_str         = Parrot_str_new_constant(interp, "$!hash");
    FLATTENS_str     = Parrot_str_new_constant(interp, "$!flattens");
    NEXTITER_str     = Parrot_str_new_constant(interp, "$!nextiter");
    HASH_SIGIL_str   = Parrot_str_new_constant(interp, "%");
    ARRAY_SIGIL_str  = Parrot_str_new_constant(interp, "@");
    BANG_TWIGIL_str  = Parrot_str_new_constant(interp, "!");
    SCALAR_SIGIL_str = Parrot_str_new_constant(interp, "$");
    NAMED_str        = Parrot_str_new_constant(interp, "named");
    INSTANTIATE_GENERIC_str = Parrot_str_new_constant(interp, "instantiate_generic");
    
    smo_id  = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "SixModelObject", 0));
    qrpa_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "QRPA", 0));
}


/* Gets the ID of a 6model object PMC. */
INTVAL Rakudo_smo_id(void) { return smo_id; }

/* Checks that a PMC is a native list object */
INTVAL Rakudo_isnqplist(PMC *pmc) {
    return (INTVAL)(pmc->vtable->base_type == qrpa_id
                    || pmc->vtable->base_type == enum_class_ResizablePMCArray);
}


/* Return the type we'd box a native value to. */
static PMC *
box_type(Rakudo_BindVal bv) {
    switch (bv.type) {
        case BIND_VAL_INT:
            return Rakudo_types_int_get();
        case BIND_VAL_NUM:
            return Rakudo_types_num_get();
        case BIND_VAL_STR:
            return Rakudo_types_str_get();
        default:
            return Rakudo_types_mu_get();
    }
}


/* Boxes a native value. */
static PMC *
create_box(PARROT_INTERP, Rakudo_BindVal bv) {
    PMC *box_type_obj = box_type(bv);
    PMC *boxed = REPR(box_type_obj)->allocate(interp, STABLE(box_type_obj));
    switch (bv.type) {
        case BIND_VAL_INT:
            REPR(boxed)->box_funcs->set_int(interp, STABLE(boxed), OBJECT_BODY(boxed), bv.val.i);
            break;
        case BIND_VAL_NUM:
            REPR(boxed)->box_funcs->set_num(interp, STABLE(boxed), OBJECT_BODY(boxed), bv.val.n);
            break;
        case BIND_VAL_STR:
            REPR(boxed)->box_funcs->set_str(interp, STABLE(boxed), OBJECT_BODY(boxed), bv.val.s);
            break;
    }
    return boxed;
}


/* Creates a Parcel from a RPA, filling PMCNULL elements if needed. */
/* This function gets shared with perl6.ops for the perl6_parcel_from_rpa op. */
PMC *
Rakudo_binding_parcel_from_rpa(PARROT_INTERP, PMC *rpa, PMC *fill) {
    PMC *type = Rakudo_types_parcel_get();
    PMC *parcel = REPR(type)->allocate(interp, STABLE(type));
    VTABLE_set_attr_keyed(interp, parcel, type, STORAGE_str, rpa);

    if (!PMC_IS_NULL(fill)) {
        INTVAL elems = VTABLE_elements(interp, rpa);
        INTVAL i;
        for (i = 0; i < elems; i++) {
            if (PMC_IS_NULL(VTABLE_get_pmc_keyed_int(interp, rpa, i)))
                VTABLE_set_pmc_keyed_int(interp, rpa, i, fill);
        }
    }

    return parcel;
}
        

/* Creates a ListIter from a RPA */
/* This function gets shared with perl6.ops for the perl6_iter_from_rpa op. */
PMC *
Rakudo_binding_iter_from_rpa(PARROT_INTERP, PMC *rpa, PMC *list) {
    PMC *type = Rakudo_types_listiter_get();
    PMC *iter = REPR(type)->allocate(interp, STABLE(type));
    VTABLE_set_attr_keyed(interp, iter, type, REST_str, rpa);
    VTABLE_set_attr_keyed(interp, iter, type, LIST_str, list);
    return iter;
}


/* Creates a List from type and a RPA, initializing the iterator */
/* This function gets shared with perl6.ops for the perl6_list_from_rpa op. */
PMC *
Rakudo_binding_list_from_rpa(PARROT_INTERP, PMC *rpa, PMC *type, PMC *flattens) {
    PMC *list = REPR(type)->allocate(interp, STABLE(type));
    PMC *List = Rakudo_types_list_get();
    if (!PMC_IS_NULL(rpa)) 
        VTABLE_set_attr_keyed(interp, list, List, NEXTITER_str,
            Rakudo_binding_iter_from_rpa(interp, rpa, list));
    VTABLE_set_attr_keyed(interp, list, List, FLATTENS_str, flattens);
    return list;
}
   

/* Creates a Perl 6 Array. */
static PMC *
Rakudo_binding_create_positional(PARROT_INTERP, PMC *rpa) {
    return Rakudo_binding_list_from_rpa(interp, rpa, Rakudo_types_array_get(),
               Rakudo_types_bool_true_get());
}


/* Creates a Perl 6 List. */
static PMC *
Rakudo_binding_create_list(PARROT_INTERP, PMC *rpa) {
    return Rakudo_binding_list_from_rpa(interp, rpa, Rakudo_types_list_get(),
               Rakudo_types_bool_true_get());
}


/* Creates a Perl 6 LoL. */
static PMC *
Rakudo_binding_create_lol(PARROT_INTERP, PMC *rpa) {
    return Rakudo_binding_list_from_rpa(interp, rpa, Rakudo_types_lol_get(),
               Rakudo_types_bool_false_get());
}


/* Creates a Perl 6 Hash. */
static PMC *
Rakudo_binding_create_hash(PARROT_INTERP, PMC *storage) {
    PMC *type = Rakudo_types_hash_get();
    PMC *hash = REPR(type)->allocate(interp, STABLE(type));
    VTABLE_set_attr_keyed(interp, hash, Rakudo_types_enummap_get(), STORAGE_str, storage);
    return hash;
}


static STRING *
Rakudo_binding_arity_fail(PARROT_INTERP, PMC *params, INTVAL num_params,
                          INTVAL num_pos_args, INTVAL too_many) {
    STRING *result;
    INTVAL arity = 0;
    INTVAL count = 0;
    INTVAL i;
    const char *whoz_up = too_many ? "Too many" : "Not enough";

    /* Work out how many we could have been passed. */
    for (i = 0; i < num_params; i++) {
        Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
            VTABLE_get_pmc_keyed_int(interp, params, i));

        if (!PMC_IS_NULL(param->named_names))
            continue;
        if (param->flags & SIG_ELEM_SLURPY_NAMED)
            continue;
        if (param->flags & SIG_ELEM_SLURPY_POS) {
            count = -1;
        }
        else if (param->flags & SIG_ELEM_IS_OPTIONAL) {
            count++;
        }
        else {
            count++;
            arity++;
        }
    }

    /* Now generate decent error. */
    if (arity == count)
        result = Parrot_sprintf_c(interp, "%s positional parameters passed; got %d but expected %d",
                whoz_up, num_pos_args, arity);
    else if (count == -1)
        result = Parrot_sprintf_c(interp, "%s positional parameters passed; got %d but expected at least %d",
                whoz_up, num_pos_args, arity);
    else
        result = Parrot_sprintf_c(interp, "%s positional parameters passed; got %d but expected between %d and %d",
                whoz_up, num_pos_args, arity, count);
    return result;
}


/* Binds any type captures a variable has. */
static void
Rakudo_binding_bind_type_captures(PARROT_INTERP, PMC *lexpad, Rakudo_Parameter *param, Rakudo_BindVal value) {
    PMC * type_obj = value.type == BIND_VAL_OBJ ?
        STABLE(Rakudo_cont_decontainerize(interp, value.val.o))->WHAT :
        box_type(value);
    PMC * iter     = VTABLE_get_iter(interp, param->type_captures);
    while (VTABLE_get_bool(interp, iter)) {
        STRING *name = VTABLE_shift_string(interp, iter);
        VTABLE_set_pmc_keyed_str(interp, lexpad, name, type_obj);
    }
}


/* Assigns an attributive parameter to the desired attribute. */
static INTVAL
Rakudo_binding_assign_attributive(PARROT_INTERP, PMC *lexpad, Rakudo_Parameter *param,
                                  Rakudo_BindVal value, PMC *decont_value, STRING **error) {
    PMC *assignee = PMCNULL;
    PMC *assigner;

    /* Find self. */
    PMC *self = VTABLE_get_pmc_keyed_str(interp, lexpad,
            Parrot_str_new(interp, "self", 0));
    if (PMC_IS_NULL(self)) {
        if (error)
            *error = Parrot_sprintf_c(interp,
                    "Unable to bind attributive parameter '%S' - could not find self",
                    param->variable_name);
        return BIND_RESULT_FAIL;
    }
    
    /* Ensure it's not native; NYI. */
    if (value.type != BIND_VAL_OBJ) {
        *error = Parrot_sprintf_c(interp,
            "Binding to natively typed attributive parameter '%S' not supported",
            param->variable_name);
        return BIND_RESULT_FAIL;
    }

    /* If it's private, just need to fetch the attribute. */
    if (param->flags & SIG_ELEM_BIND_PRIVATE_ATTR) {
        assignee = VTABLE_get_attr_keyed(interp, self, param->attr_package,
            param->variable_name);
    }

    /* Otherwise if it's public, do a method call to get the assignee. */
    else {
        PMC *meth = VTABLE_find_method(interp, self, param->variable_name);
        if (PMC_IS_NULL(meth)) {
            if (error)
                *error = Parrot_sprintf_c(interp,
                        "Unable to bind attributive parameter '$.%S' - could not find method '%S'",
                        param->variable_name,
                        param->variable_name);
            return BIND_RESULT_FAIL;
        }
        Parrot_ext_call(interp, meth, "Pi->P", self, &assignee);
    }

    Rakudo_cont_store(interp, assignee, decont_value, 1, 1);
    return BIND_RESULT_OK;
}


/* Returns an appropriate failure mode (junction fail or normal fail). */
static INTVAL junc_or_fail(PARROT_INTERP, PMC *value) {
    if (value->vtable->base_type == smo_id && STABLE(value)->WHAT == Rakudo_types_junction_get())
        return BIND_RESULT_JUNCTION;
    else
        return BIND_RESULT_FAIL;
}


/* Binds a single argument into the lexpad, after doing any checks that are
 * needed. Also handles any type captures. If there is a sub signature, then
 * re-enters the binder. Returns one of the BIND_RESULT_* codes. */
static INTVAL
Rakudo_binding_bind_one_param(PARROT_INTERP, PMC *lexpad, Rakudo_Signature *signature, Rakudo_Parameter *param,
                              Rakudo_BindVal orig_bv, INTVAL no_nom_type_check, STRING **error) {
    PMC            *decont_value = NULL;
    INTVAL          desired_native;
    Rakudo_BindVal  bv;
    
    /* Check if boxed/unboxed expections are met. */
    desired_native = param->flags & SIG_ELEM_NATIVE_VALUE;
    if ((desired_native == 0 && orig_bv.type == BIND_VAL_OBJ) ||
        (desired_native == SIG_ELEM_NATIVE_INT_VALUE && orig_bv.type == BIND_VAL_INT) ||
        (desired_native == SIG_ELEM_NATIVE_NUM_VALUE && orig_bv.type == BIND_VAL_NUM) ||
        (desired_native == SIG_ELEM_NATIVE_STR_VALUE && orig_bv.type == BIND_VAL_STR))
    {
        /* We have what we want. */
        bv = orig_bv;
    }
    else if (desired_native == 0) {
        /* We need to do a boxing operation. */
        bv.type = BIND_VAL_OBJ;
        bv.val.o = create_box(interp, orig_bv);
    }
    else if (orig_bv.val.o->vtable->base_type == smo_id) {
        storage_spec spec;
        decont_value = Rakudo_cont_decontainerize(interp, orig_bv.val.o);
        spec = REPR(decont_value)->get_storage_spec(interp, STABLE(decont_value));
        switch (desired_native) {
            case SIG_ELEM_NATIVE_INT_VALUE:
                if (spec.can_box & STORAGE_SPEC_CAN_BOX_INT) {
                    bv.type = BIND_VAL_INT;
                    bv.val.i = REPR(decont_value)->box_funcs->get_int(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
                }
                else {
                    if (error)
                        *error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native int",
                            param->variable_name);
                    return BIND_RESULT_FAIL;
                }
                break;
            case SIG_ELEM_NATIVE_NUM_VALUE:
                if (spec.can_box & STORAGE_SPEC_CAN_BOX_NUM) {
                    bv.type = BIND_VAL_NUM;
                    bv.val.n = REPR(decont_value)->box_funcs->get_num(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
                }
                else {
                    if (error)
                        *error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native num",
                            param->variable_name);
                    return BIND_RESULT_FAIL;
                }
                break;
            case SIG_ELEM_NATIVE_STR_VALUE:
                if (spec.can_box & STORAGE_SPEC_CAN_BOX_STR) {
                    bv.type = BIND_VAL_STR;
                    bv.val.s = REPR(decont_value)->box_funcs->get_str(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
                }
                else {
                    if (error)
                        *error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native str",
                            param->variable_name);
                    return BIND_RESULT_FAIL;
                }
                break;
            default:
                if (error)
                    *error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native type",
                        param->variable_name);
                return BIND_RESULT_FAIL;
        }
        decont_value = NULL;
    }
    else if (orig_bv.val.o->vtable->base_type == enum_class_Integer &&
             desired_native == SIG_ELEM_NATIVE_INT_VALUE) {
         bv.type = BIND_VAL_INT;
         bv.val.i = VTABLE_get_integer(interp, orig_bv.val.o);
    }
    else if (orig_bv.val.o->vtable->base_type == enum_class_Float &&
             desired_native == SIG_ELEM_NATIVE_NUM_VALUE) {
         bv.type = BIND_VAL_NUM;
         bv.val.n = VTABLE_get_number(interp, orig_bv.val.o);
    }
    else if (orig_bv.val.o->vtable->base_type == enum_class_String &&
             desired_native == SIG_ELEM_NATIVE_STR_VALUE) {
         bv.type = BIND_VAL_STR;
         bv.val.s = VTABLE_get_string(interp, orig_bv.val.o);
    }
    else {
        if (error)
            *error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native type",
                param->variable_name);
        return BIND_RESULT_FAIL;
    }
    
    /* By this point, we'll either have an object that we might be able to
     * bind if it passes the type check, or a native value that needs no
     * further checking. */
    if (bv.type == BIND_VAL_OBJ) {
        /* Ensure the value is a 6model object; if not, marshall it to one. */
        if (bv.val.o->vtable->base_type != smo_id) {
            bv.val.o = Rakudo_types_parrot_map(interp, bv.val.o);
            if (bv.val.o->vtable->base_type != smo_id) {
                *error = Parrot_sprintf_c(interp, "Unmarshallable foreign language value passed for parameter '%S'",
                        param->variable_name);
                return BIND_RESULT_FAIL;
            }
        }

        /* We pretty much always need to de-containerized value, so get it
         * right off. */
        decont_value = Rakudo_cont_decontainerize(interp, bv.val.o);
    
        /* Skip nominal type check if not needed. */
        if (!no_nom_type_check) {
            PMC *nom_type;
            
            /* Is the nominal type generic and in need of instantiation? (This
             * can happen in (::T, T) where we didn't learn about the type until
             * during the signature bind). */
            if (param->flags & SIG_ELEM_NOMINAL_GENERIC) {
                PMC *HOW = STABLE(param->nominal_type)->HOW;
                PMC *ig  = VTABLE_find_method(interp, HOW, INSTANTIATE_GENERIC_str);
                Parrot_ext_call(interp, ig, "PiPP->P", HOW, param->nominal_type,
                    lexpad, &nom_type);
            }
            else {
                nom_type = param->nominal_type;
            }

            /* If not, do the check. If the wanted nominal type is Mu, then
             * anything goes. */
            if (nom_type != Rakudo_types_mu_get() &&
                    (decont_value->vtable->base_type != smo_id ||
                     !STABLE(decont_value)->type_check(interp, decont_value, nom_type))) {
                /* Type check failed; produce error if needed. */
                if (error) {
                    PMC    * got_how       = STABLE(decont_value)->HOW;
                    PMC    * exp_how       = STABLE(nom_type)->HOW;
                    PMC    * got_name_meth = VTABLE_find_method(interp, got_how, NAME_str);
                    PMC    * exp_name_meth = VTABLE_find_method(interp, exp_how, NAME_str);
                    STRING * expected, * got;
                    Parrot_ext_call(interp, got_name_meth, "PiP->S", got_how, bv.val.o, &got);
                    Parrot_ext_call(interp, exp_name_meth, "PiP->S", exp_how, nom_type, &expected);
                    *error = Parrot_sprintf_c(interp, "Nominal type check failed for parameter '%S'; expected %S but got %S instead",
                                param->variable_name, expected, got);
                }
                
                /* Report junction failure mode if it's a junction. */
                return junc_or_fail(interp, decont_value);
            }
            
            /* Also enforce definedness constraints. */
            if (param->flags & SIG_ELEM_DEFINEDNES_CHECK) {
                INTVAL defined = IS_CONCRETE(decont_value);
                if (defined && param->flags & SIG_ELEM_UNDEFINED_ONLY) {
                    if (error) {
                        if (param->flags & SIG_ELEM_INVOCANT) {
                            *error = Parrot_sprintf_c(interp,
                                "Invocant requires a type object, but an object instance was passed" );
                        }
                        else {
                            *error = Parrot_sprintf_c(interp,
                                "Parameter '%S' requires a type object, but an object instance was passed",
                                param->variable_name);
                        }
                    }
                    return junc_or_fail(interp, decont_value);
                }
                if (!defined && param->flags & SIG_ELEM_DEFINED_ONLY) {
                    if (error) {
                        if (param->flags & SIG_ELEM_INVOCANT) {
                            *error = Parrot_sprintf_c(interp,
                                "Invocant requires an instance, but a type object was passed" );
                        }
                        else {
                            *error = Parrot_sprintf_c(interp,
                                "Parameter '%S' requires an instance, but a type object was passed",
                                param->variable_name);
                        }
                    }
                    return junc_or_fail(interp, decont_value);
                }
            }
        }
    }

    /* Do we have any type captures to bind? */
    if (!PMC_IS_NULL(param->type_captures)) {
        Rakudo_binding_bind_type_captures(interp, lexpad, param, bv);
    }

    /* Do a coercion, if one is needed. */
    if (!PMC_IS_NULL(param->coerce_type)) {
        /* Coercing natives not possible - nothing to call a method on. */
        if (bv.type != BIND_VAL_OBJ) {
            if (error)
                *error = Parrot_sprintf_c(interp,
                    "Unable to coerce natively typed parameter '%S'",
                    param->variable_name);
            return BIND_RESULT_FAIL;
        }

        /* Only coerce if we don't already have the correct type. */
        if (!STABLE(decont_value)->type_check(interp, decont_value, param->coerce_type)) {
            PMC *coerce_meth = VTABLE_find_method(interp, decont_value, param->coerce_method);
            if (!PMC_IS_NULL(coerce_meth)) {
                Parrot_ext_call(interp, coerce_meth, "Pi->P", decont_value, &decont_value);
            }
            else {
                /* No coercion method availale; whine and fail to bind. */
                if (error) {
                    PMC    * got_how       = STABLE(decont_value)->HOW;
                    PMC    * got_name_meth = VTABLE_find_method(interp, got_how, NAME_str);
                    STRING * got;
                    Parrot_ext_call(interp, got_name_meth, "PiP->S", got_how, decont_value, &got);
                    *error = Parrot_sprintf_c(interp,
                            "Unable to coerce value for '%S' from %S to %S; no coercion method defined",
                            param->variable_name, got, param->coerce_method);
                }
                return BIND_RESULT_FAIL;
            }
        }
    }

    /* If it's not got attributive binding, we'll go about binding it into the
     * lex pad. */
    if (!(param->flags & SIG_ELEM_BIND_ATTRIBUTIVE) && !STRING_IS_NULL(param->variable_name)) {
        /* Is it native? If so, just go ahead and bind it. */
        if (bv.type != BIND_VAL_OBJ) {
            switch (bv.type) {
                case BIND_VAL_INT:
                    VTABLE_set_integer_keyed_str(interp, lexpad, param->variable_name, bv.val.i);
                    break;
                case BIND_VAL_NUM:
                    VTABLE_set_number_keyed_str(interp, lexpad, param->variable_name, bv.val.n);
                    break;
                case BIND_VAL_STR:
                    VTABLE_set_string_keyed_str(interp, lexpad, param->variable_name, bv.val.s);
                    break;
            }
        }
        
        /* Otherwise it's some objecty case. */
        else if (param->flags & SIG_ELEM_IS_RW) {
            /* XXX TODO Check if rw flag is set; also need to have a
             * wrapper container that carries extra constraints. */
            VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bv.val.o);
        }
        else if (param->flags & SIG_ELEM_IS_PARCEL) {
            /* Just bind the thing as is into the lexpad. */
            VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bv.val.o);
        }
        else {
            /* If it's an array, copy means make a new one and store,
             * and a normal bind is a straightforward binding plus
             * adding a constraint. */
            if (param->flags & SIG_ELEM_ARRAY_SIGIL) {
                PMC *bindee = decont_value;
                if (param->flags & SIG_ELEM_IS_COPY) {
                    bindee = Rakudo_binding_create_positional(interp,
                        Parrot_pmc_new(interp, enum_class_ResizablePMCArray));
                    Rakudo_cont_store(interp, bindee, decont_value, 0, 0);
                }
                VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bindee);
            }
            
            /* If it's a hash, similar approach to array. */
            else if (param->flags & SIG_ELEM_HASH_SIGIL) {
                PMC *bindee = decont_value;
                if (param->flags & SIG_ELEM_IS_COPY) {
                    bindee = Rakudo_binding_create_hash(interp,
                        Parrot_pmc_new(interp, enum_class_Hash));
                    Rakudo_cont_store(interp, bindee, decont_value, 0, 0);
                }
                VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bindee);
            }
            
            /* If it's a scalar, we always need to wrap it into a new
             * container and store it, for copy or ro case (the rw bit
             * in the container descriptor takes care of the rest). */
            else {
                PMC *new_cont = Rakudo_cont_scalar_from_descriptor(interp, param->container_descriptor);
                Rakudo_cont_store(interp, new_cont, decont_value, 0, 0);
                VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, new_cont);
            }
        }
    }

    /* Is it the invocant? If so, also have to bind to self lexical. */
    if (param->flags & SIG_ELEM_INVOCANT)
        VTABLE_set_pmc_keyed_str(interp, lexpad, SELF_str, decont_value);

    /* Handle any constraint types (note that they may refer to the parameter by
     * name, so we need to have bound it already). */
    if (!PMC_IS_NULL(param->post_constraints)) {
        PMC * code_type         = Rakudo_types_code_get();
        PMC * const constraints = param->post_constraints;
        INTVAL num_constraints  = VTABLE_elements(interp, constraints);
        INTVAL i;
        for (i = 0; i < num_constraints; i++) {
            /* Check we meet the constraint. */
            PMC *cons_type    = VTABLE_get_pmc_keyed_int(interp, constraints, i);
            PMC *accepts_meth = VTABLE_find_method(interp, cons_type, ACCEPTS);
            PMC *old_ctx      = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            PMC *cappy        = Parrot_pmc_new(interp, enum_class_CallContext);
            if (STABLE(cons_type)->type_check(interp, cons_type, code_type))
                Parrot_sub_capture_lex(interp,
                    VTABLE_get_attr_keyed(interp, cons_type, code_type, DO_str));
            VTABLE_push_pmc(interp, cappy, cons_type);
            switch (bv.type) {
                case BIND_VAL_OBJ:
                    VTABLE_push_pmc(interp, cappy, bv.val.o);
                    break;
                case BIND_VAL_INT:
                    VTABLE_push_integer(interp, cappy, bv.val.i);
                    break;
                case BIND_VAL_NUM:
                    VTABLE_push_float(interp, cappy, bv.val.n);
                    break;
                case BIND_VAL_STR:
                    VTABLE_push_string(interp, cappy, bv.val.s);
                    break;
            }
            Parrot_pcc_invoke_from_sig_object(interp, accepts_meth, cappy);
            cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
            if (!VTABLE_get_bool(interp, VTABLE_get_pmc_keyed_int(interp, cappy, 0))) {
                if (error)
                    *error = Parrot_sprintf_c(interp, "Constraint type check failed for parameter '%S'",
                            param->variable_name);
                return BIND_RESULT_FAIL;
            }
        }
    }

    /* If it's attributive, now we assign it. */
    if (param->flags & SIG_ELEM_BIND_ATTRIBUTIVE) {
        INTVAL result = Rakudo_binding_assign_attributive(interp, lexpad, param, bv, decont_value, error);
        if (result != BIND_RESULT_OK)
            return result;
    }

    /* If it has a sub-signature, bind that. */
    if (!PMC_IS_NULL(param->sub_llsig) && bv.type == BIND_VAL_OBJ) {
        /* Turn value into a capture, unless we already have one. */
        PMC *capture = PMCNULL;
        INTVAL result;
        if (param->flags & SIG_ELEM_IS_CAPTURE) {
            capture = decont_value;
        }
        else {
            PMC *meth    = VTABLE_find_method(interp, decont_value, Parrot_str_new(interp, "Capture", 0));
            if (PMC_IS_NULL(meth)) {
                if (error)
                    *error = Parrot_sprintf_c(interp, "Could not turn argument into capture");
                return BIND_RESULT_FAIL;
            }
            Parrot_ext_call(interp, meth, "Pi->P", decont_value, &capture);
        }

        /* Recurse into signature binder. */
        result = Rakudo_binding_bind(interp, lexpad, param->sub_llsig,
                capture, no_nom_type_check, error);
        if (result != BIND_RESULT_OK)
        {
            if (error) {
                /* Note in the error message that we're in a sub-signature. */
                *error = Parrot_str_concat(interp, *error,
                        Parrot_str_new(interp, " in sub-signature", 0));

                /* Have we a variable name? */
                if (!STRING_IS_NULL(param->variable_name)) {
                    *error = Parrot_str_concat(interp, *error,
                            Parrot_str_new(interp, " of parameter ", 0));
                    *error = Parrot_str_concat(interp, *error, param->variable_name);
                }
            }
            return result;
        }
    }

    /* Binding of this parameter was thus successful - we're done. */
    return BIND_RESULT_OK;
}


/* This takes a signature element and either runs the closure to get a default
 * value if there is one, or creates an appropriate undefined-ish thingy. */
static PMC *
Rakudo_binding_handle_optional(PARROT_INTERP, Rakudo_Parameter *param, PMC *lexpad) {
    PMC *cur_lex;

    /* Is the "get default from outer" flag set? */
    if (param->flags & SIG_ELEM_DEFAULT_FROM_OUTER) {
        PMC *outer_ctx    = Parrot_pcc_get_outer_ctx(interp, CURRENT_CONTEXT(interp));
        PMC *outer_lexpad = Parrot_pcc_get_lex_pad(interp, outer_ctx);
        return VTABLE_get_pmc_keyed_str(interp, outer_lexpad, param->variable_name);
    }

    /* Do we have a default value or value closure? */
    else if (!PMC_IS_NULL(param->default_value)) {
        if (param->flags & SIG_ELEM_DEFAULT_IS_LITERAL) {
            return param->default_value;
        }
        else {
            /* Thunk; run it to get a value. */
            PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            PMC *cappy   = Parrot_pmc_new(interp, enum_class_CallContext);
            Parrot_pcc_invoke_from_sig_object(interp, param->default_value, cappy);
            cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
            return VTABLE_get_pmc_keyed_int(interp, cappy, 0);
        }
    }

    /* Otherwise, go by sigil to pick the correct default type of value. */
    else {
        if (param->flags & SIG_ELEM_ARRAY_SIGIL) {
            return Rakudo_binding_create_positional(interp, PMCNULL);
        }
        else if (param->flags & SIG_ELEM_HASH_SIGIL) {
            return Rakudo_binding_create_hash(interp, Parrot_pmc_new(interp, enum_class_Hash));
        }
        else {
            return param->nominal_type;
        }
    }
}


/* Extracts bind value information for a positional parameter. */
static Rakudo_BindVal
get_positional_bind_val(PARROT_INTERP, struct Pcc_cell *pc_positionals, PMC *capture, INTVAL cur_pos_arg) {
    Rakudo_BindVal cur_bv;
    if (pc_positionals) {
        switch (pc_positionals[cur_pos_arg].type) {
            case BIND_VAL_INT:
                cur_bv.type = BIND_VAL_INT;
                cur_bv.val.i = pc_positionals[cur_pos_arg].u.i;
                break;
            case BIND_VAL_NUM:
                cur_bv.type = BIND_VAL_NUM;
                cur_bv.val.n = pc_positionals[cur_pos_arg].u.n;
                break;
            case BIND_VAL_STR:
                cur_bv.type = BIND_VAL_STR;
                cur_bv.val.s = pc_positionals[cur_pos_arg].u.s;
                break;
            default:
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = pc_positionals[cur_pos_arg].u.p;
        }
    }
    else {
        cur_bv.type = BIND_VAL_OBJ;
        cur_bv.val.o = VTABLE_get_pmc_keyed_int(interp, capture, cur_pos_arg);
    }
    return cur_bv;
}


/* Takes a signature along with positional and named arguments and binds them
 * into the provided lexpad (actually, anything that has a Hash interface will
 * do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there
 * is a failure and BIND_RESULT_JUNCTION if the failure was because of a
 * Junction being passed (meaning we need to auto-thread). */
INTVAL
Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture,
                    INTVAL no_nom_type_check, STRING **error) {
    INTVAL            i, num_pos_args;
    INTVAL            bind_fail   = 0;
    INTVAL            cur_pos_arg = 0;
    Rakudo_Signature *sig         = (Rakudo_Signature *)PMC_data(sig_pmc);
    PMC              *params      = sig->params;
    INTVAL            num_params  = VTABLE_elements(interp, params);
    Rakudo_BindVal    cur_bv;

    /* If we do have some named args, we want to make a clone of the hash
     * to work on. We'll delete stuff from it as we bind, and what we have
     * left over can become the slurpy hash or - if we aren't meant to be
     * taking one - tell us we have a problem. */
    PMC *named_args_copy = PMCNULL;

    /* If we have a |$foo that's followed by slurpies, then we can suppress
     * any future arity checks. */
    INTVAL suppress_arity_fail = 0;
    
    /* If it's a Parrot capture, it may contain natively typed arguments.
     * NOTE: This is a really an encapsulation breakage; if Parrot folks
     * change stuff and this breaks, it's not Parrot's fault. */
    struct Pcc_cell * pc_positionals = NULL;

    /* Set up statics. */
    if (!smo_id)
        setup_binder_statics(interp);

    /* If we've got a CallContext, just has an attribute with list of named
     * parameter names. Otherwise, it's probably a Perl 6 Capture and we need
     * to extract its parts. */
    if (capture->vtable->base_type == enum_class_CallContext) {
        PMC *named_names = VTABLE_get_attr_str(interp, capture, NAMED_str);
        if (!PMC_IS_NULL(named_names)) {
            PMC *iter = VTABLE_get_iter(interp, named_names);
            named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
            while (VTABLE_get_bool(interp, iter)) {
                STRING *name = VTABLE_shift_string(interp, iter);
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, name,
                        VTABLE_get_pmc_keyed_str(interp, capture, name));
            }
        }
        GETATTR_CallContext_positionals(interp, capture, pc_positionals);
    }
    else if (capture->vtable->base_type == smo_id &&
            STABLE(capture)->type_check(interp, capture, Rakudo_types_capture_get())) {
        PMC *captype   = Rakudo_types_capture_get();
        PMC *list_part = VTABLE_get_attr_keyed(interp, capture, captype, LIST_str);
        PMC *hash_part = VTABLE_get_attr_keyed(interp, capture, captype, HASH_str);
        capture = Rakudo_isnqplist(list_part) 
                    ?  list_part 
                    : Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
        if (hash_part->vtable->base_type == enum_class_Hash) {
            PMC *iter = VTABLE_get_iter(interp, hash_part);
            named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
            while (VTABLE_get_bool(interp, iter)) {
                STRING *arg_copy_name = VTABLE_shift_string(interp, iter);
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, arg_copy_name,
                    VTABLE_get_pmc_keyed_str(interp, hash_part, arg_copy_name));
            }
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Internal Error: Rakudo_binding_bind passed invalid Capture");
    }

    /* Now we'll walk through the signature and go about binding things. */
    num_pos_args = VTABLE_elements(interp, capture);
    for (i = 0; i < num_params; i++) {
        Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
                VTABLE_get_pmc_keyed_int(interp, params, i));

        /* Is it looking for us to bind a capture here? */
        if (param->flags & SIG_ELEM_IS_CAPTURE) {
            /* Capture the arguments from this point forwards into a Capture.
             * Of course, if there's no variable name we can (cheaply) do pretty
             * much nothing. */
            if (STRING_IS_NULL(param->variable_name)) {
                bind_fail = BIND_RESULT_OK;
            }
            else {
                PMC *captype    = Rakudo_types_capture_get();
                PMC *capsnap    = REPR(captype)->allocate(interp, STABLE(captype));
                PMC *pos_args   = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                PMC *named_args = Parrot_pmc_new(interp, enum_class_Hash);
                INTVAL k;
                VTABLE_set_attr_keyed(interp, capsnap, captype, LIST_str, pos_args);
                VTABLE_set_attr_keyed(interp, capsnap, captype, HASH_str, named_args);
                for (k = cur_pos_arg; k < num_pos_args; k++) {
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, k);
                    VTABLE_push_pmc(interp, pos_args, cur_bv.type == BIND_VAL_OBJ ?
                        cur_bv.val.o :
                        create_box(interp, cur_bv));
                }
                if (!PMC_IS_NULL(named_args_copy)) {
                    PMC *iter = VTABLE_get_iter(interp, named_args_copy);
                    while (VTABLE_get_bool(interp, iter)) {
                        STRING *name = VTABLE_shift_string(interp, iter);
                        VTABLE_set_pmc_keyed_str(interp, named_args, name,
                            VTABLE_get_pmc_keyed_str(interp, named_args_copy, name));
                    }
                }
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = capsnap;
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv,
                        no_nom_type_check, error);
            }
            if (bind_fail) {
                return bind_fail;
            }
            else if (i + 1 == num_params) {
                /* Since a capture acts as "the ultimate slurpy" in a sense, if
                 * this is the last parameter in the signature we can return
                 * success right off the bat. */
                return BIND_RESULT_OK;
            }
            else {
                Rakudo_Parameter *next_param = (Rakudo_Parameter *)PMC_data(
                    VTABLE_get_pmc_keyed_int(interp, params, i + 1));
                if (next_param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED))
                    suppress_arity_fail = 1;
            }
        }

        /* Could it be a named slurpy? */
        else if (param->flags & SIG_ELEM_SLURPY_NAMED) {
            /* We'll either take the current named arguments copy hash which
             * will by definition contain all unbound named parameters and use
             * that. Otherwise, putting Mu in there is fine; Hash is smart
             * enough to know what to do. */
            PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
                    Rakudo_types_mu_get() :
                    named_args_copy;
            cur_bv.type = BIND_VAL_OBJ;
            cur_bv.val.o = Rakudo_binding_create_hash(interp, slurpy);
            bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                    cur_bv, no_nom_type_check, error);
            if (bind_fail)
                return bind_fail;
            
            /* Nullify named arguments hash now we've consumed it, to mark all
             * is well. */
            named_args_copy = PMCNULL;
        }

        /* Otherwise, maybe it's a positional. */
        else if (PMC_IS_NULL(param->named_names)) {
            /* Slurpy or LoL-slurpy? */
            if (param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_LOL)) {
                /* Create Perl 6 array, create RPA of all remaining things, then
                 * store it. */
                PMC *temp = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                while (cur_pos_arg < num_pos_args) {
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
                    VTABLE_push_pmc(interp, temp, cur_bv.type == BIND_VAL_OBJ ?
                        cur_bv.val.o :
                        create_box(interp, cur_bv));
                    cur_pos_arg++;
                }
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = param->flags & SIG_ELEM_SLURPY_POS ?
                    (param->flags & SIG_ELEM_IS_RW ?
                        Rakudo_binding_create_list(interp, temp) :
                        Rakudo_binding_create_positional(interp, temp)) :
                    Rakudo_binding_create_lol(interp, temp);
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, no_nom_type_check, error);
                if (bind_fail)
                    return bind_fail;
            }

            /* Otherwise, a positional. */
            else {
                /* Do we have a value?. */
                if (cur_pos_arg < num_pos_args) {
                    /* Easy - just bind that. */
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
                    bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                            cur_bv, no_nom_type_check, error);
                    if (bind_fail)
                        return bind_fail;
                    cur_pos_arg++;
                }
                else {
                    /* No value. If it's optional, fetch a default and bind that;
                     * if not, we're screwed. Note that we never nominal type check
                     * an optional with no value passed. */
                    if (param->flags & SIG_ELEM_IS_OPTIONAL) {
                        cur_bv.type = BIND_VAL_OBJ;
                        cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
                        bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                                cur_bv, 0, error);
                        if (bind_fail)
                            return bind_fail;
                    }
                    else {
                        if (error)
                            *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 0);
                        return BIND_RESULT_FAIL;
                    }
                }
            }
        }

        /* Else, it's a non-slurpy named. */
        else {
            /* Try and get hold of value. */
            PMC *value = PMCNULL;
            INTVAL num_names = VTABLE_elements(interp, param->named_names);
            INTVAL j;
            if (!PMC_IS_NULL(named_args_copy)) {
                for (j = 0; j < num_names; j++) {
                    STRING *name = VTABLE_get_string_keyed_int(interp, param->named_names, j);
                    value = VTABLE_get_pmc_keyed_str(interp, named_args_copy, name);
                    if (!PMC_IS_NULL(value)) {
                        /* Found a value. Delete entry from to-bind args and stop looking. */
                        VTABLE_delete_keyed_str(interp, named_args_copy, name);
                        break;
                    }
                }
            }

            /* Did we get one? */
            if (PMC_IS_NULL(value)) {
                /* Nope. We'd better hope this param was optional... */
                if (param->flags & SIG_ELEM_IS_OPTIONAL) {
                    cur_bv.type = BIND_VAL_OBJ;
                    cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
                    bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                            cur_bv, 0, error);
                }
                else if (!suppress_arity_fail) {
                    if (error)
                        *error = Parrot_sprintf_c(interp, "Required named parameter '%S' not passed",
                                VTABLE_get_string_keyed_int(interp, param->named_names, 0));
                    return BIND_RESULT_FAIL;
                }
            }
            else {
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = value;
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, 0, error);
            }

            /* If we got a binding failure, return it. */
            if (bind_fail)
                return bind_fail;
        }
    }

    /* Do we have any left-over args? */
    if (cur_pos_arg < num_pos_args && !suppress_arity_fail) {
        /* Oh noes, too many positionals passed. */
        if (error)
            *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 1);
        return BIND_RESULT_FAIL;
    }
    if (!PMC_IS_NULL(named_args_copy) && VTABLE_elements(interp, named_args_copy)) {
        /* Oh noes, unexpected named args. */
        if (error) {
            INTVAL num_extra = VTABLE_elements(interp, named_args_copy);
            PMC *iter        = VTABLE_get_iter(interp, named_args_copy);
            if (num_extra == 1) {
                *error = Parrot_sprintf_c(interp, "Unexpected named parameter '%S' passed",
                        VTABLE_shift_string(interp, iter));
            }
            else {
                INTVAL first  = 1;
                STRING *comma = Parrot_str_new(interp, ", ", 0);
                *error = Parrot_sprintf_c(interp, "%d unexpected named parameters passed (", num_extra);
                while (VTABLE_get_bool(interp, iter)) {
                    STRING *name = VTABLE_shift_string(interp, iter);
                    if (!first)
                        *error = Parrot_str_concat(interp, *error, comma);
                    else
                        first = 0;
                    *error = Parrot_str_concat(interp, *error, name);
                }
                *error = Parrot_str_concat(interp, *error, Parrot_str_new(interp, ")", 0));
            }
        }
        return BIND_RESULT_FAIL;
    }

    /* If we get here, we're done. */
    return BIND_RESULT_OK;
}

/* Compile time trial binding; tries to determine at compile time whether
 * certain binds will/won't work. */
INTVAL Rakudo_binding_trial_bind(PARROT_INTERP, PMC *sig_pmc, PMC *capture) {
    INTVAL            i, num_pos_args, got_prim;
    INTVAL            cur_pos_arg = 0;
    Rakudo_Signature *sig         = (Rakudo_Signature *)PMC_data(sig_pmc);
    PMC              *params      = sig->params;
    INTVAL            num_params  = VTABLE_elements(interp, params);

    /* Grab arguments. */
    struct Pcc_cell * pc_positionals = NULL;
    if (capture->vtable->base_type == enum_class_CallContext)
        GETATTR_CallContext_positionals(interp, capture, pc_positionals);
    else
        return TRIAL_BIND_NOT_SURE;

    /* Set up statics. */
    if (!smo_id)
        setup_binder_statics(interp);
        
    /* If there's a single capture parameter, then we're OK. (Worth
     * handling especially as it's the common case for protos). */
    if (num_params == 1) {
        Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
                VTABLE_get_pmc_keyed_int(interp, params, 0));
        if (param->flags & SIG_ELEM_IS_CAPTURE)
            return TRIAL_BIND_OK;
    }
        
    /* Walk through the signature and consider the parameters. */
    num_pos_args = VTABLE_elements(interp, capture);
    for (i = 0; i < num_params; i++) {
        Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
                VTABLE_get_pmc_keyed_int(interp, params, i));
        
        /* If the parameter is anything other than a boring old
         * positional parameter, we won't analyze it. */
        if (param->flags & ~(
                SIG_ELEM_MULTI_INVOCANT | SIG_ELEM_IS_PARCEL |
                SIG_ELEM_IS_COPY | SIG_ELEM_ARRAY_SIGIL |
                SIG_ELEM_HASH_SIGIL | SIG_ELEM_NATIVE_VALUE |
                SIG_ELEM_IS_OPTIONAL))
            return TRIAL_BIND_NOT_SURE;
        if (!PMC_IS_NULL(param->named_names))
            return TRIAL_BIND_NOT_SURE;
        if (!PMC_IS_NULL(param->post_constraints))
            return TRIAL_BIND_NOT_SURE;
        if (!PMC_IS_NULL(param->type_captures))
            return TRIAL_BIND_NOT_SURE;

        /* Do we have an argument for this parameter? */
        if (cur_pos_arg >= num_pos_args) {
            /* No; if it's not optional, fail.*/
            if (!(param->flags & SIG_ELEM_IS_OPTIONAL))
                return TRIAL_BIND_NO_WAY;
        }
        else {
            /* Yes, need to consider type. */
            got_prim = pc_positionals[cur_pos_arg].type;
            if (param->flags & SIG_ELEM_NATIVE_VALUE) {
                if (got_prim == BIND_VAL_OBJ) {
                    /* We got an object; if we aren't sure we can unbox, we can't
                    * be sure about the dispatch. */
                    PMC *arg = pc_positionals[cur_pos_arg].u.p;
                    storage_spec spec = REPR(arg)->get_storage_spec(interp, STABLE(arg));
                    switch (param->flags & SIG_ELEM_NATIVE_VALUE) {
                        case SIG_ELEM_NATIVE_INT_VALUE:
                            if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_INT))
                                return TRIAL_BIND_NOT_SURE;
                            break;
                        case SIG_ELEM_NATIVE_NUM_VALUE:
                            if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_NUM))
                                return TRIAL_BIND_NOT_SURE;
                            break;
                        case SIG_ELEM_NATIVE_STR_VALUE:
                            if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_STR))
                                return TRIAL_BIND_NOT_SURE;
                            break;
                        default:
                            /* WTF... */
                            return TRIAL_BIND_NOT_SURE;
                    }
                }
                else {
                    /* If it's the wrong type of native, there's no way it
                    * can ever bind. */
                    if (((param->flags & SIG_ELEM_NATIVE_INT_VALUE) && got_prim != BIND_VAL_INT) ||
                        ((param->flags & SIG_ELEM_NATIVE_NUM_VALUE) && got_prim != BIND_VAL_NUM) ||
                        ((param->flags & SIG_ELEM_NATIVE_STR_VALUE) && got_prim != BIND_VAL_STR))
                        return TRIAL_BIND_NO_WAY;
                }
            }
            else {
                /* Work out a parameter type to consider, and see if it matches. */
                PMC * const arg =
                    got_prim == BIND_VAL_OBJ ? pc_positionals[cur_pos_arg].u.p :
                    got_prim == BIND_VAL_INT ? Rakudo_types_int_get() :
                    got_prim == BIND_VAL_NUM ? Rakudo_types_num_get() :
                                            Rakudo_types_str_get();
                if (param->nominal_type != Rakudo_types_mu_get() &&
                        !STABLE(arg)->type_check(interp, arg, param->nominal_type)) {
                    /* If it failed because we got a junction, may auto-thread;
                    * hand back "not sure" for now. */
                    if (STABLE(arg)->WHAT == Rakudo_types_junction_get())
                        return TRIAL_BIND_NOT_SURE;
                    
                    /* It failed to, but that doesn't mean it can't work at runtime;
                    * we perhaps want an Int, and the most we know is we have an Any,
                    * which would include Int. However, the Int ~~ Str case can be
                    * rejected now, as there's no way it'd ever match. Basically, we
                    * just flip the type check around. */
                    return STABLE(param->nominal_type)->type_check(interp, param->nominal_type, arg) ?
                        TRIAL_BIND_NOT_SURE : TRIAL_BIND_NO_WAY;
                }
            }
        }

        /* Continue to next argument. */
        cur_pos_arg++;
    }

    /* If we have any left over arguments, it's a binding fail. */
    if (cur_pos_arg < num_pos_args)
        return TRIAL_BIND_NO_WAY;

    /* Otherwise, if we get there, all is well. */
    return TRIAL_BIND_OK;
}

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */
rakudo-2013.12/src/vm/parrot/guts/bind.h0000664000175000017500000001627712224263172017410 0ustar  moritzmoritz/* Flags that can be set on a signature element. */
#define SIG_ELEM_BIND_CAPTURE        1
#define SIG_ELEM_BIND_PRIVATE_ATTR   2
#define SIG_ELEM_BIND_PUBLIC_ATTR    4
#define SIG_ELEM_BIND_ATTRIBUTIVE    (SIG_ELEM_BIND_PRIVATE_ATTR | SIG_ELEM_BIND_PUBLIC_ATTR)
#define SIG_ELEM_SLURPY_POS          8
#define SIG_ELEM_SLURPY_NAMED        16
#define SIG_ELEM_SLURPY_LOL          32
#define SIG_ELEM_SLURPY              (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED | SIG_ELEM_SLURPY_LOL)
#define SIG_ELEM_INVOCANT            64
#define SIG_ELEM_MULTI_INVOCANT      128
#define SIG_ELEM_IS_RW               256
#define SIG_ELEM_IS_COPY             512
#define SIG_ELEM_IS_PARCEL           1024
#define SIG_ELEM_IS_OPTIONAL         2048
#define SIG_ELEM_ARRAY_SIGIL         4096
#define SIG_ELEM_HASH_SIGIL          8192
#define SIG_ELEM_DEFAULT_FROM_OUTER  16384
#define SIG_ELEM_IS_CAPTURE          32768
#define SIG_ELEM_UNDEFINED_ONLY      65536
#define SIG_ELEM_DEFINED_ONLY        131072
#define SIG_ELEM_DEFINEDNES_CHECK    (SIG_ELEM_UNDEFINED_ONLY | SIG_ELEM_DEFINED_ONLY)
#define SIG_ELEM_NOMINAL_GENERIC     524288
#define SIG_ELEM_DEFAULT_IS_LITERAL  1048576
#define SIG_ELEM_NATIVE_INT_VALUE    2097152
#define SIG_ELEM_NATIVE_NUM_VALUE    4194304
#define SIG_ELEM_NATIVE_STR_VALUE    8388608
#define SIG_ELEM_NATIVE_VALUE        (SIG_ELEM_NATIVE_INT_VALUE | SIG_ELEM_NATIVE_NUM_VALUE | SIG_ELEM_NATIVE_STR_VALUE)

/* This is how a parameter looks on the inside. Actually, this is a C struct
 * that should match the computed object layout by P6opaque for the type
 * Parameter. So if changing that, this needs to be changed here. */
typedef struct {
    PMC    *st;                   /* S-table, though we don't care about that here. */
    PMC    *sc;                   /* Serialization context, though we don't care about that here. */
    STRING *variable_name;        /* The name in the lexpad to bind to, if any. */
    PMC    *named_names;          /* List of the name(s) that a named parameter has. */
    PMC    *type_captures;        /* Name(s) that we bind the type of a parameter to. */
    INTVAL flags;                 /* Various flags about the parameter. */
    PMC    *nominal_type;         /* The nominal type of the parameter. */
    PMC    *post_constraints;     /* Array of any extra constraints; we will do a
                                   * smart-match against each of them. For now, we
                                   * always expect an array of blocks. */
    PMC    *coerce_type;          /* The type to coerce the value to, if any. */
    STRING *coerce_method;        /* Name of the method to call to coerce; for X we do $val.X. */
    PMC    *sub_llsig;            /* Any nested signature. */
    PMC    *default_value;        /* The default value or a thunk producing it. */
    PMC    *container_descriptor; /* Descriptor for the container we bind into, if any. */
    PMC    *attr_package;         /* Package part of an attributive binding. */
} Rakudo_Parameter;

/* This is how a signature looks on the inside. Actually, this is a C struct
 * that should match the computed object layout by P6opaque for the type
 * Signature. So if changing that, this needs to be changed here. */
typedef struct {
    PMC    *st;                 /* S-table, though we don't care about that here. */
    PMC    *sc;                 /* Serialization context, though we don't care about that here. */
    PMC    *params;             /* Array of objects that are all parameters. */
    PMC    *rtype;              /* Return type. */
    PMC    *arity;              /* Cached arity. */
    PMC    *count;              /* Cached count. */
    PMC    *code;               /* The code object the signature is for. */
} Rakudo_Signature;

/* This is how a Code looks on the inside. Once again, C struct that should
 * match what P6opaque computes for the Code class. */
typedef struct {
    PMC    *st;                 /* S-table, though we don't care about that here. */
    PMC    *sc;                 /* Serialization context, though we don't care about that here. */
    PMC    *_do;                /* Lower-level code object. */
    PMC    *signature;          /* Signature object. */
    PMC    *compstuff;          /* Place for the compiler to hang stuff */
    PMC    *phasers;            /* Hash mapping phaser names to lists of phasers. */
    PMC    *dispatchees;        /* List of dispatchees, if any. */
    PMC    *dispatcher_cache;   /* Holder for any dispatcher cache. */
    PMC    *dispatcher;         /* The parent dispatcher, if any. */
    INTVAL  rw;                 /* Is it rw? */
} Rakudo_Code;

/* 
 * ALREADY_CHECKED can be flagged on a CallContext, and indicates that we have
 * determined that all of the arguments can be bound to positional parameters
 * without any further type checking (because the multi-dispatch told us so).
 */
#define PObj_P6BINDER_ALREADY_CHECKED_FLAG PObj_private0_FLAG

/* 
 * CHECKING_PRE flags that we are currently checking pre-conditions. If we
 * get an exception during this, it suppresses running of various other
 * phasers.
 */
#define PObj_P6_CHECKING_PRE_FLAG PObj_private0_FLAG

/* Flags that the block has state variables and that this is the first time
 * that we are visiting the block and so they need initializing. */
#define PObj_P6LEXPAD_STATE_INIT_FLAG PObj_private1_FLAG
#define PObj_SUB_FIRST_FLAG PObj_private7_FLAG

/* Gets the ID of a 6model object PMC. */
INTVAL Rakudo_smo_id(void);

/* Checks that a PMC is a nqp native list */
INTVAL Rakudo_isnqplist(PMC *);

/* Functions we want to share to provide the interface to the binder. */
INTVAL Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc,
                    PMC *capture, INTVAL no_nom_type_check,
                    STRING **error);
void Rakudo_binder_set_top_type(PMC *type);
PMC * Rakudo_binder_get_top_type(void);
void Rakudo_binder_set_junction_type(PMC *type);
PMC * Rakudo_binder_get_junction_type(void);
/* for perl6.ops */
PMC * Rakudo_binding_parcel_from_rpa(PARROT_INTERP, PMC *rpa, PMC *fill);
PMC * Rakudo_binding_iter_from_rpa(PARROT_INTERP, PMC *rpa, PMC *list);
PMC * Rakudo_binding_list_from_rpa(PARROT_INTERP, PMC *rpa, PMC *type, PMC *flat);

/* Things Rakudo_binding_bind_llsig may return to indicate a problem. */
#define BIND_RESULT_OK       0
#define BIND_RESULT_FAIL     1
#define BIND_RESULT_JUNCTION 2

/* The value we're going to bind. */
#define BIND_VAL_INT 1
#define BIND_VAL_NUM 2
#define BIND_VAL_STR 3
#define BIND_VAL_OBJ 4
typedef struct {    
    union {
        PMC      *o;
        INTVAL    i;
        FLOATVAL  n;
        STRING   *s;
    } val;
    char type;
} Rakudo_BindVal;

/* Nabbed from Parrot, since it's not exposed and it's the only way
 * (so far as I can tell) to get at the underlying primitive type
 * being passed. */
typedef struct Pcc_cell
{
    union u {
        PMC     *p;
        STRING  *s;
        INTVAL   i;
        FLOATVAL n;
    } u;
    INTVAL type;
} Pcc_cell;

/* Compile time trial binding function and result flags. */
#define TRIAL_BIND_NOT_SURE  0   /* Plausible, but need to check at runtime. */
#define TRIAL_BIND_OK        1   /* Bind will always work out. */
#define TRIAL_BIND_NO_WAY   -1   /* Bind could never work out. */
INTVAL Rakudo_binding_trial_bind(PARROT_INTERP, PMC *sig_pmc, PMC *capture);
rakudo-2013.12/src/vm/parrot/guts/container.c0000664000175000017500000002077412224263172020446 0ustar  moritzmoritz#define PARROT_IN_EXTENSION
#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "container.h"
#include "sixmodelobject.h"
#include "bind.h"
#include "exceptions.h"
#include "types.h"

static PMC *scalar_type = NULL;
void Rakudo_cont_set_scalar_type(PMC *type) { scalar_type = type; }

/* Grabs obj.HOW.name(obj) so we can display type name in error. */
static STRING * type_name(PARROT_INTERP, PMC *obj) {
    PMC *how     = STABLE(obj)->HOW;
    PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
    PMC *meth    = VTABLE_find_method(interp, how, Parrot_str_new(interp, "name", 0));
    PMC *cappy   = Parrot_pmc_new(interp, enum_class_CallContext);
    VTABLE_push_pmc(interp, cappy, how);
    VTABLE_push_pmc(interp, cappy, obj);
    Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
    cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
    Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
    return VTABLE_get_string_keyed_int(interp, cappy, 0);
}

static PMC * rakudo_scalar_fetch(PARROT_INTERP, PMC *cont) {
    return ((Rakudo_Scalar *)PMC_data(cont))->value;
}

static void rakudo_scalar_store(PARROT_INTERP, PMC *cont, PMC *value) {
    Rakudo_Scalar *scalar = (Rakudo_Scalar *)PMC_data(cont);
    INTVAL rw = 0;
    INTVAL ok = 0;

    if (!PMC_IS_NULL(scalar->descriptor))
        rw = ((Rakudo_ContainerDescriptor *)PMC_data(scalar->descriptor))->rw;
    if (!rw) {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Cannot assign to a readonly variable or a value");
    }

    if (!PMC_IS_NULL(scalar->descriptor)) {
        Rakudo_ContainerDescriptor *desc = ((Rakudo_ContainerDescriptor *)PMC_data(scalar->descriptor));
        if ( STABLE(value)->WHAT == Rakudo_types_nil_get() ) {
            value = desc->the_default;
        }
        else {
            ok = STABLE(value)->type_check(interp, value, desc->of);
            if (!ok) {
                PMC *thrower = Rakudo_get_thrower(interp, "X::TypeCheck::Assignment");
                if PMC_IS_NULL(thrower)
                    Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                        "Type check failed in assignment to '%S'; expected '%S' but got '%S'",
                        desc->name, type_name(interp, desc->of), type_name(interp, value));
                else
                    Parrot_pcc_invoke_sub_from_c_args(interp, thrower,
                            "SPP->", desc->name, value, desc->of);
            }
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Type check failed in assignment");
    }

    if (!PMC_IS_NULL(scalar->whence)) {
        PMC *cappy = Parrot_pmc_new(interp, enum_class_CallContext);
        Parrot_pcc_invoke_from_sig_object(interp, scalar->whence, cappy);
        scalar->whence = PMCNULL;
    }
    
    /* If we get here, all is fine; store the value. */
    scalar->value = value;
    PARROT_GC_WRITE_BARRIER(interp, cont);
}

static void rakudo_scalar_store_unchecked(PARROT_INTERP, PMC *cont, PMC *value) {
    Rakudo_Scalar *scalar = (Rakudo_Scalar *)PMC_data(cont);

    if (!PMC_IS_NULL(scalar->whence)) {
        PMC *cappy = Parrot_pmc_new(interp, enum_class_CallContext);
        Parrot_pcc_invoke_from_sig_object(interp, scalar->whence, cappy);
        scalar->whence = PMCNULL;
    }
    
    /* If we get here, all is fine; store the value. */
    scalar->value = value;
    PARROT_GC_WRITE_BARRIER(interp, cont);
}

static void rakudo_scalar_gc_mark_data(PARROT_INTERP, STable *st) {
    /* No data to mark. */
}

static void rakudo_scalar_gc_free_data(PARROT_INTERP, STable *st) {
    /* No data to free. */
}

static void rakudo_scalar_serialize(PARROT_INTERP, STable *st, SerializationWriter *writer) {
    /* No data to serialize. */
}
    
static void rakudo_scalar_deserialize(PARROT_INTERP, STable *st, SerializationReader *reader) {
    /* No data to deserialize. */
}

static ContainerSpec *rakudo_scalar_spec = NULL;

static void rakudo_scalar_set_container_spec(PARROT_INTERP, STable *st) {
    st->container_data = NULL;
    st->container_spec = rakudo_scalar_spec;
}
    
static void rakudo_scalar_configure_container_spec(PARROT_INTERP, STable *st, PMC *config) {
    /* Nothing to configure here. */
}

/* Sets up the container specification for Rakudo's container handling. */
void Rakudo_cont_register(PARROT_INTERP) {
    ContainerConfigurer *cc = mem_sys_allocate(sizeof(ContainerConfigurer));
    
    rakudo_scalar_spec = mem_sys_allocate(sizeof(ContainerSpec));
    rakudo_scalar_spec->name = Parrot_str_new_constant(interp, "rakudo_scalar");
    rakudo_scalar_spec->fetch = rakudo_scalar_fetch;
    rakudo_scalar_spec->store = rakudo_scalar_store;
    rakudo_scalar_spec->store_unchecked = rakudo_scalar_store_unchecked;
    rakudo_scalar_spec->gc_mark_data = rakudo_scalar_gc_mark_data;
    rakudo_scalar_spec->gc_free_data = rakudo_scalar_gc_free_data;
    rakudo_scalar_spec->serialize = rakudo_scalar_serialize;
    rakudo_scalar_spec->deserialize = rakudo_scalar_deserialize;
    
    cc->set_container_spec = rakudo_scalar_set_container_spec;
    cc->configure_container_spec = rakudo_scalar_configure_container_spec;
    
    REGISTER_DYNAMIC_CONTAINER_CONFIG(interp,
        Parrot_str_new_constant(interp, "rakudo_scalar"),
        cc);
}

/* Function wrapper around DECONT macro; potentially can go away at some
 * point. */
PMC *Rakudo_cont_decontainerize(PARROT_INTERP, PMC *var) {
    return DECONT(interp, var);
}

/* Perl 6 storage semantics. If it's a container, just use the container
 * protocol to handle it. Otherwise, fall back to calling a STORE
 * method. */
void Rakudo_cont_store(PARROT_INTERP, PMC *cont, PMC *value,
                       INTVAL type_check, INTVAL rw_check) {
    ContainerSpec *spec = STABLE(cont)->container_spec;
    if (spec) {
        /* Ensure the value we're storing is a 6model type. */
        if (value->vtable->base_type != Rakudo_smo_id())
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Cannot assign a non-Perl 6 value to a Perl 6 container");
        
        if (type_check || rw_check)
            spec->store(interp, cont, DECONT(interp, value));
        else
            spec->store_unchecked(interp, cont, DECONT(interp, value));
    }
    else {
        PMC *meth = VTABLE_find_method(interp, cont, Parrot_str_new(interp, "STORE", 0));
        if (!PMC_IS_NULL(meth)) {
            PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            PMC *cappy   = Parrot_pmc_new(interp, enum_class_CallContext);
            VTABLE_push_pmc(interp, cappy, cont);
            VTABLE_push_pmc(interp, cappy, value);
            Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
            Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
        }
        else {
            PMC * thrower = Rakudo_get_thrower(interp, "X::Assignment::RO");
            if (PMC_IS_NULL(thrower))
                Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                    "Cannot assign to a non-container");
            else
                Parrot_pcc_invoke_sub_from_c_args(interp, thrower, "->");
        }
    }
}

/* Checks if the thing we have is a rw scalar. */
INTVAL Rakudo_cont_is_rw_scalar(PARROT_INTERP, PMC *check) {
    if (IS_CONCRETE(check) && STABLE(check)->WHAT == scalar_type) {
        Rakudo_Scalar *scalar = (Rakudo_Scalar *)PMC_data(check);
        if (!PMC_IS_NULL(scalar->descriptor))
            return ((Rakudo_ContainerDescriptor *)PMC_data(scalar->descriptor))->rw;
    }
    return 0;
}

/* Creates a new Scalar container with the associated container
 * descriptor. */
PMC * Rakudo_cont_scalar_from_descriptor(PARROT_INTERP, PMC *descriptor) {
    PMC *new_scalar = REPR(scalar_type)->allocate(interp, STABLE(scalar_type));
    REPR(new_scalar)->initialize(interp, STABLE(new_scalar), OBJECT_BODY(new_scalar));
    ((Rakudo_Scalar *)PMC_data(new_scalar))->descriptor = descriptor;
    PARROT_GC_WRITE_BARRIER(interp, new_scalar);
    return new_scalar;
}

/* Creates a new Scalar container with the associated container
 * descriptor. */
PMC * Rakudo_cont_scalar_with_value_no_descriptor(PARROT_INTERP, PMC *value) {
    PMC *new_scalar = REPR(scalar_type)->allocate(interp, STABLE(scalar_type));
    REPR(new_scalar)->initialize(interp, STABLE(new_scalar), OBJECT_BODY(new_scalar));
    ((Rakudo_Scalar *)PMC_data(new_scalar))->value = value;
    PARROT_GC_WRITE_BARRIER(interp, new_scalar);
    return new_scalar;
}
rakudo-2013.12/src/vm/parrot/guts/container.h0000664000175000017500000000312312224263172020440 0ustar  moritzmoritz/* The ContainerDescriptor class. Depends on P6opaque object layout. */
typedef struct {
    PMC    *st;                 /* S-table, though we don't care about that here. */
    PMC    *sc;                 /* Serialization context, though we don't care about that here. */
    PMC    *of;                 /* Type of value. */
    INTVAL  rw;                 /* Non-zero if we can write. */
    STRING *name;               /* The name of the container, if any. */
    PMC    *the_default;        /* The default value if any. */
    INTVAL *is_dynamic;         /* The container is dynamically visible */
} Rakudo_ContainerDescriptor;

/* The Scalar class. Depends on P6opaque object layout. */
typedef struct {
    PMC    *st;                 /* S-table, though we don't care about that here. */
    PMC    *sc;                 /* Serialization context, though we don't care about that here. */
    PMC    *descriptor;         /* Container descriptor. */
    PMC    *value;              /* The currently held value. */
    PMC    *whence;             /* Any whence property */
} Rakudo_Scalar;

/* Various functions related to container manipulations. */
void Rakudo_cont_set_scalar_type(PMC *type);
void Rakudo_cont_register(PARROT_INTERP);
PMC * Rakudo_cont_decontainerize(PARROT_INTERP, PMC *var);
void Rakudo_cont_store(PARROT_INTERP, PMC *cont, PMC *value, INTVAL type_check, INTVAL rw_check);
PMC * Rakudo_cont_scalar_from_descriptor(PARROT_INTERP, PMC *container_descriptor);
PMC * Rakudo_cont_scalar_with_value_no_descriptor(PARROT_INTERP, PMC *value);
INTVAL Rakudo_cont_is_rw_scalar(PARROT_INTERP, PMC *check);
rakudo-2013.12/src/vm/parrot/guts/exceptions.c0000664000175000017500000000111412224263172020630 0ustar  moritzmoritz#define PARROT_IN_EXTENSION
#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "exceptions.h"
PMC * Rakudo_get_thrower(PARROT_INTERP, const char * name) {
        PMC * const hll_ns = Parrot_hll_get_ctx_HLL_namespace(interp);
        PMC * const ex_hash = Parrot_ns_find_namespace_global(interp,
                    hll_ns, Parrot_str_new_constant(interp, "P6EX"));
        PMC * const thrower = PMC_IS_NULL(ex_hash)
            ? PMCNULL
            : VTABLE_get_pmc_keyed_str(interp,
                    ex_hash, Parrot_str_new(interp, name, 0));
        return thrower;
}

rakudo-2013.12/src/vm/parrot/guts/exceptions.h0000664000175000017500000000007412224263172020641 0ustar  moritzmoritzPMC * Rakudo_get_thrower(PARROT_INTERP, const char * name);
rakudo-2013.12/src/vm/parrot/guts/serialization.h0000664000175000017500000001301412224263172021333 0ustar  moritzmoritz/* This represents the root of the serialization data; everything hangs
 * off this. In read mode, we don't do much besides populate and then
 * read this. In write mode, however, the tables and data chunks will be
 * filled out and grown as needed. */
typedef struct {
    /* The version of the serialization format. */
    Parrot_Int4   version;

    /* The number of dependencies, as well as a pointer to the
     * dependencies table. */
    Parrot_Int4   num_dependencies;
    char         *dependencies_table;
    
    /* The SC we're serializing/deserializing. */
    PMC          *sc;

    /* List of the serialization context objects that we depend on. */
    PMC          *dependent_scs;
    
    /* The number of STables, as well as pointers to the STables
     * table and data chunk. */
    Parrot_Int4   num_stables;
    char         *stables_table;
    char         *stables_data;
    
    /* The number of objects, as well as pointers to the objects
     * table and data chunk. */
    Parrot_Int4   num_objects;
    char         *objects_table;
    char         *objects_data;
    
    /* The number of closures, as we as a pointer to the closures
     * table. */
    Parrot_Int4  num_closures;
    char        *closures_table;
    
    /* The number of contexts (e.g. lexpads), as well as pointers
     * to the contexts table and data chunk. */
    Parrot_Int4   num_contexts;
    char         *contexts_table;
    char         *contexts_data;
    
    /* Array of STRINGs. */
    PMC          *string_heap;
} SerializationRoot;

/* Represents the serialization reader and the various functions available
 * on it. */
typedef struct SixModel_STable STable;
typedef struct SerializationReader {
    /* Serialization root data. */
    SerializationRoot root;
    
    /* The stables, objects code refs and contexts lists we're deserializing
     * things into. */
    PMC *stables_list;
    PMC *objects_list;
    PMC *codes_list;
    PMC *contexts_list;
    
    /* Current offsets for the data chunks (also correspond to the amount of
     * data written in to them). */
    Parrot_Int4 stables_data_offset;
    Parrot_Int4 objects_data_offset;
    Parrot_Int4 contexts_data_offset;
    
    /* Limits up to where we can read stables, objects and contexts data. */
    char *stables_data_end;
    char *objects_data_end;
    char *contexts_data_end;
    
    /* Where to find details related to the current buffer we're reading from:
     * the buffer pointer itself, the current offset and the amount that is
     * allocated. These are all pointers back into this data structure. */
    char        **cur_read_buffer;
    Parrot_Int4  *cur_read_offset;
    char        **cur_read_end;
    
    /* Various reading functions. */
    INTVAL   (*read_int) (PARROT_INTERP, struct SerializationReader *reader);
    FLOATVAL (*read_num) (PARROT_INTERP, struct SerializationReader *reader);
    STRING * (*read_str) (PARROT_INTERP, struct SerializationReader *reader);
    PMC *    (*read_ref) (PARROT_INTERP, struct SerializationReader *reader);
    STable * (*read_stable_ref) (PARROT_INTERP, struct SerializationReader *reader);
    
    /* The data, which we'll want to free after deserialization. */
    char *data;
} SerializationReader;

/* Represents the serialization writer and the various functions available
 * on it. */
typedef struct SerializationWriter {
    /* Serialization root data. */
    SerializationRoot root;
    
    /* The stables, objects, code refs and contexts lists we're working
     * through/adding to. */
    PMC *stables_list;
    PMC *objects_list;
    PMC *codes_list;
    PMC *contexts_list;
    
    /* Current position in the stables, objects and contexts lists. */
    INTVAL stables_list_pos;
    INTVAL objects_list_pos;
    INTVAL contexts_list_pos;

    /* Hash of strings we've already seen while serializing to the index they
     * are placed at in the string heap. */
    PMC *seen_strings;
    
    /* Amount of memory allocated for various things. */
    Parrot_Int4 dependencies_table_alloc;
    Parrot_Int4 stables_table_alloc;
    Parrot_Int4 stables_data_alloc;
    Parrot_Int4 objects_table_alloc;
    Parrot_Int4 objects_data_alloc;
    Parrot_Int4 closures_table_alloc;
    Parrot_Int4 contexts_table_alloc;
    Parrot_Int4 contexts_data_alloc;
    
    /* Current offsets for the data chunks (also correspond to the amount of
     * data written in to them). */
    Parrot_Int4 stables_data_offset;
    Parrot_Int4 objects_data_offset;
    Parrot_Int4 contexts_data_offset;
    
    /* Where to find details related to the current buffer we're writing in
     * to: the buffer pointer itself, the current offset and the amount that
     * is allocated. These are all pointers back into this data structure. */
    char        **cur_write_buffer;
    Parrot_Int4  *cur_write_offset;
    Parrot_Int4  *cur_write_limit;
    
    /* Various writing functions. */
    void (*write_int) (PARROT_INTERP, struct SerializationWriter *writer, INTVAL value);
    void (*write_num) (PARROT_INTERP, struct SerializationWriter *writer, FLOATVAL value);
    void (*write_str) (PARROT_INTERP, struct SerializationWriter *writer, STRING *value);
    void (*write_ref) (PARROT_INTERP, struct SerializationWriter *writer, PMC *value);
    void (*write_stable_ref) (PARROT_INTERP, struct SerializationWriter *writer, STable *st);
} SerializationWriter;

/* Core serialize and deserialize functions. */
STRING * Serialization_serialize(PARROT_INTERP, PMC *sc, PMC *empty_string_heap);
void Serialization_deserialize(PARROT_INTERP, PMC *sc, PMC *string_heap, PMC *codes_static, STRING *data);
rakudo-2013.12/src/vm/parrot/guts/sixmodelobject.h0000664000175000017500000005171412224263172021502 0ustar  moritzmoritz/* This file contains various structure definitions for the 6model object
 * meta-model implementation. */

#ifndef SIXMODELOBJECT_H_GUARD
#define SIXMODELOBJECT_H_GUARD

#include "storage_spec.h"
#include "serialization.h"

/* The commonalities shared between all 6model objects, no matter what the
 * REPR is. This struct should be placed as the first thing in the object
 * struct used by all representations. */
typedef struct {
    PMC *stable;  /* The shared table. */
    PMC *sc;      /* Serialization context. */
} SixModelObjectCommonalities;

/* An example object, mostly used to compute the offset of the data part of
 * a 6model object. */
typedef struct {
    SixModelObjectCommonalities common;
    void *data;
} SixModelObjectStooge;

/* This is used to identify an attribute for various types of cache. */
typedef struct {
    PMC    *class_handle;   /* Class handle */
    STRING *attr_name;      /* Name of the attribute. */
    INTVAL  hint;           /* Hint for use in static/gradual typing. */
} AttributeIdentifier;

/* Container specification information, for types that serve as containers.
 * A container is something that can be assigned into. It may be some kind
 * of container object (like Perl 6's Scalar) or it may be a reference to a
 * native lexical or object field. The function table determines the way it
 * behaves. */
typedef struct {
    /* Fetches a value out of a container. Used for decontainerization. */
    PMC * (*fetch) (PARROT_INTERP, PMC *cont);
    
    /* Stores a value in a container. Used for assignment. */
    void (*store) (PARROT_INTERP, PMC *cont, PMC *obj);
    
    /* Stores a value in a container, without any checking of it (this
     * assumes an optimizer or something else already did it). Used for
     * assignment. */
    void (*store_unchecked) (PARROT_INTERP, PMC *cont, PMC *obj);
    
    /* Name of this container specification. */
    STRING *name;
    
    /* Marks container data, if any. */
    void (*gc_mark_data) (PARROT_INTERP, STable *st);

    /* Frees container data, if any. */
    void (*gc_free_data) (PARROT_INTERP, STable *st);
    
    /* Serializes the container data, if any. */
    void (*serialize) (PARROT_INTERP, STable *st, SerializationWriter *writer);
    
    /* Deserializes the container data, if any. */
    void (*deserialize) (PARROT_INTERP, STable *st, SerializationReader *reader);
} ContainerSpec;

/* A container configurer knows how to attach a certain type of container
 * to an STable and configure it. */
typedef struct {
    /* Sets this container spec in place for the specified STable. */ 
    void (*set_container_spec) (PARROT_INTERP, STable *st);
    
    /* Configures the container spec with the specified info. */
    void (*configure_container_spec) (PARROT_INTERP, STable *st, PMC *config);
} ContainerConfigurer;

/* How do we invoke this thing? Specifies either an attribute to look at for
 * an invokable thing, or alternatively a method to call. */
typedef struct {
    AttributeIdentifier  value_slot;
    PMC                 *invocation_handler;
} InvocationSpec;

/* How do we turn something of this type into a boolean? */
typedef struct {
    INTVAL mode;
    PMC *  method;
} BoolificationSpec;

/* Defines and struct we use to access inlined members. */
#define NATIVE_VALUE_INT    1
#define NATIVE_VALUE_FLOAT  2
#define NATIVE_VALUE_STRING 3

typedef struct {
    union {
        INTVAL    intval;
        FLOATVAL  floatval;
        STRING   *stringval;
    } value;
    INTVAL type;
} NativeValue;

/* Boolification mode flags. */
#define BOOL_MODE_CALL_METHOD                   0
#define BOOL_MODE_UNBOX_INT                     1
#define BOOL_MODE_UNBOX_NUM                     2
#define BOOL_MODE_UNBOX_STR_NOT_EMPTY           3
#define BOOL_MODE_UNBOX_STR_NOT_EMPTY_OR_ZERO   4
#define BOOL_MODE_NOT_TYPE_OBJECT               5
#define BOOL_MODE_BIGINT                        6

/* Controls the way that type checks are performed. By default, if there is
 * a type check cache we treat it as definitive. However, it's possible to
 * declare that in the case the type check cache has no entry we should fall
 * back to asking the .HOW.type_check method (set TYPE_CHECK_CACHE_THEN_METHOD).
 * While a normal type check asks a value if it supports another type, the
 * TYPE_CHECK_NEEDS_ACCEPTS flag results in a call to .accepts_type on the
 * HOW of the thing we're checking the value against, giving it a chance to
 * decide answer. */
#define TYPE_CHECK_CACHE_DEFINITIVE    0
#define TYPE_CHECK_CACHE_THEN_METHOD   1
#define TYPE_CHECK_NEEDS_ACCEPTS       2
#define TYPE_CHECK_CACHE_FLAG_MASK     3

/* This flag is set if we consider the method cche authoritative. */
#define METHOD_CACHE_AUTHORITATIVE     4

/* HLL type roles. */
#define HLL_ROLE_NONE       0
#define HLL_ROLE_INT        1
#define HLL_ROLE_NUM        2
#define HLL_ROLE_STR        3
#define HLL_ROLE_ARRAY      4
#define HLL_ROLE_HASH       5
#define HLL_ROLE_CODE       6

/* S-Tables (short for Shared Table) contains the commonalities shared between
 * a (HOW, REPR) pairing (for example, (HOW for the class Dog, P6Opaque). */
typedef struct SixModel_REPROps REPROps;
struct SixModel_STable {
    /* The representation operation table. */
    REPROps *REPR;
    
    /* Any data specific to this type that the REPR wants to keep. */
    void *REPR_data;

    /* The meta-object. */
    PMC *HOW;

    /* The type-object. */
    PMC *WHAT;

    /* The method finder. */
    PMC * (*find_method) (PARROT_INTERP, PMC *obj, STRING *name, INTVAL hint);

    /* By-name method dispatch cache. */
    PMC *method_cache;

    /* The computed v-table for static dispatch. */
    PMC **vtable;

    /* The length of the v-table. */
    INTVAL vtable_length;

    /* The type checker. */
    INTVAL (*type_check) (PARROT_INTERP, PMC *obj, PMC *checkee);

    /* Array of type objects. If this is set, then it is expected to contain
     * the type objects of all types that this type is equivalent to (e.g.
     * all the things it isa and all the things it does). */
    PMC **type_check_cache;

    /* The length of the type check cache. */
    INTVAL type_check_cache_length;
    
    /* The type checking mode and method cache mode (see flags for this
     * above). */
    INTVAL mode_flags;

    /* An ID solely for use in caches that last a VM instance. Thus it
     * should never, ever be serialized and you should NEVER make a
     * type directory based upon this ID. Otherwise you'll create memory
     * leaks for anonymous types, and other such screwups. */
    INTVAL type_cache_id;
    
    /* If this is a container, then this contains information needed in
     * order to fetch the value in it or assign a value to it. If not,
     * it'll be null, which can be taken as a "not a container" indication. */
    ContainerSpec *container_spec;
    
    /* Data that the container spec may need to function. */
    /* Any data specific to this type that the REPR wants to keep. */
    void *container_data;
    
    /* If this is invokable, then this contains information needed to
     * figure out how to invoke it. If not, it'll be null. */
    InvocationSpec *invocation_spec;
    
    /* Information - if any - about how we can turn something of this type
     * into a boolean. */
    BoolificationSpec *boolification_spec;
    
    /* The underlying package stash. */
    PMC *WHO;
    
    /* Serialization context that this s-table belongs to. */
    PMC *sc;

    /* Parrot-specific set of v-table to method mappings, for overriding
     * of Parrot v-table functions. */
    PMC **parrot_vtable_mapping;

	/* Parrot-specific set of v-table to object method mappings. */
	AttributeIdentifier *parrot_vtable_handler_mapping;
    
    /* The PMC that wraps this s-table. */
    PMC *stable_pmc;
    
    /* The HLL that this type is owned by, if any. */
    INTVAL hll_owner;
    
    /* The role that the type plays in the HLL, if any. */
    INTVAL hll_role;
};

/* A representation is what controls the layout of an object and access and
 * manipulation of the memory it manages. This includes attribute storage
 * for objects in the usual OO sense. However, representations may also
 * represent other things, such as pointers and arrays.
 *
 * The following structs define the representation API. There are some
 * things that all representations have. There are some others that a
 * representation will only implement if it plays that "role".*/
typedef struct SixModel_REPROps_Attribute {
    /* Gets the current value for an object attribute. For non-flattened
     * objects - that is, reference types - this just returns the object
     * stored in the attribute. For the flattened case, this will auto-box. */
    PMC * (*get_attribute_boxed) (PARROT_INTERP, STable *st, void *data,
        PMC *class_handle, STRING *name, INTVAL hint);

    /* Fetch the value of the attribute into the value struct. The caller sets
     * the type field of value to the type requested, and it's the caller's
     * responsibility to make sure this is compatible with the stored
     * attribute. */
    void (*get_attribute_native) (PARROT_INTERP, STable *st, void *data,
        PMC *class_handle, STRING *name, INTVAL hint, NativeValue *value);

    /* Binds the given object value to the specified attribute. If it's
     * a reference type attribute, this just simply sets the value in 
     * place. If instead it's some other flattened in representation, then
     * the value should be a boxed form of the data to store.*/
    void (*bind_attribute_boxed) (PARROT_INTERP, STable *st, void *data,
        PMC *class_handle, STRING *name, INTVAL hint, PMC *value);

    /* Set the value of a flattened attribute. It is the caller's
     * responsibility to set value to a type compatible with the type of the
     * attribute being set. */
    void (*bind_attribute_native) (PARROT_INTERP, STable *st, void *data,
        PMC *class_handle, STRING *name, INTVAL hint, NativeValue *value);

    /* Gets the hint for the given attribute ID. */
    INTVAL (*hint_for) (PARROT_INTERP, STable *st, PMC *class_handle, STRING *name);

    /* Checks if an attribute has been initialized. */
    INTVAL (*is_attribute_initialized) (PARROT_INTERP, STable *st, void *data,
        PMC *class_handle, STRING *name, INTVAL hint);
} REPROps_Attribute;
typedef struct SixModel_REPROps_Boxing {
    /* Used with boxing. Sets an integer value, for representations that
     * can hold one. */
    void (*set_int) (PARROT_INTERP, STable *st, void *data, INTVAL value);

    /* Used with boxing. Gets an integer value, for representations that
     * can hold one. */
    INTVAL (*get_int) (PARROT_INTERP, STable *st, void *data);

    /* Used with boxing. Sets a floating point value, for representations that
     * can hold one. */
    void (*set_num) (PARROT_INTERP, STable *st, void *data, FLOATVAL value);

    /* Used with boxing. Gets a floating point value, for representations that
     * can hold one. */
    FLOATVAL (*get_num) (PARROT_INTERP, STable *st, void *data);

    /* Used with boxing. Sets a string value, for representations that
     * can hold one. */
    void (*set_str) (PARROT_INTERP, STable *st, void *data, STRING *value);

    /* Used with boxing. Gets a string value, for representations that
     * can hold one. */
    STRING * (*get_str) (PARROT_INTERP, STable *st, void *data);

    /* Some objects serve primarily as boxes of others, inlining them. This gets
     * gets the reference to such things, using the representation ID to distinguish
     * them. */
    void * (*get_boxed_ref) (PARROT_INTERP, STable *st, void *data, INTVAL repr_id);
} REPROps_Boxing;
typedef struct SixModel_REPROps_Positional {
    /* Get a flattened native value, of the type specified in value->type. It
     * is the caller's responsibility to make sure the stored data is of the
     * appropriate type. May throw to indicate out of bounds, or vivify. */
    void (*at_pos_native) (PARROT_INTERP, STable *st, void *data, INTVAL index, NativeValue *value);

    /* Get a boxed object representing the element at the specified position. If the
     * object is already a reference type, simply returns that. */
    PMC * (*at_pos_boxed) (PARROT_INTERP, STable *st, void *data, INTVAL index);

    /* Sets the value at the specified index of the array. May auto-vivify or throw. */
    void (*bind_pos_native) (PARROT_INTERP, STable *st, void *data, INTVAL index, NativeValue *value);

    /* Binds the object at the specified address into the array at the specified index.
     * For arrays of non-reference types, expects a compatible type. */
    void (*bind_pos_boxed) (PARROT_INTERP, STable *st, void *data, INTVAL index, PMC *obj);
    
    /* Pushes an object. */
    void (*push_boxed) (PARROT_INTERP, STable *st, void *data, PMC *obj);
    
    /* Pops an object. */
    PMC * (*pop_boxed) (PARROT_INTERP, STable *st, void *data);
    
    /* Unshifts an object. */
    void (*unshift_boxed) (PARROT_INTERP, STable *st, void *data, PMC *obj);
    
    /* Shifts an object. */
    PMC * (*shift_boxed) (PARROT_INTERP, STable *st, void *data);
    
    /* Gets the STable representing the declared element type. */
    STable * (*get_elem_stable) (PARROT_INTERP, STable *st);
} REPROps_Positional;
typedef struct SixModel_REPROps_Associative {
    /* Gets the value at the specified key. */
    PMC * (*at_key_boxed) (PARROT_INTERP, STable *st, void *data, STRING *key);
    
    /* Binds a value to the specified key. */
    void (*bind_key_boxed) (PARROT_INTERP, STable *st, void *data, STRING *key, PMC *value);
    
    /* Checks if the specified key exists. */
    INTVAL (*exists_key) (PARROT_INTERP, STable *st, void *data, STRING *key);
    
    /* Deletes the specified key. */
    void (*delete_key) (PARROT_INTERP, STable *st, void *data, STRING *key);
} REPROps_Associative;
struct SixModel_REPROps {
    /* Creates a new type object of this representation, and
     * associates it with the given HOW. Also sets up a new
     * representation instance if needed. */
    PMC * (*type_object_for) (PARROT_INTERP, PMC *HOW);

    /* Composes the representation, passing any composition info. This
     * is the way a meta-object provides configuration to a REPR, which
     * it may then use to do layout, etc. */
    void (*compose) (PARROT_INTERP, STable *st, PMC *repr_info);

    /* Allocates a new, but uninitialized object, based on the
     * specified s-table. */
    PMC * (*allocate) (PARROT_INTERP, STable *st);

    /* Used to initialize the body of an object representing the type
     * describe by the specified s-table. DATA points to the body. It
     * may recursively call initialize for any flattened objects. */
    void (*initialize) (PARROT_INTERP, STable *st, void *data);
    
    /* For the given type, copies the object data from the source memory
     * location to the destination one. Note that it may actually be more
     * involved than a straightforward bit of copying; what's important is
     * that the representation knows about that. Note that it may have to
     * call copy_to recursively on representations of any flattened objects
     * within its body. */
    void (*copy_to) (PARROT_INTERP, STable *st, void *src, void *dest);

    /* Attribute access REPR function table. */
    struct SixModel_REPROps_Attribute *attr_funcs;
    
    /* Boxing REPR function table. */
    struct SixModel_REPROps_Boxing *box_funcs;

    /* Positional REPR function table. */
    struct SixModel_REPROps_Positional *pos_funcs;

    /* Associative REPR function table. */
    struct SixModel_REPROps_Associative *ass_funcs;
    
    /* Gets the number of elements, if it's relevant. */
    INTVAL (*elems) (PARROT_INTERP, STable *st, void *data);
    
    /* Gets the storage specification for this representation. */
    storage_spec (*get_storage_spec) (PARROT_INTERP, STable *st);
    
    /* Handles an object changing its type. The representation is responsible
     * for doing any changes to the underlying data structure, and may reject
     * changes that it's not willing to do (for example, a representation may
     * choose to only handle switching to a subclass). It is also left to update
     * the S-Table pointer as needed; while in theory this could be factored
     * out, the representation probably knows more about timing issues and
     * thread safety requirements. */
    void (*change_type) (PARROT_INTERP, PMC *Object, PMC *NewType);
    
    /* Object serialization. Writes the objects body out using the passed
     * serialization writer. */
    void (*serialize) (PARROT_INTERP, STable *st, void *data, SerializationWriter *writer);
    
    /* Object deserialization. Reads the objects body in using the passed
     * serialization reader. */
    void (*deserialize) (PARROT_INTERP, STable *st, void *data, SerializationReader *reader);
    
    /* REPR data serialization. Seserializes the per-type representation data that
     * is attached to the supplied STable. */
    void (*serialize_repr_data) (PARROT_INTERP, STable *st, SerializationWriter *writer);
    
    /* REPR data deserialization. Deserializes the per-type representation data and
     * attaches it to the supplied STable. */
    void (*deserialize_repr_data) (PARROT_INTERP, STable *st, SerializationReader *reader);
    
    /* This Parrot-specific addition to the API is used to mark an object. */
    void (*gc_mark) (PARROT_INTERP, STable *st, void *data);

    /* This Parrot-specific addition to the API is used to free an object. */
    void (*gc_free) (PARROT_INTERP, PMC *object);

    /* This is called to do any cleanup of resources when an object gets
     * embedded inside another one. Never called on a top-level object. */
    void (*gc_cleanup) (PARROT_INTERP, STable *st, void *data);

    /* This Parrot-specific addition to the API is used to mark a REPR instance. */
    void (*gc_mark_repr_data) (PARROT_INTERP, STable *st);

    /* This Parrot-specific addition to the API is used to free a REPR instance. */
    void (*gc_free_repr_data) (PARROT_INTERP, STable *st);
    
    /* The representation's ID. */
    INTVAL ID;
    
    /* The representation's name. */
    STRING *name;
};

/* Hint value to indicate the absence of an attribute lookup or method
 * dispatch hint. */
#define NO_HINT -1

/* Various handy macros for getting at important stuff. */
#define STABLE_PMC(o)    (((SixModelObjectCommonalities *)PMC_data(o))->stable)
#define STABLE(o)        ((STable *)PMC_data(STABLE_PMC(o)))
#define SC_PMC(o)        (((SixModelObjectCommonalities *)PMC_data(o))->sc)
#define STABLE_STRUCT(p) ((STable *)PMC_data(p))
#define REPR(o)          (STABLE(o)->REPR)
#define OBJECT_BODY(o)   (&(((SixModelObjectStooge *)PMC_data(o))->data))

/* Macro for getting/setting type-objectness. */
#define IS_CONCRETE(o)         (!PObj_flag_TEST(private0, (o)))
#define MARK_AS_TYPE_OBJECT(o) PObj_flag_SET(private0, (o))

/* Macro for decontainerization. */
#define DECONT(interp, o) (IS_CONCRETE(o) && STABLE(o)->container_spec ? \
    STABLE(o)->container_spec->fetch(interp, o) : \
    o)

/* Write barriers for noticing changes to objects or STables with an SC. */
typedef void (* obj_sc_barrier_func) (PARROT_INTERP, PMC *obj);
typedef void (* st_sc_barrier_func) (PARROT_INTERP, STable *st);
#define OBJ_SC_WRITE_BARRIER(o) \
    if (SC_PMC(o)) { \
        ((obj_sc_barrier_func) \
        D2FPTR(VTABLE_get_pointer(interp, \
            VTABLE_get_pmc_keyed_str(interp, interp->root_namespace, \
                Parrot_str_new_constant(interp, "_OBJ_SC_BARRIER")))))(interp, o); \
    }
#define ST_SC_WRITE_BARRIER(st) \
    if ((st)->sc) { \
        ((st_sc_barrier_func) \
        D2FPTR(VTABLE_get_pointer(interp, \
            VTABLE_get_pmc_keyed_str(interp, interp->root_namespace, \
                Parrot_str_new_constant(interp, "_ST_SC_BARRIER")))))(interp, st); \
    }

/* Object model initialization. */
void SixModelObject_initialize(PARROT_INTERP, PMC **knowhow, PMC **knowhow_attribute);

/* Some utility functions. */
void set_wrapping_object(PMC *wrapper);
PMC * wrap_object(PARROT_INTERP, void *obj);
PMC * create_stable(PARROT_INTERP, REPROps *REPR, PMC *HOW);
PMC * decontainerize(PARROT_INTERP, PMC *var);
PMC * get_hll_config(PARROT_INTERP, STRING *hll);
PMC * hllize(PARROT_INTERP, PMC *obj, INTVAL hll_id);

/* Dynamic representation registration. */
typedef PMC * (*wrap_object_t)(PARROT_INTERP, void *obj);
typedef PMC * (*create_stable_t)(PARROT_INTERP, REPROps *REPR, PMC *HOW);
typedef INTVAL (* rf) (PARROT_INTERP, STRING *name, REPROps * (*reg) (PARROT_INTERP, wrap_object_t, create_stable_t));
#define REGISTER_DYNAMIC_REPR(interp, name, reg_func) \
    ((rf) \
        VTABLE_get_pointer(interp, \
            VTABLE_get_pmc_keyed_str(interp, interp->root_namespace, \
                Parrot_str_new_constant(interp, "_REGISTER_REPR"))))(interp, name, reg_func)

/* Dynamic container configuration registration. */
typedef void (*cspec_conf) (PARROT_INTERP, STRING *name, ContainerConfigurer *configurer);
#define REGISTER_DYNAMIC_CONTAINER_CONFIG(interp, name, configurer) \
    ((cspec_conf) \
        VTABLE_get_pointer(interp, \
            VTABLE_get_pmc_keyed_str(interp, interp->root_namespace, \
                Parrot_str_new_constant(interp, "_REGISTER_CONTCONF"))))(interp, name, configurer)

#endif
rakudo-2013.12/src/vm/parrot/guts/storage_spec.h0000664000175000017500000000276412224263172021146 0ustar  moritzmoritz#ifndef STORAGE_SPEC_H_GUARD
#define STORAGE_SPEC_H_GUARD

/* This data structure describes what storage a given representation
 * needs if something of that representation is to be embedded in
 * another place. For any representation that expects to be used
 * as a kind of reference type, it will just want to be a pointer.
 * But for other things, they would prefer to be "inlined" into
 * the object. */
typedef struct {
    /* 0 if this is to be referenced, anything else otherwise. */
    INTVAL inlineable;

    /* For things that want to be inlined, the number of bits of
     * storage they need and what kind of byte-boundary they want to
     * be aligned to. Ignored otherwise. */
    INTVAL bits;
    INTVAL align;

    /* For things that are inlined, if they are just storage of a
     * primitive type and can unbox, this says what primitive type
     * that they unbox to. */
    INTVAL boxed_primitive;
    
    /* The types that this one can box/unbox to. */
    INTVAL can_box;
    
    /* For ints, whether it's an usigned value. */
    INTVAL is_unsigned;
} storage_spec;

/* Inlined or not. */
#define STORAGE_SPEC_REFERENCE  0
#define STORAGE_SPEC_INLINED    1

/* Possible options for boxed primitives. */
#define STORAGE_SPEC_BP_NONE    0
#define STORAGE_SPEC_BP_INT     1
#define STORAGE_SPEC_BP_NUM     2
#define STORAGE_SPEC_BP_STR     3

/* can_box bit field values. */
#define STORAGE_SPEC_CAN_BOX_INT     1
#define STORAGE_SPEC_CAN_BOX_NUM     2
#define STORAGE_SPEC_CAN_BOX_STR     4

#endif
rakudo-2013.12/src/vm/parrot/guts/types.c0000664000175000017500000001357512224263172017631 0ustar  moritzmoritz/* This collects together cached versions of various interesting
 * types that we often want to box to, as well as mapping Parroty
 * types into Perl 6 ones. */
 
#define PARROT_IN_EXTENSION
#include "parrot/parrot.h"
#include "sixmodelobject.h"
#include "types.h"
#include "bind.h"

static PMC * Mu         = NULL;
static PMC * Any        = NULL;
static PMC * Junction   = NULL;
static PMC * Routine    = NULL;
static PMC * Int        = NULL;
static PMC * Num        = NULL;
static PMC * Str        = NULL;
static PMC * Parcel     = NULL;
static PMC * List       = NULL;
static PMC * ListIter   = NULL;
static PMC * Nil        = NULL;
static PMC * Array      = NULL;
static PMC * LoL        = NULL;
static PMC * EnumMap    = NULL;
static PMC * _Hash      = NULL;
static PMC * Capture    = NULL;
static PMC * Code       = NULL;
static PMC * BoolFalse  = NULL;
static PMC * BoolTrue   = NULL;
static PMC * JunctionThreader = NULL;

static INTVAL ownedhash_id = 0;
static INTVAL ownedrpa_id = 0;

void Rakudo_types_mu_set(PMC * type) { Mu = type; }
PMC * Rakudo_types_mu_get(void) { return Mu; }

void Rakudo_types_any_set(PMC * type) { Any = type; }
PMC * Rakudo_types_any_get(void) { return Any; }

void Rakudo_types_junction_set(PMC * type) { Junction = type; }
PMC * Rakudo_types_junction_get(void) { return Junction; }

void Rakudo_types_routine_set(PMC * type) { Routine = type; }
PMC * Rakudo_types_routine_get(void) { return Routine; }

void Rakudo_types_int_set(PMC * type) { Int = type; }
PMC * Rakudo_types_int_get(void) { return Int; }

void Rakudo_types_num_set(PMC * type) { Num = type; }
PMC * Rakudo_types_num_get(void) { return Num; }

void Rakudo_types_str_set(PMC * type) { Str = type; }
PMC * Rakudo_types_str_get(void) { return Str; }

void Rakudo_types_parcel_set(PMC * type) { Parcel = type; }
PMC * Rakudo_types_parcel_get(void) { return Parcel; }

void Rakudo_types_list_set(PMC * type) { List = type; }
PMC * Rakudo_types_list_get(void) { return List; }

void Rakudo_types_listiter_set(PMC * type) { ListIter = type; }
PMC * Rakudo_types_listiter_get(void) { return ListIter; }

void Rakudo_types_nil_set(PMC * type) { Nil = type; }
PMC * Rakudo_types_nil_get(void) { return Nil; }

void Rakudo_types_array_set(PMC * type) { Array = type; }
PMC * Rakudo_types_array_get(void) { return Array; }

void Rakudo_types_lol_set(PMC * type) { LoL = type; }
PMC * Rakudo_types_lol_get(void) { return LoL; }

void Rakudo_types_enummap_set(PMC * type) { EnumMap = type; }
PMC * Rakudo_types_enummap_get(void) { return EnumMap; }

void Rakudo_types_hash_set(PMC * type) { _Hash = type; }
PMC * Rakudo_types_hash_get(void) { return _Hash; }

void Rakudo_types_capture_set(PMC * type) { Capture = type; }
PMC * Rakudo_types_capture_get(void) { return Capture; }

void Rakudo_types_code_set(PMC * type) { Code = type; }
PMC * Rakudo_types_code_get(void) { return Code; }

void Rakudo_types_bool_false_set(PMC * type) { BoolFalse = type; }
PMC * Rakudo_types_bool_false_get(void) { return BoolFalse; }

void Rakudo_types_bool_true_set(PMC * type) { BoolTrue = type; }
PMC * Rakudo_types_bool_true_get(void) { return BoolTrue; }

void Rakudo_types_junction_threader_set(PMC * threader) { JunctionThreader = threader; }
PMC * Rakudo_types_junction_threader_get(void) { return JunctionThreader; }

PMC * Rakudo_types_parrot_map(PARROT_INTERP, PMC * to_map) {
    PMC *result;
    switch (to_map->vtable->base_type) {
        case enum_class_String:
            result = REPR(Str)->allocate(interp, STABLE(Str));
            REPR(result)->initialize(interp, STABLE(result), OBJECT_BODY(result));
            REPR(result)->box_funcs->set_str(interp, STABLE(result), OBJECT_BODY(result), VTABLE_get_string(interp, to_map));
            PARROT_GC_WRITE_BARRIER(interp, result);
            break;
        case enum_class_Integer:
            result = REPR(Int)->allocate(interp, STABLE(Int));
            REPR(result)->initialize(interp, STABLE(result), OBJECT_BODY(result));
            REPR(result)->box_funcs->set_int(interp, STABLE(result), OBJECT_BODY(result), VTABLE_get_integer(interp, to_map));
            break;
        case enum_class_Float:
            result = REPR(Num)->allocate(interp, STABLE(Num));
            REPR(result)->initialize(interp, STABLE(result), OBJECT_BODY(result));
            REPR(result)->box_funcs->set_num(interp, STABLE(result), OBJECT_BODY(result), VTABLE_get_number(interp, to_map));
            break;
        case enum_class_ResizablePMCArray:
            result = Rakudo_binding_parcel_from_rpa(interp, to_map, Mu);
            break;
        case enum_class_Hash:
            result = REPR(_Hash)->allocate(interp, STABLE(_Hash));
            REPR(result)->initialize(interp, STABLE(result), OBJECT_BODY(result));
            VTABLE_set_attr_keyed(interp, result, EnumMap, Parrot_str_new_constant(interp, "$!storage"), to_map);
            break;
        case enum_class_Null:
            result = Mu;
            break;
        default:
            if (ownedhash_id == 0)
                ownedhash_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "OwnedHash", 0));
            if (ownedrpa_id == 0)
                ownedrpa_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "OwnedResizablePMCArray", 0));
            if (Rakudo_isnqplist(to_map)) {
                result = Rakudo_binding_parcel_from_rpa(interp, to_map, Mu);
            }
            else if (to_map->vtable->base_type == ownedhash_id) {
                result = REPR(_Hash)->allocate(interp, STABLE(_Hash));
                REPR(result)->initialize(interp, STABLE(result), OBJECT_BODY(result));
                VTABLE_set_attr_keyed(interp, result, EnumMap, Parrot_str_new_constant(interp, "$!storage"), to_map);
            }
            else if (to_map->vtable->base_type == ownedrpa_id) {
                result = Rakudo_binding_parcel_from_rpa(interp, to_map, Mu);
            }
            else {
                result = to_map;
            }
    }
    return result;
}
rakudo-2013.12/src/vm/parrot/guts/types.h0000664000175000017500000000325512224263172017630 0ustar  moritzmoritz#ifndef TYPES_H_GUARD
#define TYPES_H_GUARD

void Rakudo_types_mu_set(PMC * type);
PMC * Rakudo_types_mu_get(void);

void Rakudo_types_any_set(PMC * type);
PMC * Rakudo_types_any_get(void);

void Rakudo_types_junction_set(PMC * type);
PMC * Rakudo_types_junction_get(void);

void Rakudo_types_routine_set(PMC * type);
PMC * Rakudo_types_routine_get(void);

void Rakudo_types_int_set(PMC * type);
PMC * Rakudo_types_int_get(void);

void Rakudo_types_num_set(PMC * type);
PMC * Rakudo_types_num_get(void);

void Rakudo_types_str_set(PMC * type);
PMC * Rakudo_types_str_get(void);

void Rakudo_types_parcel_set(PMC * type);
PMC * Rakudo_types_parcel_get(void);

void Rakudo_types_list_set(PMC * type);
PMC * Rakudo_types_list_get(void);

void Rakudo_types_listiter_set(PMC * type);
PMC * Rakudo_types_listiter_get(void);

void Rakudo_types_nil_set(PMC * type);
PMC * Rakudo_types_nil_get(void);

void Rakudo_types_array_set(PMC * type);
PMC * Rakudo_types_array_get(void);

void Rakudo_types_lol_set(PMC * type);
PMC * Rakudo_types_lol_get(void);

void Rakudo_types_enummap_set(PMC * type);
PMC * Rakudo_types_enummap_get(void);

void Rakudo_types_hash_set(PMC * type);
PMC * Rakudo_types_hash_get(void);

void Rakudo_types_capture_set(PMC * type);
PMC * Rakudo_types_capture_get(void);

void Rakudo_types_code_set(PMC * type);
PMC * Rakudo_types_code_get(void);

void Rakudo_types_bool_false_set(PMC * type);
PMC * Rakudo_types_bool_false_get(void);

void Rakudo_types_bool_true_set(PMC * type);
PMC * Rakudo_types_bool_true_get(void);

void Rakudo_types_junction_threader_set(PMC * threader);
PMC * Rakudo_types_junction_threader_get(void);

PMC * Rakudo_types_parrot_map(PARROT_INTERP, PMC * to_map);

#endif
rakudo-2013.12/src/vm/parrot/ModuleLoaderVMConfig.nqp0000664000175000017500000001026012255230273022010 0ustar  moritzmoritzrole Perl6::ModuleLoaderVMConfig {
    method vm_search_paths() {
        my %conf := pir::getinterp__P()[pir::const::IGLOBALS_CONFIG_HASH];
        my @search_paths;
        @search_paths.push(%conf ~ %conf ~
            '/languages/perl6/lib');
        # XXX CHEAT: Goes away when we implement :from.
        @search_paths.push(%conf ~ %conf ~
            '/languages/nqp/lib');
        @search_paths
    }
    
    # Locates files we could potentially load for this module.
    method locate_candidates($module_name, @prefixes, :$file) {
        # If its name contains a slash or dot treat is as a path rather than a package name.
        my @candidates;
        if nqp::defined($file) {
            $file := nqp::gethllsym('perl6', 'ModuleLoader').absolute_path($file);
            if nqp::stat($file, 0) {
                my %cand;
                %cand := $file;
                my $dot := nqp::rindex($file, '.');
                my $ext := $dot >= 0 ?? nqp::substr($file, $dot, nqp::chars($file) - $dot) !! '';
                if $ext eq 'pbc' || $ext eq 'pir' {
                    %cand := $file;
                }
                else {
                    %cand := $file;
                }
                @candidates.push(%cand);
            }
        }
        else {
            # Assemble various files we'd look for.
            my $base_path := nqp::join('/', nqp::split('::', $module_name));
            my $pbc_path  := $base_path ~ '.pbc';
            my $pir_path  := $base_path ~ '.pir';
            my $pm_path   := $base_path ~ '.pm';
            my $pm6_path  := $base_path ~ '.pm6';
            
            # Go through the prefixes and build a candidate list.
            for @prefixes -> $prefix {
                $prefix := nqp::gethllsym('perl6', 'ModuleLoader').absolute_path(~$prefix);
                my $have_pm  := nqp::stat("$prefix/$pm_path", 0);
                my $have_pm6 := nqp::stat("$prefix/$pm6_path", 0);
                my $have_pir := nqp::stat("$prefix/$pir_path", 0);
                my $have_pbc := nqp::stat("$prefix/$pbc_path", 0);
                if $have_pm6 {
                    # if there are both .pm and .pm6 we assume that
                    # the former is a Perl 5 module and use the latter
                    $have_pm := 1;
                    $pm_path := $pm6_path;
                }
                if $have_pm {
                    my %cand;
                    %cand := "$prefix/$pm_path";
                    %cand  := "$prefix/$pm_path";
                    if $have_pir && nqp::stat("$prefix/$pir_path", 7)
                                 >= nqp::stat("$prefix/$pm_path", 7) {
                        %cand := "$prefix/$pir_path";
                    }
                    elsif $have_pbc && nqp::stat("$prefix/$pbc_path", 7)
                                    >= nqp::stat("$prefix/$pm_path", 7) {
                        %cand := "$prefix/$pbc_path";
                    }
                    @candidates.push(%cand);
last; # temporary, until we actually don't do just @candidates[0]
                }
                elsif $have_pir {
                    my %cand;
                    %cand  := "$prefix/$pir_path";
                    %cand := "$prefix/$pir_path";
                    @candidates.push(%cand);
last; # temporary, until we actually don't do just @candidates[0]
                }
                elsif $have_pbc {
                    my %cand;
                    %cand  := "$prefix/$pbc_path";
                    %cand := "$prefix/$pbc_path";
                    @candidates.push(%cand);
last; # temporary, until we actually don't do just @candidates[0]
                }
            }
        }
        @candidates
    }
    
    # Finds a setting to load.
    method find_setting($setting_name) {
        my $path := "$setting_name.setting.pbc";
        my @prefixes := self.search_path();
        for @prefixes -> $prefix {
            $prefix := nqp::gethllsym('perl6', 'ModuleLoader').absolute_path(~$prefix);
            if nqp::stat("$prefix/$path", 0) {
                $path := "$prefix/$path";
                last;
            }
        }
        $path
    }
}
rakudo-2013.12/src/vm/parrot/ops/.gitignore0000664000175000017500000000014212224263172020112 0ustar  moritzmoritz*.c
*.dump
*.o
*.obj
*.so
*.h
*.bundle
*.dll
*.manifest
*.exp
*.ilk
*.lib
*.pdb
*.opt
*.dsp
*.dsw
rakudo-2013.12/src/vm/parrot/ops/perl6.ops0000664000175000017500000014101512224263172017702 0ustar  moritzmoritz/*
 * Copyright (C) 2008-2013, The Perl Foundation.
 */

BEGIN_OPS_PREAMBLE

#include "parrot/parrot.h"
#include "parrot/events.h"
#include "parrot/extend.h"
#include "parrot/dynext.h"
#include "pmc_object.h"
#include "pmc_class.h"
#include "pmc_callcontext.h"
#include "pmc_sub.h"
#include "pmc_continuation.h"
#include "pmc_exception.h"
#include "../guts/bind.h"
#include "../guts/container.h"
#include "../guts/types.h"
#include "../guts/sixmodelobject.h"
#include "../guts/exceptions.h"

#if PARROT_HAS_ICU
#  include 
#endif

/* Cache some stuff for fast access. */
static INTVAL smo_id = 0;
static INTVAL qrpa_id = 0;

static PMC *build_sig_object(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), ARGIN(const char *sig), ...)
{
    PMC *sig_obj;
    va_list args;

    va_start(args, sig);
    /* sigh, Parrot_pcc_build_sig_object_from_varargs does not have a signature arg */
    sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, sig, args);
    va_end(args);
    return sig_obj;
}

static INTVAL should_run_phaser(PARROT_INTERP, PMC *phaser, PMC *all_phasers, PMC *result) {
    PMC *keep_list, *undo_list;
    INTVAL i, elems;
    
    /* Check if the phaser is in the keep or undo list. */
    INTVAL in_keep_list = 0;
    INTVAL in_undo_list = 0;
    phaser = Rakudo_cont_decontainerize(interp, phaser);
    keep_list = VTABLE_get_pmc_keyed_str(interp, all_phasers, Parrot_str_new_constant(interp, "KEEP"));
    if (!PMC_IS_NULL(keep_list)) {
        elems = VTABLE_elements(interp, keep_list);
        for (i = 0; i < elems; i++)
            if (Rakudo_cont_decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, keep_list, i)) == phaser)
            {
                in_keep_list = 1;
                break;
            }
    }
    if (!in_keep_list) {
        undo_list = VTABLE_get_pmc_keyed_str(interp, all_phasers, Parrot_str_new_constant(interp, "UNDO"));
        if (!PMC_IS_NULL(undo_list)) {
            elems = VTABLE_elements(interp, undo_list);
            for (i = 0; i < elems; i++)
                if (Rakudo_cont_decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, undo_list, i)) == phaser)
                {
                    in_undo_list = 1;
                    break;
                }
        }
    }
    
    /* If it's in neither list, it's just a plain old LEAVE. */
    if (!in_keep_list && !in_undo_list)
        return 1;

    /* If it's NULL, we're unwinding, which means we only UNDO. */
    if (PMC_IS_NULL(result))
        return in_undo_list;

    /* Otherwise, need to consider the definedness of the return value. */
    if (IS_CONCRETE(result)) {
        PMC *meth = VTABLE_find_method(interp, result, Parrot_str_new_constant(interp, "defined"));
        PMC *definedness;
        Parrot_ext_call(interp, meth, "Pi->P", result, &definedness);
        if (VTABLE_get_bool(interp, definedness))
            return in_keep_list;
        else
            return in_undo_list;
    }
    else {
        return in_undo_list;
    }
}

static PMC *run_leave_phasers(PARROT_INTERP, PMC *ctx, PMC *perl6_code, PMC *result, PMC *exceptions)
{
    Rakudo_Code *code;
    PMC *phasers, *leave_phasers, *post_phasers;
    PMC *oldctx;
    int i, n;
    Parrot_runloop jump_point;
    
    /* Don't run any phasers if we failed while checking pre-conditions. */
    if (PObj_flag_TEST(P6_CHECKING_PRE, ctx))
        return PMCNULL;
    
    if (PMC_IS_NULL(perl6_code))
        return PMCNULL;
    code = (Rakudo_Code *)PMC_data(perl6_code);
    phasers = code->phasers;
    if (PMC_IS_NULL(phasers))
        return PMCNULL;
    leave_phasers = VTABLE_get_pmc_keyed_str(interp, phasers, Parrot_str_new_constant(interp, "!LEAVE-ORDER"));
    post_phasers = VTABLE_get_pmc_keyed_str(interp, phasers, Parrot_str_new_constant(interp, "POST"));
    if (PMC_IS_NULL(leave_phasers) && PMC_IS_NULL(post_phasers))
        return PMCNULL;
    
    oldctx = CURRENT_CONTEXT(interp);
    Parrot_pcc_set_context(interp, ctx);
    
    if (!PMC_IS_NULL(leave_phasers)) {
        n = VTABLE_elements(interp, leave_phasers);
        for (i = 0; i < n; i++) {
            int runloop_id = interp->current_runloop_id;
            if (setjmp(jump_point.resume)) {
                if (PMC_IS_NULL(exceptions)) {
                    exceptions = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                }
                VTABLE_push_pmc(interp, exceptions, jump_point.exception);
                /* grrr */
                while (interp->current_runloop && interp->current_runloop_id != runloop_id)
                    free_runloop_jump_point(interp);
            } else {
                PMC *phaser = VTABLE_get_pmc_keyed_int(interp, leave_phasers, i);
                Parrot_ex_add_c_handler(interp, &jump_point);
                if (should_run_phaser(interp, phaser, phasers, result))
                    Parrot_pcc_invoke_sub_from_c_args(interp, phaser, "->");
            }
            Parrot_cx_delete_handler_local(interp);
        }
    }
    
    if (!PMC_IS_NULL(post_phasers)) {
        INTVAL failed_a_post = 0;
        n = VTABLE_elements(interp, post_phasers);
        for (i = 0; i < n; i++) {
            int runloop_id = interp->current_runloop_id;
            if (setjmp(jump_point.resume)) {
                if (PMC_IS_NULL(exceptions)) {
                    exceptions = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                }
                VTABLE_push_pmc(interp, exceptions, jump_point.exception);
                /* grrrrrrr */
                while (interp->current_runloop && interp->current_runloop_id != runloop_id)
                    free_runloop_jump_point(interp);
                failed_a_post = 1;
            } else {
                PMC *phaser = VTABLE_get_pmc_keyed_int(interp, post_phasers, i);
                Parrot_ex_add_c_handler(interp, &jump_point);
                Parrot_pcc_invoke_sub_from_c_args(interp, phaser, "P->", result);
            }
            Parrot_cx_delete_handler_local(interp);
            if (failed_a_post)
                break;
        }
    }
    
    Parrot_pcc_set_context(interp, oldctx);
    return exceptions;
}

static void rethrow_phaser_exceptions(PARROT_INTERP, PMC *exceptions)
{
    int i, n;
    if (PMC_IS_NULL(exceptions))
        return;
    n = VTABLE_elements(interp, exceptions);
    if (!n)
        return;
    for (i = 0; i < n; i++) {
        Parrot_ex_rethrow_from_c(interp, VTABLE_get_pmc_keyed_int(interp, exceptions, i));
    }
}

static void rewind_to_ctx(PARROT_INTERP, ARGIN_NULLOK(PMC *ctx), ARGIN_NULLOK(PMC *basectx), ARGIN_NULLOK(PMC *result))
{
    PMC *parrot_sub;
    PMC *perl6_code;
    PMC *exceptions = PMCNULL;
    while (!PMC_IS_NULL(ctx) && ctx != basectx) {
        parrot_sub = Parrot_pcc_get_sub(interp, ctx);
        if (!PMC_IS_NULL(parrot_sub)) {
            GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
            if (!PMC_IS_NULL(perl6_code) && perl6_code->vtable->base_type == smo_id &&
                    STABLE(perl6_code)->WHAT != Rakudo_types_code_get()) {
                exceptions = run_leave_phasers(interp, ctx, perl6_code, result, exceptions);
            }
        }
        ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
    }
    if (!PMC_IS_NULL(exceptions)) {
        Parrot_pcc_set_context(interp, basectx);
        rethrow_phaser_exceptions(interp, exceptions);
    }
}

static PMC *find_common_ctx(PARROT_INTERP, ARGIN_NULLOK(PMC *ctx1), ARGIN_NULLOK(PMC *ctx2))
{
    int depth1 = 0;
    int depth2 = 0;
    PMC *ctx;

    for (ctx = ctx1; !PMC_IS_NULL(ctx); ctx = Parrot_pcc_get_caller_ctx(interp, ctx), depth1++)
        if (ctx == ctx2)
            return ctx;
    for (ctx = ctx2; !PMC_IS_NULL(ctx); ctx = Parrot_pcc_get_caller_ctx(interp, ctx), depth2++)
        if (ctx == ctx1)
            return ctx;
    for (; depth1 > depth2; depth2++)
        ctx1 = Parrot_pcc_get_caller_ctx(interp, ctx1);
    for (; depth2 > depth1; depth1++)
        ctx2 = Parrot_pcc_get_caller_ctx(interp, ctx2);
    while (ctx1 != ctx2) {
        ctx1 = Parrot_pcc_get_caller_ctx(interp, ctx1);
        ctx2 = Parrot_pcc_get_caller_ctx(interp, ctx2);
    }
    return ctx1;
}


PARROT_CAN_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static PMC* sub_find_pad(PARROT_INTERP, ARGIN(STRING *lex_name), ARGIN(PMC *ctx))
{
    ASSERT_ARGS(Parrot_sub_find_pad)
    while (1) {
        PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, ctx);
        PMC * outer = Parrot_pcc_get_outer_ctx(interp, ctx);

        if (PMC_IS_NULL(outer))
            return lex_pad;

        PARROT_ASSERT(outer->vtable->base_type == enum_class_CallContext);

        if (!PMC_IS_NULL(lex_pad))
            if (VTABLE_exists_keyed_str(interp, lex_pad, lex_name))
                return lex_pad;

        ctx = outer;
    }
}

static PMC *defaultContainerDescriptor = NULL;

static INTVAL initialized_ops = 0;

PARROT_DYNEXT_EXPORT PMC*
Parrot_lib_perl6_ops_init(PARROT_INTERP) {
    /* Map LexPad/LexInfo. */
    INTVAL hll_id = Parrot_hll_register_HLL(interp, Parrot_str_new_constant(interp, "perl6"));
    Parrot_hll_register_HLL_type(interp, hll_id,
        Parrot_pmc_get_type_str(interp, Parrot_str_new_constant(interp, "LexPad")),
        Parrot_pmc_get_type_str(interp, Parrot_str_new_constant(interp, "NQPLexPad")));
    Parrot_hll_register_HLL_type(interp, hll_id,
        Parrot_pmc_get_type_str(interp, Parrot_str_new_constant(interp, "LexInfo")),
        Parrot_pmc_get_type_str(interp, Parrot_str_new_constant(interp, "NQPLexInfo")));
    return PMCNULL;
}

END_OPS_PREAMBLE

/*

=item rakudo_dynop_setup()

Does various setup tasks on behalf of all of the other dynops.

=cut

*/
inline op rakudo_dynop_setup() :base_core {
    if (!initialized_ops) {
        /* Get 6model object type ID. */
        smo_id = Parrot_pmc_get_type_str(interp, Parrot_str_new_constant(interp, "SixModelObject"));
        qrpa_id = Parrot_pmc_get_type_str(interp, Parrot_str_new_constant(interp, "QRPA"));
        
        /* Register Rakudo scalar container configuration. */
        Rakudo_cont_register(interp);
        
        initialized_ops = 1;
    }
}


/*

=item inline op x_is_uprop(out INT, in STR, in STR, in INT)

Sets a true value in $1 if character $4 in string $3 has the unicode property
named $2.

=cut

*/
inline op x_is_uprop(out INT, in STR, in STR, in INT) :base_core {
#if PARROT_HAS_ICU
    char     *cstr;
    INTVAL    ord;
    int32_t   strwhich, ordwhich;
    UProperty strprop;
    opcode_t  *handler;

    if ($4 > 0 && (UINTVAL)$4 == ($3->strlen)) {
        $1 = 0;
        goto NEXT();
    }

    ord = Parrot_str_indexed(interp, $3, $4);
    cstr = Parrot_str_to_cstring(interp, $2);

    /* try block tests */
    if (strncmp(cstr, "In", 2) == 0) {
        strwhich = u_getPropertyValueEnum(UCHAR_BLOCK, cstr+2);
        ordwhich = u_getIntPropertyValue(ord, UCHAR_BLOCK);
        if (strwhich != UCHAR_INVALID_CODE) {
            $1 = (strwhich == ordwhich);
            Parrot_str_free_cstring(cstr);
            goto NEXT();
        }
    }

    /* try bidi tests */
    if (strncmp(cstr, "Bidi", 4) == 0) {
        strwhich = u_getPropertyValueEnum(UCHAR_BIDI_CLASS, cstr+4);
        ordwhich = u_getIntPropertyValue(ord, UCHAR_BIDI_CLASS);
        if (strwhich != UCHAR_INVALID_CODE) {
            $1 = (strwhich == ordwhich);
            Parrot_str_free_cstring(cstr);
            goto NEXT();
        }
    }

    /* try property value aliases */
    strwhich = u_getPropertyValueEnum(UCHAR_GENERAL_CATEGORY_MASK, cstr);
    if (strwhich != UCHAR_INVALID_CODE) {
        ordwhich = u_getIntPropertyValue(ord, UCHAR_GENERAL_CATEGORY_MASK);
        $1 = ((strwhich & ordwhich) != 0);
        Parrot_str_free_cstring(cstr);
        goto NEXT();
    }

    /* try property */
    strprop = u_getPropertyEnum(cstr);
    if (strprop != UCHAR_INVALID_CODE) {
        $1 = (u_hasBinaryProperty(ord, strprop) != 0);
        Parrot_str_free_cstring(cstr);
        goto NEXT();
    }

    /* try script aliases */
    strwhich = u_getPropertyValueEnum(UCHAR_SCRIPT, cstr);
    if (strwhich != UCHAR_INVALID_CODE) {
        ordwhich = u_getIntPropertyValue(ord, UCHAR_SCRIPT);
        $1 = (strwhich == ordwhich);
        Parrot_str_free_cstring(cstr);
        goto NEXT();
    }

    /* unrecognized property name */
    Parrot_str_free_cstring(cstr);
    handler =  Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_ICU_ERROR,
            "Unicode property '%Ss' not found", $2);
    goto ADDRESS(handler);
#else
    opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_ICU_ERROR,
            "ICU not loaded", $2);
    goto ADDRESS(handler);
#endif
}

/*

=item bind_signature()

This is emitted into a sub to cause it's Perl 6 signature to be bound.

=cut

*/
inline op bind_signature() :base_core {
    /* Need to make sure some stuff doesn't get destroyed. */
    PMC      * const ctx         = CURRENT_CONTEXT(interp);
    PMC      * const saved_ccont = interp->current_cont;
    PMC      * const saved_sig   = Parrot_pcc_get_signature(interp, ctx);
    opcode_t * const current_pc  = Parrot_pcc_get_pc(interp, ctx);
    
    /* Obtain lexpad and other settings. */
    PMC * const lexpad        = Parrot_pcc_get_lex_pad(interp, ctx);
    const INTVAL noms_checked = PObj_flag_TEST(P6BINDER_ALREADY_CHECKED, ctx);
    STRING * error            = STRINGNULL;
    INTVAL bind_error;
    
    /* Look up signature to bind. */
    PMC * const parrot_sub  = Parrot_pcc_get_sub(interp, ctx);
    PMC *perl6_code, *signature;
    GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
    if (PMC_IS_NULL(perl6_code))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Could not locate Perl 6 code object");
    signature = ((Rakudo_Code *)PMC_data(perl6_code))->signature;

    /* Call signature binder. */
    bind_error = Rakudo_binding_bind(interp, lexpad, signature, ctx,
        noms_checked, &error);

    /* Bind ok? */
    if (!bind_error) {
        /* Re-instate anything we may have damaged. */
        CURRENT_CONTEXT(interp) = ctx;
        interp->current_cont    = saved_ccont;
        Parrot_pcc_set_signature(interp, ctx, saved_sig);
        Parrot_pcc_set_pc(interp, ctx, current_pc);
        goto NEXT();
    }
    else {
        /* Maybe we need to auto-thread... */
        if (bind_error == BIND_RESULT_JUNCTION) {
            /* Find dispatcher and call it. */
            PMC * const dispatcher = Rakudo_types_junction_threader_get();
            PMC * const sub        = Parrot_pcc_get_sub(interp, ctx);
            PMC * call_ctx         = VTABLE_clone(interp, ctx);
            PMC * ret_cont         = Parrot_pcc_get_continuation(interp, ctx);
            PMC * p6sub;
            opcode_t *next;

            GETATTR_Sub_multi_signature(interp, sub, p6sub);
            VTABLE_unshift_pmc(interp, call_ctx, p6sub);
            Parrot_pcc_invoke_from_sig_object(interp, dispatcher, call_ctx);

            /* Invoke the original return continuation, to return junction result. */
            next = VTABLE_invoke(interp, ret_cont, expr NEXT());
            goto ADDRESS(next);
        }
        else {
            /* Nope, just normal fail... */
            opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
                    EXCEPTION_INVALID_OPERATION, "%Ss", error);
            goto ADDRESS(handler);
        }
    }
}


/*

=item perl6_bind_sig_to_cap()

Takes a signature and capture. Binds it in the current lexical context.

=cut

*/
inline op perl6_bind_sig_to_cap(in PMC, in PMC) :base_core {
    PMC *signature = $1;
    PMC *capture   = $2;
    
    /* Need to make sure some stuff doesn't get destroyed. */
    PMC      * const ctx         = CURRENT_CONTEXT(interp);
    PMC      * const saved_ccont = interp->current_cont;
    PMC      * const saved_sig   = Parrot_pcc_get_signature(interp, ctx);
    opcode_t * const current_pc  = Parrot_pcc_get_pc(interp, ctx);
    
    /* Obtain lexpad and other settings. */
    PMC * const lexpad        = Parrot_pcc_get_lex_pad(interp, ctx);
    STRING * error            = STRINGNULL;
    INTVAL bind_error;

    /* Call signature binder. */
    bind_error = Rakudo_binding_bind(interp, lexpad, signature,
        capture, 0, &error);

    /* Bind ok? */
    if (!bind_error) {
        /* Re-instate anything we may have damaged. */
        CURRENT_CONTEXT(interp) = ctx;
        interp->current_cont    = saved_ccont;
        Parrot_pcc_set_signature(interp, ctx, saved_sig);
        Parrot_pcc_set_pc(interp, ctx, current_pc);
        goto NEXT();
    }
    else {
        opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
                EXCEPTION_INVALID_OPERATION, "%Ss", error);
        goto ADDRESS(handler);
    }
}


/*

=item perl6_trial_bind_ct()

Sees if we could potentially bind a signature.

    $0 is a flag indicating the outcome. 0 means could not decide, 1 means
    decided that we will be able to bind, -1 means that it'd never work
    
    $1 is the signature object
    
    $2 is the argument array
    
    $3 is a set of flags for native types. 0 = object, 1 = native int,
    2 = native num, 3 = native str.

=cut

*/
inline op perl6_trial_bind_ct(out INT, in PMC, in PMC, in PMC) :base_core {
    /* Build up a capture with sample arguments. */
    PMC *capture    = Parrot_pmc_new(interp, enum_class_CallContext);
    INTVAL num_args = VTABLE_elements(interp, $3);
    INTVAL args_ok  = 1;
    INTVAL i;
    for (i = 0; i < num_args; i++) {
        INTVAL native = VTABLE_get_integer_keyed_int(interp, $4, i);
        PMC *obj;
        switch (native) {
            case BIND_VAL_INT:
                VTABLE_push_integer(interp, capture, 0);
                break;
            case BIND_VAL_NUM:
                VTABLE_push_float(interp, capture, 0.0);
                break;
            case BIND_VAL_STR:
                VTABLE_push_string(interp, capture, STRINGNULL);
                break;
            default:
                obj = VTABLE_get_pmc_keyed_int(interp, $3, i);
                if (obj->vtable->base_type == smo_id) {
                    VTABLE_push_pmc(interp, capture, obj);
                }
                else {
                    args_ok = 0;
                    break;
                }
        }
    }
    
    /* Do trial bind. */
    $1 = Rakudo_binding_trial_bind(interp, $2, capture);
}


/*

=item perl6_is_sig_bindable()

Checks if a capture can be bound to a signature.

=cut

*/
inline op perl6_is_sig_bindable(out INT, in PMC, in PMC) :base_core {    
    PMC      *signature = $2;
    PMC      *capture   = $3;
    PMC      *lexpad, *ctx, *_do, *ret_cont, *call_object;
    opcode_t *next;
    INTVAL    result;

    /* Need to make sure some stuff doesn't get destroyed. */
    PMC      * const saved_ctx   = CURRENT_CONTEXT(interp);
    PMC      * const saved_ccont = interp->current_cont;
    PMC      * const saved_sig   = Parrot_pcc_get_signature(interp, saved_ctx);
    opcode_t * const saved_pc    = Parrot_pcc_get_pc(interp, saved_ctx);
    
    /* Obtain code object from signature. */
    PMC *code = ((Rakudo_Signature *)PMC_data(signature))->code;
    if (PMC_IS_NULL(code)) {
        $1 = 0;
        goto NEXT();
    }
    _do  = ((Rakudo_Code *)PMC_data(code))->_do;

    /* Invoke the code that the signature belongs to. */
    ret_cont = Parrot_pmc_new(interp, enum_class_Continuation);
    call_object = Parrot_pmc_new(interp, enum_class_CallContext);
    Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_object);
    PARROT_CONTINUATION(ret_cont)->from_ctx = call_object;
    Parrot_pcc_set_continuation(interp, call_object, ret_cont);
    interp->current_cont = ret_cont;
    next = VTABLE_invoke(interp, _do, saved_pc);
    ctx = CURRENT_CONTEXT(interp);
    
    /* Obtain lexpad. */
    lexpad = Parrot_pcc_get_lex_pad(interp, ctx);

    /* Call signature binder and stash outcome. */
    result = Rakudo_binding_bind(interp, lexpad, signature, capture, 0, NULL)
        != BIND_RESULT_FAIL;

    /* Invoke the return continuation. */
    VTABLE_invoke(interp, ret_cont, next);
    
    $1 = result;
}


/*

=item p6settypes(in PMC)

Takes the symbols produced by the bootstrap and stashes some of them away for
use by the guts.

=cut

*/
inline op p6settypes(invar PMC) :base_core {
    Rakudo_types_mu_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Mu")));
    Rakudo_types_any_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Any")));
    Rakudo_types_routine_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Routine")));
    Rakudo_types_int_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Int")));
    Rakudo_types_num_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Num")));
    Rakudo_types_str_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Str")));
    Rakudo_types_list_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "List")));
    Rakudo_types_listiter_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "ListIter")));
    Rakudo_types_array_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Array")));
    Rakudo_types_lol_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "LoL")));
    Rakudo_types_parcel_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Parcel")));
    Rakudo_types_enummap_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "EnumMap")));
    Rakudo_types_hash_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Hash")));
    Rakudo_types_capture_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Capture")));
    Rakudo_types_code_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Code")));
    Rakudo_cont_set_scalar_type(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Scalar")));
    Rakudo_types_bool_false_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "False")));
    Rakudo_types_bool_true_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "True")));
    Rakudo_types_junction_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Junction")));
    Rakudo_types_nil_set(VTABLE_get_pmc_keyed_str(interp, $1,
        Parrot_str_new_constant(interp, "Nil")));

    {
        PMC *CD = VTABLE_get_pmc_keyed_str(interp, $1,
            Parrot_str_new_constant(interp, "ContainerDescriptor"));
        PMC *defCD = REPR(CD)->allocate(interp, STABLE(CD));
        Rakudo_ContainerDescriptor *cd = ((Rakudo_ContainerDescriptor *)PMC_data(defCD));
        REPR(defCD)->initialize(interp, STABLE(defCD), OBJECT_BODY(defCD));
        cd->of          = Rakudo_types_mu_get();
        cd->name        = Parrot_str_new_constant(interp, "");
        cd->rw          = 1;
        cd->the_default = Rakudo_types_any_get();
        defaultContainerDescriptor = defCD;
        Parrot_pmc_gc_register(interp, defaultContainerDescriptor);
    }
}


/*

=item perl6_setup_junction_autothreading(in PMC)

Sets the junction type and auto-threader.

=cut

*/
inline op perl6_setup_junction_autothreading(in PMC) :base_core {
    Rakudo_types_junction_threader_set($1);
}


/*

=item perl6_booleanize(out PMC, in INT)

If $2 is non-zero, puts Bool::True in $1. Otherwise puts Bool::False
in.

=cut

*/
inline op perl6_booleanize(out PMC, in INT) :base_core {
    $1 = $2 == 0 ? Rakudo_types_bool_false_get() : Rakudo_types_bool_true_get();
}


/*

=item perl6_box_str()

Box a native string to a Perl 6 Str.

=cut

*/
inline op perl6_box_str(out PMC, in STR) :base_core {
    PMC *type = Rakudo_types_str_get();
    $1 = REPR(type)->allocate(interp, STABLE(type));
    REPR($1)->box_funcs->set_str(interp, STABLE($1), OBJECT_BODY($1), $2);
    PARROT_GC_WRITE_BARRIER(interp, $1);
}


/*

=item perl6_box_int()

Box a native int to a Perl 6 Int.

=cut

*/
inline op perl6_box_int(out PMC, in INT) :base_core {
    PMC *type = Rakudo_types_int_get();
    $1 = REPR(type)->allocate(interp, STABLE(type));
    REPR($1)->box_funcs->set_int(interp, STABLE($1), OBJECT_BODY($1), $2);    
}


/*

=item perl6_box_num()

Box a native floating point number to a Perl 6 Num.

=cut

*/
inline op perl6_box_num(out PMC, in NUM) :base_core {
    PMC *type = Rakudo_types_num_get();
    $1 = REPR(type)->allocate(interp, STABLE(type));
    REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), $2);
}


/*

=item perl6_box_bigint(out PMC, in NUM)

Return a Perl 6 Int if $2 will fit, otherwise return a Perl 6 Num.

=cut

*/
inline op perl6_box_bigint(out PMC, in NUM) :base_core {
    if ((INTVAL)$2 == $2) {
        PMC *type = Rakudo_types_int_get();
        $1 = REPR(type)->allocate(interp, STABLE(type));
        REPR($1)->box_funcs->set_int(interp, STABLE($1), OBJECT_BODY($1), $2);    
    }
    else {
        PMC *type = Rakudo_types_num_get();
        $1 = REPR(type)->allocate(interp, STABLE(type));
        REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), $2);
    }
}


/*

=item perl6_recontainerize_to_ro()

If the passed value is an rw scalar, re-wrap it. Otherwise, just
hand it on back.

=cut

*/
inline op perl6_recontainerize_to_ro(out PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id && Rakudo_cont_is_rw_scalar(interp, $2))
        $1 = Rakudo_cont_scalar_with_value_no_descriptor(interp, 
            Rakudo_cont_decontainerize(interp, $2));
    else
        $1 = $2;
}


/*

=item perl6_container_store(in PMC, in PMC)

Stores a value in a container. If it's Scalar, there's a fast path;
otherwise, calls the .STORE method.

=cut

*/
inline op perl6_container_store(in PMC, in PMC) :base_core {
    Rakudo_cont_store(interp, $1, $2, 1, 1);
}


/*

=item perl6_container_store_unchecked(in PMC, in PMC)

Stores a value in a container. If it's Scalar, there's a fast path;
otherwise, calls the .STORE method. In the fast path case, with this
op no rw or type checking is done (assumes that the compiler has
already decided that it's safe).

=cut

*/
inline op perl6_container_store_unchecked(in PMC, in PMC) :base_core {
    Rakudo_cont_store(interp, $1, $2, 0, 0);
}


/*

=item perl6_assert_bind_ok(in PMC, in PMC)

Takes a potential value to bind in $1 and a container descriptor in $2
and asserts that the bind is allowed to take place.

=cut

*/
inline op perl6_assert_bind_ok(in PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id) {
        PMC *type = $2;
        if (type != Rakudo_types_mu_get()) {
            INTVAL ok = 0;
            if ($1->vtable->base_type == smo_id) {
                PMC *value = Rakudo_cont_decontainerize(interp, $1);
                ok = STABLE(value)->type_check(interp, value, type);
            }
            if (!ok) {
                PMC * const thrower = Rakudo_get_thrower(interp, "X::TypeCheck::Binding");
                if (PMC_IS_NULL(thrower))
                        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                            "Type check failed in binding");
                else
                    Parrot_pcc_invoke_sub_from_c_args(interp, thrower, "PP->",
                        $1, type);

            }
        }

    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_assert_bind_ok on a SixModelObject");
    }
}


/*

=item perl6_var(in PMC, in PMC)

The .VAR operation. Wraps in an outer Scalar container so we can actually
operate on the underlying Scalar, if we have a container. Otherwise, $1
is just $2.

=cut

*/
inline op perl6_var(out PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id && STABLE($2)->container_spec != NULL) {
        $1 = Rakudo_cont_scalar_with_value_no_descriptor(interp, $2);
    }
    else {
        $1 = $2;
    }
}


/*

=item perl6_repr_name

Takes an object and returns a string containing the name of its representation.

=cut

*/
inline op perl6_repr_name(out PMC, in PMC) :base_core {
    PMC *val = Rakudo_cont_decontainerize(interp, $2);
    if (val->vtable->base_type == smo_id) {
        PMC    *type = Rakudo_types_str_get();
        STRING *name = REPR(val)->name;
        PMC    *res  = REPR(type)->allocate(interp, STABLE(type));
        REPR(res)->box_funcs->set_str(interp, STABLE(res), OBJECT_BODY(res), name);
        PARROT_GC_WRITE_BARRIER(interp, res);
        $1 = res;
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_repr_name with a SixModelObject");
    }
}


/*

=item perl6_definite

Takes an object and returns a boolean determining whether it is concrete.

=cut

*/
inline op perl6_definite(out PMC, in PMC) :base_core {
    PMC *val = Rakudo_cont_decontainerize(interp, $2);
    $1 = IS_CONCRETE(val) ?
        Rakudo_types_bool_true_get() :
        Rakudo_types_bool_false_get();
}


/*

=item perl6_decontainerize_return_value()

If the sub is not rw, decontainerizes the return value.

=cut

*/
inline op perl6_decontainerize_return_value(out PMC, invar PMC, invar PMC) :base_core {
    if ($3->vtable->base_type == smo_id && Rakudo_cont_is_rw_scalar(interp, $3)) {
        Rakudo_Code *code = (Rakudo_Code *)PMC_data($2);
        $1 = code->rw ? $3 : Rakudo_cont_scalar_with_value_no_descriptor(interp, 
            Rakudo_cont_decontainerize(interp, $3));
    }
    else {
        $1 = $3;
    }
}

/*

=item perl6_type_check_return_value()

Gets the return type for the sub in $2 and type-checks the value in
$1 against it.

=cut

*/
inline op perl6_type_check_return_value(invar PMC, invar PMC) :base_core {
    PMC *sig_pmc = ((Rakudo_Code *)PMC_data($2))->signature;
    PMC *rtype   = ((Rakudo_Signature *)PMC_data(sig_pmc))->rtype;
    if (!PMC_IS_NULL(rtype)) {
        PMC *decont_value = Rakudo_cont_decontainerize(interp, $1);
        if (!STABLE(decont_value)->type_check(interp, decont_value, rtype)) {
            /* Straight type check failed, but it's possible we're returning
             * an Int that can unbox into an int or similar. */
            storage_spec spec = REPR(rtype)->get_storage_spec(interp, STABLE(rtype));
            if (!spec.inlineable ||
                !STABLE(rtype)->type_check(interp, rtype, STABLE(decont_value)->WHAT)) {
                PMC * const thrower = Rakudo_get_thrower(interp, "X::TypeCheck::Return");
                if (PMC_IS_NULL(thrower))
                    Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                        "Type check failed for return value; wanted %Ss but got %Ss",
                        VTABLE_name(interp, rtype),
                        VTABLE_name(interp, decont_value));
                else
                    Parrot_pcc_invoke_sub_from_c_args(interp, thrower, "PP->",
                            decont_value, rtype);
            }
        }
    }
}


/*

=item perl6_find_dispatcher(out PMC)

Locates the nearest dispatcher $*DISPATCHER, vivifying it if required,
and returns it.

=cut

*/
inline op perl6_find_dispatcher(out PMC, in STR) :base_core {
    PMC     *ctx            = CURRENT_CONTEXT(interp);
    STRING  *dispatcher_str = Parrot_str_new_constant(interp, "$*DISPATCHER");
    PMC     *dispatcher     = NULL;
    
    while (!PMC_IS_NULL(ctx)) {
        /* Do we have a dispatcher here? */
        PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
        if (!PMC_IS_NULL(lexpad) && VTABLE_exists_keyed_str(interp, lexpad, dispatcher_str)) {
            PMC *maybe_dispatcher = VTABLE_get_pmc_keyed_str(interp, lexpad, dispatcher_str);
            if (!PMC_IS_NULL(maybe_dispatcher)) {
                dispatcher = maybe_dispatcher;
                if (!PMC_IS_NULL(dispatcher) && !IS_CONCRETE(dispatcher)) {
                    /* Need to vivify it. */
                    PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
                    PMC *meth    = VTABLE_find_method(interp, dispatcher, Parrot_str_new_constant(interp, "vivify_for"));
                    PMC *cappy   = Parrot_pmc_new(interp, enum_class_CallContext);
                    PMC *sub     = Parrot_pcc_get_sub(interp, ctx);
                    PMC *p6sub;
                    VTABLE_push_pmc(interp, cappy, dispatcher);
                    GETATTR_Sub_multi_signature(interp, sub, p6sub);
                    VTABLE_push_pmc(interp, cappy, p6sub);
                    VTABLE_push_pmc(interp, cappy, lexpad);
                    VTABLE_push_pmc(interp, cappy, ctx);
                    Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
                    cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
                    Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
                    dispatcher = VTABLE_get_pmc_keyed_int(interp, cappy, 0);
                    VTABLE_set_pmc_keyed_str(interp, lexpad, dispatcher_str, dispatcher);
                }
                break;
            }
        }

        /* Follow dynamic chain. */
        ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
    }
    
    if (!dispatcher) {
        PMC * const thrower = Rakudo_get_thrower(interp, "X::NoDispatcher");
        if (PMC_IS_NULL(thrower)) {
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "%Ss is not in the dynamic scope of a dispatcher", $2);
        } else {
            PMC *type = Rakudo_types_str_get();
            PMC *str = REPR(type)->allocate(interp, STABLE(type));
            REPR(str)->box_funcs->set_str(interp, STABLE(str), OBJECT_BODY(str), $2);
            PARROT_GC_WRITE_BARRIER(interp, str);
            Parrot_pcc_invoke_sub_from_c_args(interp, thrower, "P->", str);
        }

    }
    $1 = dispatcher;
}

/*

=item perl6_args_for_dispatcher(out PMC, in PMC)

Locates the callframe with the $*DISPATCHER passed and returns it.

=cut

*/
inline op perl6_args_for_dispatcher(out PMC, in PMC) :base_core {
    PMC     *ctx            = CURRENT_CONTEXT(interp);
    STRING  *dispatcher_str = Parrot_str_new_constant(interp, "$*DISPATCHER");
    PMC     *result         = NULL;
    
    while (!PMC_IS_NULL(ctx)) {
        /* Do we have a dispatcher here? */
        PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
        if (!PMC_IS_NULL(lexpad) && VTABLE_exists_keyed_str(interp, lexpad, dispatcher_str)) {
            PMC *dispatcher = VTABLE_get_pmc_keyed_str(interp, lexpad, dispatcher_str);
            if (dispatcher == $2) {
                result = ctx;
                break;
            }
        }
        ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
    }
    
    if (!result)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Could not find arguments for dispatcher");
    $1 = result;
}

/*

=item perl6_current_args_rpa(out PMC)

Gets a ResizablePMCArray containing the positional arguments passed to the
current block.

=cut

*/
inline op perl6_current_args_rpa(out PMC) :base_core {
    PMC   *cur_ctx = CURRENT_CONTEXT(interp);
    PMC   *result  = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
    INTVAL args    = VTABLE_elements(interp, cur_ctx);
    INTVAL i;
    for (i = 0; i < args; i++) {
        PMC *argval = VTABLE_get_pmc_keyed_int(interp, cur_ctx, i);
        VTABLE_set_pmc_keyed_int(interp, result, i,
            argval->vtable->base_type == smo_id ?
                argval :
                Rakudo_types_parrot_map(interp, argval));
    }
    $1 = result;
}


/*

=item perl6_state_needs_init(out INT)

Returns a non-zero value if state variables need their initialization
and START blocks should run.

=cut

*/
inline op perl6_state_needs_init(out INT) :base_core {
    PMC *cur_ctx = CURRENT_CONTEXT(interp);
    $1 = PObj_flag_TEST(P6LEXPAD_STATE_INIT, cur_ctx);
}


/*

=item perl6_set_block_first_flag(in PMC)

Flags that the next execution of a block should run the FIRST block.

=cut

*/
inline op perl6_set_block_first_flag(in PMC) :base_core {
    Rakudo_Code * code = (Rakudo_Code *)PMC_data($1);
    PObj_flag_SET(SUB_FIRST, code->_do);
}


/*

=item perl6_take_block_first_flag(out INT)

Checks the flag for if FIRST blocks should be run for this invocation, and
clears it.

=cut

*/
inline op perl6_take_block_first_flag(out INT) :base_core {
    PMC * const ctx     = CURRENT_CONTEXT(interp);
    PMC * const cur_sub = Parrot_pcc_get_sub(interp, ctx);
    $1 = PObj_flag_TEST(SUB_FIRST, cur_sub);
    PObj_flag_CLEAR(SUB_FIRST, cur_sub);
}


/*

=item perl6_set_checking_pre()

Sets the checking PRE blocks flag on a context.

=cut

*/
inline op perl6_set_checking_pre() :base_core {
    PMC * const ctx = CURRENT_CONTEXT(interp);
    PObj_flag_SET(P6_CHECKING_PRE, ctx);
}


/*

=item perl6_clear_checking_pre()

Clears the checking PRE blocks flag on a context.

=cut

*/
inline op perl6_clear_checking_pre() :base_core {
    PMC * const ctx = CURRENT_CONTEXT(interp);
    PObj_flag_CLEAR(P6_CHECKING_PRE, ctx);
}


/*

=item perl6_parcel_from_rpa(out PMC, in PMC, in PMC)

Creates a Perl 6 Parcel object from the RPA in $2, replacing
any PMCNULL elements with $3.

=cut

*/
inline op perl6_parcel_from_rpa(out PMC, in PMC, in PMC) :base_core {
    $1 = Rakudo_binding_parcel_from_rpa(interp, $2, $3);
}


/*

=item perl6_iter_from_rpa(out PMC, in PMC, in PMC)

Creates a lazy Perl 6 ListIter object from the RPA in $2
and iterates into the List at $3.

=cut

*/
inline op perl6_iter_from_rpa(out PMC, in PMC, in PMC) :base_core {
    $1 = Rakudo_binding_iter_from_rpa(interp, $2, $3);
}


/*

=item perl6_list_from_rpa(out PMC, in PMC, in PMC, in PMC)

Creates a lazy Perl 6 List object of type $3 from the RPA
in $2 and with flattening $4.

=cut

*/
inline op perl6_list_from_rpa(out PMC, in PMC, in PMC, in PMC) :base_core {
    PMC *items = $2;
    if (items->vtable->base_type != qrpa_id) {
        /* Switch aggregate to be a QRPA */
        PMC *t = Parrot_pmc_new(interp, qrpa_id);
        VTABLE_splice(interp, t, items, 0, 0);
        items = t;
    }
    $1 = Rakudo_binding_list_from_rpa(interp, items, $3, $4);
}


/*

=item perl6_listitems(out PMC, in PMC)

Returns the $!items attribute of $2 into $1, vivifying it to a
low-level array if it isn't one already.

*/
inline op perl6_listitems(out PMC, in PMC) :base_core {
    PMC *List  = Rakudo_types_list_get();
    PMC *items = VTABLE_get_attr_keyed(interp, $2, List,
                     Parrot_str_new_constant(interp, "$!items"));
    INTVAL type = items->vtable->base_type;
    if (type != qrpa_id && type != enum_class_ResizablePMCArray) {
        items = Parrot_pmc_new(interp, qrpa_id);
        VTABLE_set_attr_keyed(interp, $2, List,
                     Parrot_str_new_constant(interp, "$!items"), items);
    }
    $1 = items;
}


/*

=item perl6_rpa_find_types(out INT, in PMC, in PMC, int INT, in INT)

Find the first element of RPA $2 that has any of the types in
$3, starting at index $4 and up through (but not including) index
$5. Sets $1 to be the index of the first element matching type,
otherwise $1 is set to the highest index searched.

Containerized elements are automatically skipped.

=cut

*/
inline op perl6_rpa_find_types(out INT, invar PMC, invar PMC, in INT, in INT) {
    PMC *rpa      = $2;
    PMC *types    = $3;
    INTVAL elems  = VTABLE_elements(interp, rpa);
    INTVAL ntypes = VTABLE_elements(interp, types);
    INTVAL last   = $5;
    INTVAL index, type_index;

    if (elems < last)  last = elems;

    for (index = $4; index < last; index++) {
        PMC *val = VTABLE_get_pmc_keyed_int(interp, rpa, index);
        if (val->vtable->base_type == smo_id && !STABLE(val)->container_spec) {
            INTVAL found = 0;
            for (type_index = 0; type_index < ntypes; type_index++) {
                PMC *type = VTABLE_get_pmc_keyed_int(interp, types, type_index);
                if (STABLE(val)->type_check(interp, val, type)) {
                    found = 1;
                    break;
                }
            }
            if (found)
                break;
        }
    }

    $1 = index;
}


/*

=item perl6_shiftpush(inout PMC, in PMC, in INT)

Shifts up to $3 elements from $2, pushing each shifted onto $1.
$1 can be PMCNULL, in which case the shifted elements are
simply discarded.

*/
inline op perl6_shiftpush(inout PMC, in PMC, in INT) :base_core {
    INTVAL count = $3;
    INTVAL elems = VTABLE_elements(interp, $2);
    if (count > elems) count = elems;

    if (!PMC_IS_NULL($1) && $3 > 0) {
        INTVAL get_pos = 0;
        INTVAL set_pos = VTABLE_elements(interp, $1);
        VTABLE_set_integer_native(interp, $1, set_pos + count);
        while (count > 0) {
            VTABLE_set_pmc_keyed_int(interp, $1, set_pos,
                VTABLE_get_pmc_keyed_int(interp, $2, get_pos));
            count--;
            get_pos++;
            set_pos++;
        }
    }
    if ($3 > 0)
        VTABLE_splice(interp, $2, Parrot_pmc_new(interp, enum_class_ResizablePMCArray), 0, $3);
}


/*

=item capture_all_outers(in PMC)

Takes a list of Code objects that map to closures, finds those closures outers
can captures those contexts.

=cut

*/
inline op capture_all_outers(in PMC) :base_core {
    PMC    *cur_ctx = CURRENT_CONTEXT(interp);
    INTVAL  elems   = VTABLE_elements(interp, $1);
    INTVAL  i;
    for (i = 0; i < elems; i++) {
        PMC *code_obj = VTABLE_get_pmc_keyed_int(interp, $1, i);
        PMC *closure = ((Rakudo_Code *)PMC_data(code_obj))->_do;
        PMC *ctx_to_diddle = PARROT_SUB(closure)->outer_ctx;
        Parrot_pcc_set_outer_ctx_func(interp, ctx_to_diddle, cur_ctx);
    }
}


/*

=item encodelocaltime(out INT, in PMC)

The inverse of C.

=cut

*/
inline op encodelocaltime(out INT, in PMC) :base_core {
    struct tm tm;

    tm.tm_sec  = VTABLE_get_integer_keyed_int(interp, $2, 0);
    tm.tm_min  = VTABLE_get_integer_keyed_int(interp, $2, 1);
    tm.tm_hour = VTABLE_get_integer_keyed_int(interp, $2, 2);
    tm.tm_mday = VTABLE_get_integer_keyed_int(interp, $2, 3);
    tm.tm_mon  = VTABLE_get_integer_keyed_int(interp, $2, 4) - 1;
    tm.tm_year = VTABLE_get_integer_keyed_int(interp, $2, 5) - 1900;
    /* We needn't bother setting tm_wday or tm_yday, since mktime
    is required to ignore them. */
    tm.tm_isdst = VTABLE_get_integer_keyed_int(interp, $2, 8);

    $1 = mktime(&tm);
}


/*

=item perl6_based_rethrow(in PMC, in PMC)

Rethrow an exception, but instead of starting the search for a
matching ExceptionHandler in the current context, use another
exception as base for the rethrow.

=cut

*/
inline op perl6_based_rethrow(in PMC, in PMC) :base_core {
    PMC      *except = $1;
    PMC      *base = $2;
    opcode_t *dest;
    STRING   *handlers_left_str = Parrot_str_new_constant(interp, "handlers_left");
    PMC      *base_ctx = (PMC *)VTABLE_get_pointer(interp, base);
    INTVAL    base_handlers_left = VTABLE_get_integer_keyed_str(interp, base, handlers_left_str);

    VTABLE_set_pointer(interp, except, base_ctx);
    VTABLE_set_integer_keyed_str(interp, except, handlers_left_str, base_handlers_left);
    dest = Parrot_ex_rethrow_from_op(interp, except);
    goto ADDRESS(dest);
}


/*

=item perl6_skip_handlers_in_rethrow(in PMC, in INT)

=cut

*/
inline op perl6_skip_handlers_in_rethrow(in PMC, in INT) :base_core {
    PMC      *except = $1;
    STRING   *handlers_left_str = Parrot_str_new_constant(interp, "handlers_left");
    INTVAL    handlers_left = VTABLE_get_integer_keyed_str(interp, except, handlers_left_str);

    handlers_left -= $2;
    if (handlers_left < 0)
        handlers_left = 0;
    VTABLE_set_integer_keyed_str(interp, except, handlers_left_str, handlers_left);
}


/*

=item perl6_invoke_catchhandler(invar PMC, in PMC)

Works like invoke, but takes a parrot exception as second argument.
The perl6 spec says that the catchhandler's call chain must include
the callframes from the exception, so we do some context fiddling
here. When the catchhandler returns, it uses the continuation that
points to the original callchain.
Note that exceptions in the catchhandler must be caught and
possibly rethrown with perl6_based_rethrow, otherwise the handlers
from the exception will pick them up.

=cut

*/
inline op perl6_invoke_catchhandler(invar PMC, in PMC) :flow {
    PMC      * p        = $1;
    PMC      * ctx      = CURRENT_CONTEXT(interp);
    opcode_t * dest     = expr NEXT();
    PMC      * call_obj = Parrot_pcc_build_call_from_c_args(interp, PMCNULL, "P", $2);
    PMC      * cont     = Parrot_pmc_new(interp, enum_class_Continuation);
    PMC      * ectx     = PMCNULL;

    VTABLE_set_pointer(interp, cont, dest);
    Parrot_pcc_set_pc(interp, ctx, dest);
    /* now the tricky part, restore exception context */
    GETATTR_Exception_thrower(interp, $2, ectx);
    if (PMC_IS_NULL(ectx))
        ectx = ctx;
    if (ectx != ctx)
        Parrot_pcc_set_context(interp, ectx);
    if (PMC_IS_NULL(p)) {
        /* no function provided, return immediately */
        PMC *basectx = find_common_ctx(interp, ctx, ectx);
        rewind_to_ctx(interp, ectx, basectx, PMCNULL);
        Parrot_pcc_set_context(interp, ctx);
        goto NEXT();
    } else {
        interp->current_cont = cont;
        Parrot_pcc_set_signature(interp, ectx, call_obj);
        dest = VTABLE_invoke(interp, p, dest);
        goto ADDRESS(dest);
    }
}


inline op perl6_return_from_routine(in PMC) :flow {
    PMC * ctx = CURRENT_CONTEXT(interp);
    PMC * cont = PMCNULL;
    opcode_t * dest = expr NEXT();
    PMC * cctx;
    PMC * basectx;
    PMC * call_sig = build_sig_object(interp, PMCNULL, "P", $1);
    STRING * lex_name = Parrot_str_new_constant(interp, "RETURN");

    for (ctx = Parrot_pcc_get_caller_ctx(interp, ctx); !PMC_IS_NULL(ctx); ctx = Parrot_pcc_get_caller_ctx(interp, ctx)) {
        PMC * const lex_pad = sub_find_pad(interp, lex_name, ctx);
        if (!PMC_IS_NULL(lex_pad)) {
            cont = VTABLE_get_pmc_keyed_str(interp, lex_pad, lex_name);
            if (!PMC_IS_NULL(cont))
                break;
        }
    }
    if (cont->vtable->base_type != enum_class_Continuation) {
        PMC * const thrower = Rakudo_get_thrower(interp, "X::ControlFlow::Return");
        if (PMC_IS_NULL(thrower))
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                    "Attempt to return outside of any Routine");
        else
            Parrot_pcc_invoke_sub_from_c_args(interp, thrower, "->");
    }
    ctx = CURRENT_CONTEXT(interp);
    GETATTR_Continuation_to_ctx(interp, cont, cctx);
    basectx = find_common_ctx(interp, ctx, cctx);
    rewind_to_ctx(interp, ctx, basectx, $1);
    Parrot_pcc_set_signature(interp, ctx, call_sig);
    dest = VTABLE_invoke(interp, cont, dest);
    goto ADDRESS(dest);
}


inline op perl6_returncc(in PMC) :flow {
    PMC * ctx = CURRENT_CONTEXT(interp);
    PMC * cont = Parrot_pcc_get_continuation(interp, ctx);
    opcode_t * dest = expr NEXT();
    PMC * cctx;
    PMC * basectx;
    PMC * call_sig = build_sig_object(interp, PMCNULL, "P", $1);

    GETATTR_Continuation_to_ctx(interp, cont, cctx);
    basectx = find_common_ctx(interp, ctx, cctx);
    rewind_to_ctx(interp, ctx, basectx, $1);
    Parrot_pcc_set_signature(interp, ctx, call_sig);
    dest = VTABLE_invoke(interp, cont, dest);
    goto ADDRESS(dest);
}


/*

=item perl6_capture_lex

Does a lexical capture, but based on a Perl 6 code object.

=cut

*/
inline op perl6_capture_lex(in PMC) {
    if ($1->vtable->base_type == smo_id) {
        Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data($1);
        Parrot_sub_capture_lex(interp, code_obj->_do);
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_capture_lex with a SixModelObject");
    }
}

/*

=item perl6_get_outer_ctx

Returns the OUTER context of a Perl 6 code object. Needed for the fixups
that macros do.

=cut

*/
inline op perl6_get_outer_ctx(out PMC, in PMC) {
    if ($2->vtable->base_type == smo_id) {
        Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(Rakudo_cont_decontainerize(interp, $2));
        if (code_obj->_do->vtable->base_type != enum_class_Sub)
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "perl6_get_outer_ctx did not get a Parrot Sub as expected, got %Ss",
                VTABLE_name(interp, VTABLE_get_class(interp, $2)));
        $1 = PARROT_SUB(code_obj->_do)->outer_ctx;
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_get_outer_ctx with a SixModelObject");
    }
}

/*

=item p6scalarfromdesc

Creates a Scalar from the specified descriptor.

=cut

*/
inline op p6scalarfromdesc(out PMC, invar PMC) {
    PMC *cont;
    PMC *desc = $2;
    
    if (PMC_IS_NULL($2) || !IS_CONCRETE($2))
        desc = defaultContainerDescriptor;

    cont = Rakudo_cont_scalar_from_descriptor(interp, desc);
    ((Rakudo_Scalar *)PMC_data(cont))->value = ((Rakudo_ContainerDescriptor *)PMC_data(desc))->the_default;
    
    $1 = cont;
}

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */
rakudo-2013.12/src/vm/parrot/Perl6/Ops.nqp0000664000175000017500000001674312224263172017610 0ustar  moritzmoritzmy $ops := nqp::getcomp('QAST').operations;

# Perl 6 opcode specific mappings.
$ops.add_hll_pirop_mapping('perl6', 'p6box_i', 'perl6_box_int', 'Pi', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6box_n', 'perl6_box_num', 'Pn', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6box_s', 'perl6_box_str', 'Ps', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6bigint', 'perl6_box_bigint', 'Pn', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6parcel', 'perl6_parcel_from_rpa', 'PPP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6listiter', 'perl6_iter_from_rpa', 'PPP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6list', 'perl6_list_from_rpa', 'PPPP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6listitems', 'perl6_listitems', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6recont_ro', 'perl6_recontainerize_to_ro', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6store', 'perl6_container_store', '0PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6var', 'perl6_var', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6reprname', 'perl6_repr_name', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6definite', 'perl6_definite', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6bindsig', 'bind_signature', 'v');
$ops.add_hll_pirop_mapping('perl6', 'p6isbindable', 'perl6_is_sig_bindable', 'IPP');
$ops.add_hll_pirop_mapping('perl6', 'p6bindcaptosig', 'perl6_bind_sig_to_cap', '0PP');
$ops.add_hll_pirop_mapping('perl6', 'p6trialbind', 'perl6_trial_bind_ct', 'IPPP');
$ops.add_hll_pirop_mapping('perl6', 'p6typecheckrv', 'perl6_type_check_return_value', '0PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6decontrv', 'perl6_decontainerize_return_value', 'PPP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6capturelex', 'perl6_capture_lex', '0P');
$ops.add_hll_pirop_mapping('perl6', 'p6bindassert', 'perl6_assert_bind_ok', '0PP');
$ops.add_hll_pirop_mapping('perl6', 'p6stateinit', 'perl6_state_needs_init', 'I');
$ops.add_hll_pirop_mapping('perl6', 'p6setpre', 'perl6_set_checking_pre', 'v');
$ops.add_hll_pirop_mapping('perl6', 'p6clearpre', 'perl6_clear_checking_pre', 'v');
$ops.add_hll_pirop_mapping('perl6', 'p6setfirstflag', 'perl6_set_block_first_flag', '0P');
$ops.add_hll_pirop_mapping('perl6', 'p6takefirstflag', 'perl6_take_block_first_flag', 'I');
$ops.add_hll_pirop_mapping('perl6', 'p6return', 'perl6_returncc', '0P');
$ops.add_hll_pirop_mapping('perl6', 'p6routinereturn', 'perl6_return_from_routine', '0P');
$ops.add_hll_pirop_mapping('perl6', 'p6getouterctx', 'perl6_get_outer_ctx', 'PP');
$ops.add_hll_pirop_mapping('perl6', 'p6captureouters', 'capture_all_outers', 'vP');
$ops.add_hll_pirop_mapping('perl6', 'p6argvmarray', 'perl6_current_args_rpa', 'P');
$ops.add_hll_pirop_mapping('perl6', 'p6bindattrinvres', 'setattribute', '0PPsP');
$ops.add_hll_pirop_mapping('perl6', 'p6finddispatcher', 'perl6_find_dispatcher', 'Ps');
$ops.add_hll_pirop_mapping('perl6', 'p6argsfordispatcher', 'perl6_args_for_dispatcher', 'PP');
$ops.add_hll_pirop_mapping('perl6', 'p6shiftpush', 'perl6_shiftpush', '0PPi');
$ops.add_hll_pirop_mapping('perl6', 'p6arrfindtypes', 'perl6_rpa_find_types', 'IPPii');
$ops.add_hll_pirop_mapping('perl6', 'p6decodelocaltime', 'decodelocaltime', 'Pi');
$ops.add_hll_pirop_mapping('perl6', 'p6setautothreader', 'perl6_setup_junction_autothreading', 'vP');
$ops.add_hll_pirop_mapping('perl6', 'tclc', 'titlecase', 'Ss', :inlinable(1));
$ops.add_hll_op('perl6', 'p6sort', -> $qastcomp, $op {
    $qastcomp.as_post(QAST::Op.new(
        :op('callmethod'), :name('sort'),
        $op[0], $op[1]
    ))
});
my $p6bool := -> $qastcomp, $op {
    my $cpost := $qastcomp.as_post($op[0]);
    my $reg := $*REGALLOC.fresh_p();
    my $ops := $qastcomp.post_new('Ops', :result($reg));
    $ops.push($cpost);
    if nqp::lc($qastcomp.infer_type($cpost.result)) eq 'i' {
        $ops.push_pirop('perl6_booleanize', $reg, $cpost);
    }
    else {
        my $reg_i := $*REGALLOC.fresh_i();
        $ops.push_pirop('istrue', $reg_i, $cpost);
        $ops.push_pirop('perl6_booleanize', $reg, $reg_i);
    }
    $ops
}
$ops.add_hll_op('perl6', 'p6bool', :inlinable(1), $p6bool);
$ops.add_hll_op('perl6', 'p6staticouter', -> $qastcomp, $op {
    $qastcomp.as_post(QAST::Op.new(
        :op('callmethod'), :name('get_outer'),
        $op[0]
    ))
});
$ops.add_hll_pirop_mapping('perl6', 'p6scalarfromdesc', 'p6scalarfromdesc', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('perl6', 'p6invokehandler', 'perl6_invoke_catchhandler', 'vPP');

# Make some of them also available from NQP land, since we use them in the
# metamodel and bootstrap.
$ops.add_hll_op('nqp', 'p6bool', :inlinable(1), $p6bool);
$ops.add_hll_pirop_mapping('nqp', 'p6var', 'perl6_var', 'PP', :inlinable(1));
$ops.add_hll_pirop_mapping('nqp', 'p6parcel', 'perl6_parcel_from_rpa', 'PPP', :inlinable(1));
$ops.add_hll_pirop_mapping('nqp', 'p6isbindable', 'perl6_is_sig_bindable', 'IPP');
$ops.add_hll_pirop_mapping('nqp', 'p6trialbind', 'perl6_trial_bind_ct', 'IPPP');
$ops.add_hll_pirop_mapping('nqp', 'p6settypes', 'p6settypes', 'vP', :inlinable(1));
$ops.add_hll_pirop_mapping('nqp', 'p6init', 'rakudo_dynop_setup', 'v', :inlinable(1));

# Override defor to avoid v-table call.
$ops.add_hll_op('perl6', 'defor', :inlinable(1), -> $qastcomp, $op {
    if +$op.list != 2 {
        nqp::die("Operation 'defor' needs 2 operands");
    }
    my $ops := PIRT::Ops.new();
    my $lbl := PIRT::Label.new(:name('defor'));
    my $dreg := $*REGALLOC.fresh_p();
    my $rreg := $*REGALLOC.fresh_p();
    my $test := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
    my $then := $qastcomp.coerce($qastcomp.as_post($op[1]), 'P');
    $ops.push($test);
    $ops.push_pirop('set', $rreg, $test);
    $ops.push_pirop('callmethod', "'defined'", $rreg, :result($dreg));
    $ops.push_pirop('if', $dreg, $lbl);
    $ops.push($then);
    $ops.push_pirop('set', $rreg, $then);
    $ops.push($lbl);
    $ops.result($rreg);
    $ops
});

# Boxing and unboxing configuration.
QAST::Operations.add_hll_box('perl6', 'i', -> $qastcomp, $post {
    my $reg := $*REGALLOC.fresh_p();
    my $ops := $qastcomp.post_new('Ops');
    $ops.push($post);
    $ops.push_pirop('perl6_box_int', $reg, $post);
    $ops.result($reg);
    $ops
});
QAST::Operations.add_hll_box('perl6', 'n', -> $qastcomp, $post {
    my $reg := $*REGALLOC.fresh_p();
    my $ops := $qastcomp.post_new('Ops');
    $ops.push($post);
    $ops.push_pirop('perl6_box_num', $reg, $post);
    $ops.result($reg);
    $ops
});
QAST::Operations.add_hll_box('perl6', 's', -> $qastcomp, $post {
    my $reg := $*REGALLOC.fresh_p();
    my $ops := $qastcomp.post_new('Ops');
    $ops.push($post);
    $ops.push_pirop('perl6_box_str', $reg, $post);
    $ops.result($reg);
    $ops
});
QAST::Operations.add_hll_unbox('perl6', 'i', -> $qastcomp, $post {
    my $reg := $*REGALLOC.fresh_i();
    my $ops := $qastcomp.post_new('Ops');
    $ops.push($post);
    $ops.push_pirop('repr_unbox_int', $reg, $post);
    $ops.result($reg);
    $ops
});
QAST::Operations.add_hll_unbox('perl6', 'n', -> $qastcomp, $post {
    my $reg := $*REGALLOC.fresh_n();
    my $ops := $qastcomp.post_new('Ops');
    $ops.push($post);
    $ops.push_pirop('set', $reg, $post);
    $ops.result($reg);
    $ops
});
QAST::Operations.add_hll_unbox('perl6', 's', -> $qastcomp, $post {
    my $reg := $*REGALLOC.fresh_s();
    my $ops := $qastcomp.post_new('Ops');
    $ops.push($post);
    $ops.push_pirop('set', $reg, $post);
    $ops.result($reg);
    $ops
});
QAST::Compiler.force_return_boxing_for_hll('perl6');
rakudo-2013.12/t/00-parrot/01-literals.t0000664000175000017500000000122112255230273017011 0ustar  moritzmoritz#!./parrot perl6.pbc

# check literals

use v6;

say '1..24';


print "ok ";
print 1;
print "\n";

print 'ok ';
say 2;

print "ok 3\n";
say 'ok 4';
say "ok 5";

say 'ok ', 0x6;
say 'ok ', 0b111;
say 'ok ', 0o10;
say 'ok ', 0d9;
say 'ok ', +"0x0a";
say 'ok ', '0b1010' + 1;
say 'ok ', '0o6' * '0b10';
say 'ok ', +'0d13';

say 'ok ', 0_0_1_4;
say 'ok ', 0x0000_000f;
say 'ok ', 0d16;
say 'ok ', 0b0001_0001;

say 'ok ', "\x31\x38";
say 'ok ', "1\x39";
say 'ok ', "\x32\o60";
say "\x023 test multiple escapes in string using diag output: \x31\x32\o63";
say "ok 21";

say 'ok ', +"\x[32]2";
say 'ok ', +"2\x[33]";
say 'ok ', +"\o[62,064]";


## TODO a lot more
rakudo-2013.12/t/00-parrot/02-op-math.t0000664000175000017500000000067312255230273016552 0ustar  moritzmoritz#!./parrot perl6.pbc

# check basic math ops

use v6;

say '1..14';

print 'ok ';
say 0 + 1;
print 'ok ';
say 1 + 1;
print 'ok ';
say 4 - 1;
print 'ok ';
say 2 * 2;

# 5
print 'ok ';
say 4 +| 1;
print 'ok ';
say 7 +& +^1;

print 'ok ';
say 15 +^ 8;
print 'ok ';
say 2 ** 3;

# 9
print 'ok ';
say 3 ** 2;
print 'ok ';
say 20 +> 1;

print 'ok ';
say 5 +< 1 + 1;
print 'ok ';
say 25 % 13;

# 13
print 'ok ';
say -(-13);
print 'ok ';
say abs -14;
rakudo-2013.12/t/00-parrot/03-op-logic.t0000664000175000017500000000104412255230273016710 0ustar  moritzmoritz#!./parrot perl6.pbc

# check logical ops

use v6;

say '1..16';

1 and say 'ok 1';
0 or say 'ok 2';
1 && say 'ok 3';
0 || say 'ok 4';
0 xor say 'ok 5';
0 ^^ say 'ok 6';

## chaining logical ops
(1 and 2) and say 'ok 7';
(2 && 4) and say 'ok 8';
(0 or 2) and say 'ok 9';
(2 || 0) and say 'ok 10';
(1 xor 0) and say 'ok 11';
(1 ^^ 1)  or say 'ok 12';

## interesting
(1 and 0 xor 1 or 0) and say 'ok 13';
(1 and 0 xor 0 || 1) and say 'ok 14';

## more interesting
(5 and 0 xor 0 || 3) == 3 and say 'ok 15';
(0 xor 0 ^^ 42 or 1) == 1 or say 'ok 16';
rakudo-2013.12/t/00-parrot/04-op-cmp.t0000664000175000017500000000130412255230273016372 0ustar  moritzmoritz#!./parrot perl6.pbc

# check compare ops

use v6;

say '1..24';

1 < 2 and say 'ok 1';
1 > 2 or say 'ok 2';
1 <= 2 and say 'ok 3';
1 >= 2 or say 'ok 4';
1 == 1 and say 'ok 5';
1 == 2 or say 'ok 6';
1 < 2 < 3 and say 'ok 7';
1 < 2 < 2 or say 'ok 8';
4 > 3 > 1 and say 'ok 9';
4 > 3 > 3 or say 'ok 10';
1 != 2 and say 'ok 11';
1 != 1 or say 'ok 12';

'a' lt 'b' and say 'ok 13';
'a' gt 'b' or say 'ok 14';
'a' le 'b' and say 'ok 15';
'a' ge 'b' or say 'ok 16';
'a' eq 'a' and say 'ok 17';
'a' eq 'b' or say 'ok 18';
'a' lt 'b' lt 'c' and say 'ok 19';
'a' lt 'b' lt 'b' or say 'ok 20';
'd' gt 'c' gt 'a' and say 'ok 21';
'd' gt 'c' gt 'c' or say 'ok 22';
'a' ne 'b' and say 'ok 23';
'a' ne 'a' or say 'ok 24';
rakudo-2013.12/t/00-parrot/05-var.t0000664000175000017500000000113412255230273015771 0ustar  moritzmoritz#!./parrot perl6.pbc

# check variables

use v6;

say '1..12';

my $o1 = 'ok 1'; say $o1;

my $o2; $o2 = 'ok 2'; say $o2;

my $a = 3; print 'ok '; say $a;

my $b; $b = 4; print 'ok '; say $b;

our $x = 5;  say 'ok ', $x;

{ my $x = 6; say 'ok ', $x; };

if ($x + 2 == 7)  { say 'ok ', $x + 2; }

{ my $x = 999; { our $x; say 'ok ', $x + 3; } }


##   variable interpolation in strings

$b = 9;  "ok $b" eq 'ok 9' and say 'ok 9';

'ok $b' ne 'ok 9' and say 'ok 10';

$b = "0x0b";  "ok $b" eq 'ok 0x0b' and say 'ok 11';


##   nested 'our' declarations

$x = 'not ok 12';  { our $x = 'ok 12'; };  say $x;

rakudo-2013.12/t/00-parrot/06-op-inplace.t0000664000175000017500000000207212255230273017233 0ustar  moritzmoritz#!./parrot perl6.pbc

# check inplace math ops

use v6;

say '1..11';

my $test_num = 1;
my $a = 0;
$a += 1;
$a != 1 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

++$a;
$a != 2 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a = 4;
$a -= 1;
$a != 3 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;


my $b = 1;
$a += $b;
$a != 4 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a +|= $b;
$a != 5 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a +&= +^$b;
$a +^= 2;
$a != 6 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a++;
$a != 7 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a = 1;
$a +<= 3;
$a != 8 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a +>= 1;
$a -= 1;
$a **= 2;
$a != 9 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a /= 3;
$a += 7;
$a != 10 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;

$a %= 3;
$a != 1 and print 'not ';
say "ok $test_num";
$test_num = $test_num + 1;
rakudo-2013.12/t/00-parrot/07-op-string.t0000664000175000017500000000141312255230273017125 0ustar  moritzmoritz#!./parrot perl6.pbc

# check string ops

use v6;

say '1..18';
say 'ok ' ~ '1';
say 'ok' ~ ' ' ~ '2';
my $s = 'ok ';
say $s ~ '3';
$s ~= '4';
say $s;

#5
$s = 'ab';
$s eq 'ab' and say 'ok 5';
$s ne 'Ab' and say 'ok 6';
'ab' le 'ab' and say 'ok 7';
'ab' lt 'ac' and say 'ok 8';
'cd' ge 'cd' and say 'ok 9';
'cd' gt 'cc' and say 'ok 10';

'ab' x 2 eq 'abab' and say 'ok 11';
$s x= 3;
$s eq 'ababab' and say 'ok 12';

$s = 'A' ~| 3;
$s eq 's' and say 'ok 13';

$s = 'a';
$s ~&= ' ';
$s eq ' ' and say 'ok 14';
$s = 'abc';
$s ~&= '    ';
$s eq '   ' and say 'ok 15';

$s = 'ABC' ~| '   ';
$s eq 'abc' and say 'ok 16';

# check COW of Parrot strings (r27046, r27048)
my $foo = 'fred';
my $bar = 'fred';
$foo++;
$bar--;
$foo eq 'free' and say 'ok 17';
$bar eq 'frec' and say 'ok 18';
rakudo-2013.12/t/00-parrot/08-var-array.t0000664000175000017500000000062512255230273017114 0ustar  moritzmoritz#!./parrot perl6.pbc

# check array variables

use v6;

say '1..11';

my @a = (1, 2, 3);

say 'ok ' ~ @a[0];
say 'ok ' ~ @a[1];
say 'ok ' ~ @a[2];
3 == @a.elems and say 'ok 4';

my @b = <5 6>;

say 'ok ' ~ @b[0];
say 'ok ' ~ @b[1];
2 == @b.elems and say 'ok 7';

my @c = ; say ~@c;

2 == (1, 2).elems and say 'ok 9';
3 == .elems and say 'ok 10';
3 == ['a', <2 three>].elems and say 'ok 11';

rakudo-2013.12/t/00-parrot/09-pir.t0000664000175000017500000000114112224263172015775 0ustar  moritzmoritz#!./parrot perl6.pbc

# check inline PIR

use v6;

BEGIN {
    unless $*VM eq 'parrot' {
        say '1..0 # SKIP This is not Parrot and cannot run PIR blocks';
        exit 0;
    }
}

say '1..3';

## inline directly
Q:PIR { say 'ok 1' };

## assigned to a variable
my $a = Q:PIR { %r = perl6_box_str 'ok 2' };
say $a;

## within a subroutine
sub foo($x) {
    Q:PIR {
        $P0 = find_lex '$x'
        $S0 = repr_unbox_str $P0
        say $S0
    };
    # a Q:PIR block returning nothing as last statement inside a block
    # is a bad idea, so end on a happy note instead:
    1;

}
foo('ok 3');


rakudo-2013.12/t/00-parrot/10-regex.t0000664000175000017500000000071312255230273016311 0ustar  moritzmoritz#!./parrot perl6.pbc

# check basic regex capabilities

use v6;

say '1..11';

'abc' ~~ /abc/ and say 'ok 1';
'2' ~~ /^ \d+ $/ and say "ok ", ~$/;

my $rx = /  /;
'012a456' ~~ $rx and say 'ok 3';

my $l = 5;
my $r = 5;
$l   ~~ $r and say 'ok 4';
5    ~~ $r and say 'ok 5';
'5'  ~~ $r and say 'ok 6';
'25' ~~ $r or  say 'ok 7';

$r = / 5 /;
$l   ~~ $r and say 'ok 8';
5    ~~ $r and say 'ok 9';
'5'  ~~ $r and say 'ok 10';
'25' ~~ $r and say 'ok 11';


rakudo-2013.12/t/01-sanity/01-tap.t0000664000175000017500000000052312255230273015763 0ustar  moritzmoritz
# L
use v6;


# Checking that testing is sane: TAP output

say '1..10';

say 'ok 1';
say "ok 2";

say 'ok';
say '# comment';
say 'ok ', '4';
say "ok", " " ~ "5";

say 'ok 6 foo';
say 'ok 7 # skip';
say 'ok 8 # skip bar';
say 'not ok 9 # TODO';
say 'not ok 10 # TODO baz';
rakudo-2013.12/t/01-sanity/02-counter.t0000664000175000017500000000043612255230273016662 0ustar  moritzmoritz# L
use v6;

# Checking that testing is sane: counted tests


say '1..4';

my $counter = 1;
say "ok $counter";

$counter++;
say "ok $counter";

++$counter;
say 'ok ', $counter;

++$counter;
say 'ok ' ~ $counter;
rakudo-2013.12/t/01-sanity/03-equal.t0000664000175000017500000000040412255230273016306 0ustar  moritzmoritzuse v6;

# Checking that testing is sane: equality and inequality


say '1..4';

my $x = '0';

($x eq $x) && say 'ok 1';
($x ne $x) && say 'not ok 1';
($x eq $x) || say 'not ok 2';
($x ne $x) || say 'ok 2';

($x == $x) && say 'ok 3';
($x != $x) || say 'ok 4';
rakudo-2013.12/t/01-sanity/04-if.t0000664000175000017500000000140712255230273015602 0ustar  moritzmoritzuse v6;

# Checking that testing is sane: if


say '1..9';

my $x = '0';

if ($x eq $x) { say     'ok 1' } else { say 'not ok 1' }
if ($x ne $x) { say 'not ok 2' } else { say     'ok 2' }

if (1) { say     'ok 3' } elsif 0 { say 'not ok 3' } else { say 'not ok 3' }
if (0) { say 'not ok 4' } elsif 1 { say     'ok 4' } else { say 'not ok 4' }
if (0) { say 'not ok 5' } elsif 0 { say 'not ok 5' } else { say     'ok 5' }

if    0 { say 'not ok 6' }
elsif 1 { say     'ok 6' }
elsif 0 { say 'not ok 6' }
else    { say 'not ok 6' }

if    0 { say 'not ok 7' }
elsif 0 { say 'not ok 7' }
elsif 1 { say     'ok 7' }
else    { say 'not ok 7' }

if    0 { say 'not ok 8' }
elsif 1 { say     'ok 8' }
elsif 1 { say 'not ok 8' }
else    { say 'not ok 8' }

unless 0 { say    'ok 9' }
rakudo-2013.12/t/01-sanity/05-sub.t0000664000175000017500000000032512255230273015774 0ustar  moritzmoritzuse v6;

# Checking that testing is sane: subroutines


say '1..4';

sub ok($num) {
    say "ok $num";
}

ok(1);
ok 2;

my $counter = 2;
sub ok_auto {
    ++$counter;
    say "ok $counter";
}

ok_auto();
ok_auto;
rakudo-2013.12/t/01-sanity/06-eqv.t0000664000175000017500000000021712255230273015777 0ustar  moritzmoritzuse v6;

# Make sure that &infix: is available (but not too worried about
# the results yet).

say '1..1';

my $a = 1 eqv 3;

say 'ok 1';
rakudo-2013.12/t/01-sanity/07-isa.t0000664000175000017500000000046012255230273015761 0ustar  moritzmoritzuse v6;


say "1..3";

{
    my $string = "Pugs";
    if $string.isa("Str") { say "ok 1" } else { say "not ok 1" }
}

{
    my $int = 3;
    if $int.isa("Int")    { say "ok 2" } else { say "not ok 2 # TODO" }
}

{
    my $code = { 42 };
    if $code.isa("Code")  { say "ok 3" } else { say "not ok 3" }
}
rakudo-2013.12/t/01-sanity/08-simple-multisubs.t0000664000175000017500000000054012255230273020523 0ustar  moritzmoritzuse v6;


say "1..2";

multi sub foo ($only_one_arg) {
    if $only_one_arg eq "only_one_arg" {
        say "ok 1";
    }
    else {
        say "not ok 1";
    }
}

multi sub foo ($arg1, $arg2) {
    if $arg1 eq "arg1" and $arg2 eq "arg2" {
        say "ok 2";
    }
    else {
        say "not ok 2";
    }
}

foo "only_one_arg";
foo "arg1", "arg2";
rakudo-2013.12/t/01-sanity/09-end-blocks.t0000664000175000017500000000117712224263172017236 0ustar  moritzmoritzuse v6;

say "1..2";

#
# $was_in_second_end_block is a package variable, not a lexical one, per S04:
#
# Some closures produce C objects at compile time that cannot be
# cloned, because they're not attached to any runtime code that can
# actually clone them.  C, C, C, and C blocks
# fall into this category...  It's only safe to refer to package
# variables and file-scoped lexicals from such a routine.
#

our $was_in_second_end_block = 0;

END {
    if $was_in_second_end_block {
        say "ok 2";
    } else {
        say "not ok 2";
    }
}

END {
    $was_in_second_end_block = 1;
    say "ok 1";
}
rakudo-2013.12/t/01-sanity/10-say.t0000664000175000017500000000104412255230273015772 0ustar  moritzmoritzuse v6;

say '1..13';

# Double-quoted string
say "ok 1";

# Single-quoted
say 'ok 2';

# Invoke method on literal
'ok 3'.say;

# Invoke method on list
('ok', ' ', 4).say;
say 'ok', ' ', 5;

# Invoke method on number
print 'ok ';
6.say;

print 'ok ';
say 7;

# Invoke method on scalar variables
my $test8 = 'ok 8';
$test8.say;

my $test9 = 'ok 9';
say $test9;

# Verify return code of say
say 'ok ', 11*say 'ok 10';

# Direct call on result of expression
print 'ok ';
(2**4-4).say;

# Indirect call on result of expression
print 'ok ';
say 2**4-3;
rakudo-2013.12/t/01-sanity/11-defined.t0000664000175000017500000000035712255230273016603 0ustar  moritzmoritzuse v6;


say "1..3";

my $var;
if defined $var { say "not ok 1" } else { say "ok 1" }

$var = "Pugs";
if defined $var { say "ok 2" } else { say "not ok 2" }

undefine( $var);

if defined $var { say "not ok 3 - $var" } else { say "ok 3" }
rakudo-2013.12/t/01-sanity/12-try.t0000664000175000017500000000053212255230273016017 0ustar  moritzmoritzuse v6;


say "1..4";

try { die };
say "ok 1";  # we're still here, so &try worked at least partially.

try { die "foo\n" };
if $! eq "foo\n" { say "ok 2" } else { say "not ok 2" }

try { "this_does_not_die" };
if !$!           { say "ok 3" } else { say "not ok 3" }

try { die "bar\n" };
if $! eq "bar\n" { say "ok 4" } else { say "not ok 4" }
rakudo-2013.12/t/01-sanity/99-test-basic.t0000664000175000017500000000764112224263172017266 0ustar  moritzmoritzuse v6;
use Test;
# plan *;     # This does not test having a real plan.

pass( 'pass($desc)' );

my $ok1 = ok 1, 'ok with description';
ok $ok1, 'ok returns True';
my $ok2 = ok 1;
ok $ok2, 'ok returns True';

# NOT_TODO
# next is TODO only so our test script won't fail
# we are only testing the return value of &ok
todo( 'testing failure' );
my $ok3 = ok False, 'calling ok False';
nok $ok3, 'failure returns False';


my $nok1 = nok 0, 'nok with description';
ok $nok1, 'nok 0 returns True';
my $nok2 = nok 0;
ok $nok2, 'nok 0 returns True';

# NOT_TODO
todo( 'tesing nok True' );
my $nok3 = nok 1, 'nok 1 with description';
nok $nok3, 'nok 1 returns False';


my $is1 = is 1, 1, 'is with description';
ok $is1, 'is returns True';
is 1, 1;

# NOT_TODO
todo( 'failing is' );
my $is3 = is 1, 0, 'is 1, 0; with description';
nok $is3, 'is 1, 0;  returns False';


my $isnt1 = isnt 1, 0, 'isnt with description';
ok $isnt1, 'isnt 1, 0; returns True';
isnt 1, 0;

# NOT_TODO
todo( 'testing isnt 1,1' );
my $isnt3 = isnt 1, 1, 'isnt 1,1, with description';
nok $isnt3, 'isnt 1, 1; returns False';


my $approx1 = is_approx 1, 1, 'is_approx with description';
ok $approx1, 'is_approx 1,1, returns True';
my $approx2 = is_approx 1, 1;
my $approx3 = is_approx 1, 1.000001, 'is_approx with small difference';
ok $approx3, 'is_approx 1,1.000001, returns True';

# NOT_TODO
todo( 'failing is_approx 1,2;');
my $approx4 = is_approx 1, 2, 'is_approx with small difference';
nok $approx4, 'is_approx 1, 2; fails and returns False';


todo( 'testing todo twice', 2 );
ok 0, 'this should fail, to test todo()';
ok 0, 'this should also fail, to test todo()';
ok 1, 'passing test (todo is done)';

todo( 'todo with no count' );
ok 0, 'todo with no count covers one test';
ok 1, 'passing test (not todo)';

skip( 'skip with reason' );
skip;
skip( 'skip with count and reason', 2 );

# skip_rest();

diag( 'diag works, FYI' );

todo( 'testing flunk', 1 );
flunk( 'flunk' );

{
    my $x = 3;
    my $isa1 = isa_ok( $x, Int, 'isa_ok with message' );
    ok $isa1, 'isa_ok returns True';
    isa_ok( $x, Int );

    # NOT_TODO
    todo( 'failing isa_ok returns False' );
    my $isa2 = isa_ok( 'abc', Int );
    nok $isa2, 'Failing isa_ok returns False';
}

my $dies_ok1 = dies_ok { skip( 2, 'reason' ) },
        'skip() dies when given the arguments in the wrong order';
ok $dies_ok1, 'dies_ok returns True';

# NOT_TODO
todo( 'failing dies_ok returns False' );
my $dies_ok2 = dies_ok { 1 }, 'dies_ok {1}';
nok $dies_ok2, 'dies_ok returns False if code did not die';

dies_ok { die }, 'dies_ok';
dies_ok { die };

my $lives_ok1 = lives_ok { 1 }, 'lives_ok';
ok $lives_ok1, 'lives_ok returns True';
lives_ok { 1 };

# NOT_TODO
todo( 'failing lives_ok returns False' );
my $lives_ok2 = lives_ok { die }, 'lives_ok { die }';
nok $lives_ok2, 'failing lives_ok returns False';

my $ed_ok1 = eval_dies_ok 'die', 'eval_dies_ok';
ok $ed_ok1, 'eavl_dies_ok returns True';
eval_dies_ok 'die';

# NOT_TODO
todo( 'eval_dies_ok 1 returns False' );
my $ed_ok2 = eval_dies_ok '1', 'eval_dies_ok 1 fails';
nok $ed_ok2, 'eval_dies_ok 1 returns False';

my $el_ok1 = eval_lives_ok '1', 'eval_lives_ok';
ok $el_ok1, 'eval_lives_ok 1 returns True';
eval_lives_ok '1';

# NOT_TODO
todo( 'failing eval_lives_ok returns False' );
my $el_ok2 = eval_lives_ok 'die', 'lives_ok { die }';
nok $el_ok2, 'failing eval_lives_ok returns False';

{
    my $deeply = {
        list  => (1, 2),
        hash  => { a => 1, b => 2 },
        str   => 'hello',
        num   => 1.2,
        int   => 33,
        pair  => :a(3),
#        undef => undef,
        bool  => Bool::True,
        array => [3, 4],
    };
    my $is_deeply = is_deeply $deeply, $deeply, 'is_deeply';
    ok $is_deeply, 'is_deeply returns True';
    is_deeply $deeply, $deeply;
}

# NOT_TODO
todo( 'failing is_deeply returns False' );
my $is_deeply = is_deeply {a => 1}, {}, 'is_deeply with exta key fails';
nok $is_deeply, 'failing is_deeply returns False';

done;

# vim: ft=perl6
rakudo-2013.12/t/02-rakudo/dump.t0000664000175000017500000000647212224263172015716 0ustar  moritzmoritzuse v6;
use Test;

plan 44;

# Undefined values DUMP as .perl
is DUMP(Mu),        Mu.perl,          'DUMP(:U) is .perl (Mu)';
is DUMP(Junction),  Junction.perl,    'DUMP(:U) is .perl (Junction)';
is DUMP(Any),       Any.perl,         'DUMP(:U) is .perl (Any)';
is DUMP(Bool),      Bool.perl,        'DUMP(:U) is .perl (Bool)';
is DUMP(Cool),      Cool.perl,        'DUMP(:U) is .perl (Cool)';
is DUMP(Str),       Str.perl,         'DUMP(:U) is .perl (Str)';
is DUMP(Int),       Int.perl,         'DUMP(:U) is .perl (Int)';
is DUMP(Num),       Num.perl,         'DUMP(:U) is .perl (Num)';
is DUMP(Rat),       Rat.perl,         'DUMP(:U) is .perl (Rat)';
is DUMP(FatRat),    FatRat.perl,      'DUMP(:U) is .perl (FatRat)';
is DUMP(Complex),   Complex.perl,     'DUMP(:U) is .perl (Complex)';
is DUMP(Duration),  Duration.perl,    'DUMP(:U) is .perl (Duration)';
is DUMP(Instant),   Instant.perl,     'DUMP(:U) is .perl (Instant)';

# Defined booleans DUMP as .Str
is DUMP(False),     False.Str,        'DUMP(Bool:D) is .Str (False)';
is DUMP(True),      True.Str,         'DUMP(Bool:D) is .Str (True)';

# Defined numbers DUMP as .perl
is DUMP(0),         (0).perl,         'DUMP(Int:D) is .perl (0)';
is DUMP(1),         (1).perl,         'DUMP(Int:D) is .perl (1)';
is DUMP(-128),      (-128).perl,      'DUMP(Int:D) is .perl (-128)';
is DUMP(123456789), (123456789).perl, 'DUMP(Int:D) is .perl (123456789)';
is DUMP(1 +< 100),  (1 +< 100).perl,  'DUMP(Int:D) is .perl (1 +< 100)';

is DUMP( 0e0),      ( 0e0).perl,      'DUMP(Num:D) is .perl (0e0)';
is DUMP(-0e0),      (-0e0).perl,      'DUMP(Num:D) is .perl (-0e0)';
is DUMP( Inf),      ( Inf).perl,      'DUMP(Num:D) is .perl (Inf)';
is DUMP(-Inf),      (-Inf).perl,      'DUMP(Num:D) is .perl (-Inf)';
is DUMP( NaN),      ( NaN).perl,      'DUMP(Num:D) is .perl (NaN)';

is DUMP( 0.0),      ( 0.0).perl,      'DUMP(Rat:D) is .perl (0.0)';
is DUMP(-0.0),      (-0.0).perl,      'DUMP(Rat:D) is .perl (-0.0)';
is DUMP( 1.1),      ( 1.1).perl,      'DUMP(Rat:D) is .perl (1.1)';
is DUMP(-1.1),      (-1.1).perl,      'DUMP(Rat:D) is .perl (-1.1)';
is DUMP( 22/7),     ( 22/7).perl,     'DUMP(Rat:D) is .perl (22/7)';
is DUMP(-22/7),     (-22/7).perl,     'DUMP(Rat:D) is .perl (-22/7)';

todo('0i literal gets wrapped in a container, unlike other numeric literals');
is DUMP(   0i),     (   0i).perl,     'DUMP(Complex:D) is .perl (0i)';
is DUMP(  -0i),     (  -0i).perl,     'DUMP(Complex:D) is .perl (-0i)';
is DUMP( 0+0i),     ( 0+0i).perl,     'DUMP(Complex:D) is .perl (0+0i)';
is DUMP( 0-0i),     ( 0-0i).perl,     'DUMP(Complex:D) is .perl (0-0i)';
is DUMP(-0+0i),     (-0+0i).perl,     'DUMP(Complex:D) is .perl (-0+0i)';
is DUMP(-0-0i),     (-0-0i).perl,     'DUMP(Complex:D) is .perl (-0-0i)';
is DUMP( 1+1i),     ( 1+1i).perl,     'DUMP(Complex:D) is .perl (1+1i)';
is DUMP( 1-1i),     ( 1-1i).perl,     'DUMP(Complex:D) is .perl (1-1i)';
is DUMP(-1+1i),     (-1+1i).perl,     'DUMP(Complex:D) is .perl (-1+1i)';
is DUMP(-1-1i),     (-1-1i).perl,     'DUMP(Complex:D) is .perl (-1-1i)';

# Variables with native primitive types dump as literals
my int $int = 42;
my num $num = 12345e0;
my str $str = 'a string';

is DUMP($int),      DUMP(42),         'DUMP(int) dumps as a literal';
is DUMP($num),      DUMP(12345e0),    'DUMP(num) dumps as a literal';
is DUMP($str),      DUMP('a string'), 'DUMP(str) dumps as a literal';
rakudo-2013.12/t/fudgeandrun0000775000175000017500000000107312255230273015300 0ustar  moritzmoritz#! /usr/bin/env perl
use strict;
use warnings;

my $version = `./perl6 --version`;

my $impl = ($version =~ /jvm/i) ? "rakudo.jvm" : "rakudo.parrot";

my @OPTS = ('--keep-exit-code', $impl);

if (@ARGV) {
    my $file = $ARGV[0];
    if (! -e $file) {
        my $spec = "t/spec/$file";
        if (-e $spec) {
            $ARGV[0] = $spec;
        }
    }
}

my $nt = `t/spec/fudge @OPTS @ARGV`;
# uninstalled rakudo doesn't know how to find Test.pm
# ... or any other modules
my $pwd = `pwd`; chomp $pwd;
$ENV{PERL6LIB}="$pwd/lib:.";
system("./perl6", split ' ', $nt);
rakudo-2013.12/t/harness0000664000175000017500000001147412255230273014444 0ustar  moritzmoritz#! perl

# note: Due to a limitation in Getopt::Long options that should be passed
# through to fudgeall have to come after all other options

use strict;
use warnings;

use FindBin;
use File::Spec;
use Getopt::Long qw(:config pass_through);
use Pod::Usage;

my $slash = $^O eq 'MSWin32' ? '\\' : '/';
$ENV{'HARNESS_PERL'} = ".${slash}perl6-p";
my $path_sep = $^O eq 'MSWin32' ? ';' : ':';
$ENV{'PERL6LIB'} = join $path_sep, qw/ lib . /;
use Test::Harness;
$Test::Harness::switches = '';

GetOptions(
    'tests-from-file=s' => \my $list_file,
    'fudge'             => \my $do_fudge,
    'verbosity=i'       => \$Test::Harness::verbose,
    'jobs:1'            => \my $jobs,
    'icu:1'             => \my $do_icu,
    'long:1'            => \my $do_long,
    'stress:1'          => \my $do_stress,
    'archive=s'         => \my $archive,
    'parrot_revision=s' => \my $parrot_revision,
    'jvm'               => \my $jvm,
    'help|h' => sub { pod2usage(1); },
) or pod2usage(2);

$do_long = 1 unless defined $do_long;
$do_stress = 0 unless defined $do_stress;

my @pass_through_options = grep m/^--?[^-]/, @ARGV;
my @files = grep m/^[^-]/, @ARGV;

if ($list_file) {
    open(my $f, '<', $list_file)
        or die "Can't open file '$list_file' for reading: $!";
    while (<$f>) {
        next if m/^\s*#/;
        next unless m/\S/;
        s/^\s+//;
        s/\s+\z//;
        my ($fn, $fudgespec) = split /\s+#\s*/;
        if ($fudgespec) {
            next if ($fudgespec =~ m/icu/)    && !$do_icu && !$jvm;
            next if ($fudgespec =~ m/long/)   && !$do_long;
            next if ($fudgespec =~ m/stress/) && !$do_stress;
            next if ($fudgespec =~ m/jvm/)    && !$jvm;
        }
        $fn = "t/spec/$fn" unless $fn =~ m/^t\Q$slash\Espec\Q$slash\E/;
        $fn =~ s{/}{$slash}g;
        if ( -r $fn ) {
            push @files, $fn;
        } else {
            warn "Missing test file: $fn\n";
        }
    }
    close $f or die $!;
}

my @tfiles = map { all_in($_) } sort @files;

if ($do_fudge) {
    @tfiles = fudge(@tfiles);
}

my $tap_harness_class = 'TAP::Harness';
$tap_harness_class .= '::Archive' if $archive;

my $extra_properties;
if ($archive) {
    $extra_properties->{'Parrot Revision'} = $parrot_revision
    if $parrot_revision;
    $extra_properties->{'Submitter'} = $ENV{SMOLDER_SUBMITTER}
    if $ENV{SMOLDER_SUBMITTER};
}

if ($jvm) {
    unlink("TESTTOKEN");
    $ENV{HARNESS_PERL} = "$^X .${slash}eval-client.pl TESTTOKEN run";

    no warnings 'once';
    # leak the filehandle; it will be closed at exit, robustly telling the server to terminate
    open JVMSERVER, "| .${slash}perl6-eval-server -bind-stdin -cookie TESTTOKEN -app .${slash}perl6.jar" or die "cannot fork eval server: $!\n";
    sleep 1;
}

if (eval "require $tap_harness_class;") {
    my %harness_options = (
        exec        => $jvm ? [$^X, "./eval-client.pl", "TESTTOKEN", "run"] : [$ENV{HARNESS_PERL}],
        verbosity   => 0+$Test::Harness::verbose,
        jobs        => $jobs || $ENV{TEST_JOBS} || 1,
        ignore_exit => 1,
        merge       => 1,
        $archive ? ( archive => $archive ) : (),
        $extra_properties ? ( extra_properties => $extra_properties ) : (),
    );
    $tap_harness_class->new( \%harness_options )->runtests(@tfiles);
}
elsif ($archive) {
    die "Can't load $tap_harness_class, which is needed for smolder submissions: $@";
}
else {
    runtests(@tfiles);
}

# adapted to return only files ending in '.t'
sub all_in {
    my $start = shift;

    return $start unless -d $start;

    my @skip = ( File::Spec->updir, File::Spec->curdir, qw( .svn CVS .git ) );
    my %skip = map {($_,1)} @skip;

    my @hits = ();

    if ( opendir( my $dh, $start ) ) {
        my @files = sort readdir $dh;
        closedir $dh or die $!;
        for my $file ( @files ) {
            next if $skip{$file};

            my $currfile = File::Spec->catfile( $start, $file );
            if ( -d $currfile ) {
                push( @hits, all_in( $currfile ) );
            } else {
                push( @hits, $currfile ) if $currfile =~ /\.t$/;
            }
        }
    } else {
        warn "$start: $!\n";
    }

    return @hits;
}

sub fudge {
    my $impl = $jvm ? 'rakudo.jvm' : 'rakudo.parrot';
    my $cmd  = join ' ', $^X, 't/spec/fudgeall',
                         @pass_through_options, $impl, @_;
    return split ' ', `$cmd`;
}

=head1 NAME

t/harness - run the harness tests for Rakudo.

=head1 SYNOPSIS

t/harness [options] [files]

Options:

    --help / -h - display the help message.
    --tests-from-file=[filename] - get the tests from the filename.
    --fudge - fudge (?)
    --verbosity=[level] - set the verbosity level.
    --jobs - number of jobs.
    --icu - do icu.
    --long - do long.
    --stress - perform the stress tests/
    --archive=[archive] - write to an archive.
    --parrot_revision=[rev] - test with Parrot revision.

rakudo-2013.12/tools/autounfudge.pl0000664000175000017500000002147612224263172016641 0ustar  moritzmoritz#! perl
# Copyright (C) 2008, The Perl Foundation.
# $Id$

=head1 NAME

autounfudge - automatically write patches for unfudging spec tests

=head1 DESCRIPTION

This tool runs the non-pure tests of the C make target,
automatically creates files with less 'skip' fudge directives, runs them 
again, and if the
modified tests succeeds, it adds a patch to C that, when
applied as C<< patch -p0 < autounfudge.patch >>, removes the superfluous fudge
directives.

With the C<--untodo> option, C skip markers are also removed (where
appropriate), with the C<--unskip> option it tries to substitute C
markers by C markers.

=head1 USAGE

Most common usage: C. For more options
please run this script without any options or command line parameters.

=head1 WARNINGS

This tool assumes that all fudge directives are orthogonal,
which might not be the case in real world tests. So always make sure to
run C before committing the changes.

Never blindly apply the automatically generated patch.

=head1 MISCELLANEA

Fudge directives containing the words I, I or I  
are ignored.
The latter is because Unicode related tests can succeed on platforms with icu
installed, and fail on other platforms.

By default some files are skipped (which can be overridden with the
C<--exclude> option) because certain tests loop (at the time of writing
C), others because processing them
simply takes too long; C contains more than 250
fudge lines and thus would take about three hours to automatically unfudge.

=cut

use strict;
use warnings;

use Getopt::Long;
use Fatal qw(close);
use File::Temp qw(tempfile tempdir);
use TAP::Harness;
use TAP::Parser::Aggregator;
use Cwd qw(getcwd);
use File::Spec;
use File::Path;
use Text::Diff;
use threads;
use threads::shared;
use Thread::Queue;

my $impl = 'rakudo';
our $debug = 0;
our $out_filename = 'autounfudge.patch';
my $exclude = '(?!)';
our $threads_num = 1;
my $jvm;

GetOptions  'impl=s'        => \$impl,
            'debug'         => \$debug,
            'specfile=s'    => \my $specfile,
            'auto'          => \my $auto,
            'keep-env'      => \my $keep_env,
            'unskip'        => \my $unskip,
            'untodo'        => \my $untodo,
            'section=s'     => \my $section,
            'out=s'         => \$out_filename,
            'exclude'       => \$exclude,
            'jobs=i'        => \$threads_num,
            'jvm'           => \$jvm,
            or usage();

my $path_sep = $^O eq 'MSWin32' ? ';' : ':';
my $slash    = $^O eq 'MSWin32' ? '\\' : '/';
$ENV{PERL6LIB} = join($path_sep, qw/lib ./) unless $keep_env;
my $impl_re = quotemeta $impl;

if ($impl eq 'rakudo') {
    my $postfix = $jvm ? 'jvm' : 'parrot';
    $impl_re = qr{rakudo(?:\.$postfix)?(?=\s)};
}

my %fh;
sub eval_server {
    # leak the filehandle; it will be closed at exit, robustly telling the server to terminate
    return unless $jvm;
    my $token = int(100_000 * rand);
    
    open my $pipe, "| .${slash}perl6-eval-server -bind-stdin -cookie $token -app .${slash}perl6.jar" or die "cannot fork eval server: $!\n";
    $fh{$token} = $pipe;
    sleep 1;
    return $token;
}

my @files;

$specfile = 't/spectest.data' if $auto;

if ($specfile){
    @files = read_specfile($specfile);
}
else {
    @files = @ARGV or usage();
}

if ($section) {
    my $s = ($section =~ m/^\d{1,2}$/)
            ? sprintf('S%02d', $section)
            : $section;
    print "Only of section `$s'\n";
    @files = grep { m{ spec [/\\] \Q$s\E  }x } @files;
}

our $diff_lock :shared = 0;
open our $diff_fh, '>', $out_filename
    or die "Can't open '$out_filename' for writing: $!";
{
    select $diff_fh;
    $| = 1;
    select STDOUT;
}

our $tmp_dir = tempdir('RAKUDOXXXXXX', CLEANUP => 1);

if ($threads_num > 1) {
    my $queue = Thread::Queue->new;
    for (1..$threads_num) {
        threads->create(sub {
                my $token = eval_server();
                while(my $file_name = $queue->dequeue) {
                    auto_unfudge_file($file_name, $token);
                }
            });
    }

    $queue->enqueue($_) for @files;
    $queue->enqueue(undef) for 1..$threads_num;
    $_->join for threads->list;
}
else {
    my $token = eval_server();
    for (@files) {
        auto_unfudge_file($_, $token);
    }
}


sub auto_unfudge_file {
    my ($file_name, $token) = @_;

    return unless defined $file_name;
    open my $f, '<:encoding(UTF-8)', $file_name
        or die "Can't open '$file_name' for reading: $!";
    print "Processing file '$file_name'\n";
    my @fudge_lines;
    while (<$f>) {
        push @fudge_lines, [$. , $_] if m/^\s*#\?$impl_re/ &&
            !m/unspecced|unicode|utf-?8|noauto/i;
    }
    close $f;
    if (@fudge_lines){
        print "Found " . (scalar @fudge_lines) . " fudges...\n" if $debug;
    }
    else {
        print "No fudges found. Nothing to do\n" if $debug;
        return;
    }
    my $fudged = fudge($file_name);
    print "Fudged: $fudged\n" if $debug;
    if (!tests_ok($fudged, $token)){
        print "File '$file_name' doesn't even pass in its current state\n";
        return;
    }
    my @to_unfudge;
    for my $to_unfudge (@fudge_lines){
        print "trying line $to_unfudge->[0]...\n" if $debug;
        next if $to_unfudge->[1] =~ m/\btodo\b/ && !$untodo;
        $fudged = fudge(unfudge_some($file_name, [$to_unfudge->[0], '']));
        if (tests_ok($fudged, $token)){
            print "WOOOOOT: Can remove fudge instruction on line $to_unfudge->[0]\n"
                if $debug;
            push @to_unfudge, [$to_unfudge->[0], ''],
        } 
        elsif ($unskip && $to_unfudge->[1] =~ s/\bskip\b/todo/) {
            # try to replace 'skip' with 'todo'-markers
            $fudged = fudge(unfudge_some($file_name, $to_unfudge));
            if (tests_ok($fudged, $token)){
                print "s/skip/todo/ successful\n" if $debug;
                push @to_unfudge, $to_unfudge;
            }
        }
        else {
            print "not successful\n"if $debug;
        }
    }

    if (@to_unfudge){
        my $u = unfudge_some($file_name, @to_unfudge);
        lock($diff_lock);
        print $diff_fh diff($file_name, $u);
        unlink $u;
    }

}

sub fudge {
    my $fn = shift;

    open my $p, '-|', 't/spec/fudge', '--keep-exit-code',  $impl, $fn
        or die "Can't launch fudge: $!";
    my $ret_fn = <$p>;
    chomp $ret_fn;
    1 while <$p>;
    close $p;
    return $ret_fn;
}

sub usage {
    die <<"USAGE"
Usage:
    $0 [options] file+
Valid options:
    --debug             Enable debug output
    --impl impl         Specify a different implementation
    --specfile file     Specification file to read filenames from
    --auto              use t/spectest.data for --specfile
    --keep-env          Keep PERL6LIB environment variable.
    --exclude regex     Don't run the tests that match regex
    --section number    Run only on tests belonging to section 
    --unskip            Try to change 'skip' to 'todo' markers
    --untodo            Try to remove 'todo' markers
    --out               Output patch file (defaults to "autounfudge.patch")
    --jobs number       Number of threads to use when processing 
    --jvm               For Rakudo running on the JVM
USAGE
}

sub unfudge_some {
    my ($file, @lines) = @_;

    my ($fh, $tmp_filename) = tempfile(
            'tempXXXXX',
            SUFFIX => '.t',
            DIR => $tmp_dir
    );
    open my $in, '<', $file
        or die "Can't open file '$file' for reading: $!";
    while (<$in>){
        if ($. == $lines[0][0]){
            print $fh $lines[0][1];
            shift @lines if @lines > 1;
        }
        else {
            print $fh $_;
        }
    }
    close $fh;
    close $in;
    return $tmp_filename;
}

sub tests_ok {
    my ($fn, $token) = @_;

    $fn =~ s/\s+\z//;
    my $harness = get_harness($token);
    my $agg = TAP::Parser::Aggregator->new();
    $agg->start();
    $harness->aggregate_tests($agg, $fn);
    $agg->stop();

    print "Exit status " . $agg->exit  . "\n" if $debug;

    return !$agg->has_errors;
}

sub get_harness {
    my $token = shift;
    return TAP::Harness->new({
            verbosity   => -2,
            exec        => $jvm ? [$^X, "./eval-client.pl", $token, "run"] : [$^X, 'tools/perl6-limited.pl'],
            merge       => 1,
    });
}

sub read_specfile {
    my $fn = shift;

    my @res;
    open (my $f, '<', $fn) or die "Can't open file '$fn' for reading: $!";
    while (<$f>){
        next if m/#/;
        next unless m/\S/;
        next if m/$exclude/;
        m/(\S+)/ && push @res, "t/spec/$1";
    }
    return @res;
}

END {
    close $diff_fh if $diff_fh;
    File::Path::rmtree($tmp_dir);
}

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
rakudo-2013.12/tools/benchmark.pl0000664000175000017500000000371012224263172016234 0ustar  moritzmoritz#!/usr/bin/perl
use v5;
use Time::HiRes qw( gettimeofday tv_interval );

my %benchmarks = (
# The Hello World benchmark mostly exists to benchmark our start-up time.
"01 - hello world" => q{
    "Hello, world!"; # don't say, don't want output from benchmarks
},

# This one tests our performance at calling a single-dispatch sub (and the
# cost of signature binding somewhat). Note loop of 5,000 and 2 calls so it
# matches the other tests in all other respects.
"02 - 10,000 sub dispatches" => q{
    sub foo(Int $x, Int $y) { }
    for 1..5000 {
        foo(1,2);
        foo(1,2);
    }
},

# This one tests our performance for calling multi-dispatch subs.
"03 - 10,000 multi dispatches" => q{
    multi foo(Int $x, Str $y) { }
    multi foo(Str $x, Int $y) { }
    for 1..5000 {
        foo(1, "hi");
        foo("hi", 1);
    }
},

# This one tests our performance for method dispatch.
"04 - 10,000 method dispatches" => q{
    class A { method m1(Int $x, Int $y) { }; method m2(Int $x, Int $y) { } }
    my $x = A.new;
    for 1..5000 {
        $x.m1(1,2);
        $x.m2(1,2);
    }
},

# This one is for multi-method dispatch.
"05 - 10,000 multi-method dispatches" => q{
    class A {
        multi method m(Int $x, Str $y) { }
        multi method m (Str $x, Int $y) { }
    }
    my $x = A.new;
    for 1..5000 {
        $x.m(1, "hi");
        $x.m("hi", 1);
    }
},

# This one is for operators dispatch.
"06 - 10,000 operator dispatches" => q{
    my $x = 3;
    my $y = 39;
    for 1..5000 {
        $x + $y;
        $x - $y;
    }
},

# This one tests posfix:<++> performance.
"07 - postfix:<++> 10,000 times" => q{
    my $i = 0;
    while $i < 10000 { $i++ }
}
);

# Run the benchmarks and output results.
for (sort keys %benchmarks) {
    print "$_: ";
    open my $fh, "> bm_current.p6";
    print $fh $benchmarks{$_};
    close $fh;
    my $start = [gettimeofday];
    system('perl6 bm_current.p6') && die 'Error running benchmark';
    print tv_interval($start) . "\n";
}
rakudo-2013.12/tools/bisect-parrot.pl0000664000175000017500000000266212224263172017065 0ustar  moritzmoritz#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use 5.010;
# not using autodie for open() because of [perl #81572]
use autodie qw(close chdir);
use File::Path qw(remove_tree);

die <<"USAGE" unless @ARGV == 1;
Usage: $0 
Note that this script does some really drastic cleaning,
including 'git clean -xdf' in parrot/ and removing parrot_install.
Please run this script only in a source tree where you have no important
files (except those under version control)
USAGE

my $rakudo_dir = "$FindBin::Bin/..";

sub system_quietly {
    my ($program, @rest) = @_;
    open(my $h, '-|', $program, @rest) or die $!;
    1 while <$h>;
    close $h;
}

eval {

    say "Cleaning rakudo...";
    remove_tree "$rakudo_dir/parrot_install";
    chdir "$rakudo_dir";
    system("make",  "realclean") and 1;
    chdir "$rakudo_dir/parrot";
    say "..done";

    say "build parrot...";
    chdir "$rakudo_dir/parrot";
    system_quietly('git', 'clean', '-xdqf');
    system_quietly($^X, 'Configure.pl', "--prefix=$rakudo_dir/parrot_install",
            "--optimize", '--nomanicheck', '--cc=ccache gcc');
    system_quietly('make', '-j3');
    say "... installing parrot ...";
    system_quietly('make', 'install');
    say "... done building parrot";

    chdir $rakudo_dir;
    system_quietly($^X, 'Configure.pl');
    system('make', '-j3') == 0 or die "error during make: $!";
    exec('./perl6', $ARGV[0]);
};

if ($@) {
    say $@;
    exit 125;
}
rakudo-2013.12/tools/build/check-versions.pl0000664000175000017500000000170212250627156020330 0ustar  moritzmoritz#!/usr/bin/perl
# Copyright (C) 2008-2011, The Perl Foundation.

use strict;
use warnings;
use 5.008;
use lib 'tools/lib';
use NQP::Configure qw(slurp cmp_rev read_config);

if (-M 'Makefile' > -M 'tools/build/Makefile-Parrot.in') {
    die <catfile($prefix, 'bin') : $prefix;
my $jardir = $type eq 'install' ? File::Spec->catfile($prefix, 'languages', 'perl6', 'runtime') : $prefix;
my $libdir = $type eq 'install' ? File::Spec->catfile($prefix, 'languages', 'perl6', 'lib') : 'blib';
my $nqplibdir = File::Spec->catfile($nqpprefix, 'languages', 'nqp', 'lib');

sub install {
    my ($name, $command) = @_;

    my $install_to = File::Spec->catfile($destdir, $bindir, "$name$bat");

    print "Creating '$install_to'\n";
    open my $fh, ">", $install_to or die "open: $!";
    print $fh $preamble, $command, $postamble, "\n" or die "print: $!";
    close $fh or die "close: $!";

    chmod 0755, $install_to if $^O ne 'MSWin32';
}

my $bootclasspath = join($cpsep,
    ($thirdpartyjars,
    File::Spec->catfile($jardir, 'rakudo-runtime.jar'),
    File::Spec->catfile($jardir, 'perl6.jar')));
    
my $classpath = join($cpsep, ($jardir, $libdir, $nqplibdir));
my $jopts = '-Xms100m -Xbootclasspath/a:' . $bootclasspath 
          . ' -cp ' . $classpath
          . ' -Dperl6.prefix=' . $prefix;

install "perl6-j", "java $jopts perl6";
install "perl6-jdb-server", "java -Xdebug -Xrunjdwp:transport=dt_socket,address=8000,server=y,suspend=n $jopts perl6";
install "perl6-eval-server", "java $jopts org.perl6.nqp.tools.EvalServer";
cp(File::Spec->catfile($nqpprefix,'bin','eval-client.pl'), '.')
    or die "Couldn't copy 'eval-client.pl' from $nqpprefix: $!";
rakudo-2013.12/tools/build/gen-cat.pl0000664000175000017500000000152012224263172016714 0ustar  moritzmoritz#!/usr/bin/perl
# Copyright (C) 2008-2011, The Perl Foundation.

use strict;
use warnings;
use 5.008;

binmode STDOUT, ':utf8';

my ($backend, @files) = @ARGV;

print <<"END_HEAD";
# This file automatically generated by $0

END_HEAD

foreach my $file (@files) {
    print "# From $file\n\n";
    open(my $fh, "<:utf8",  $file) or die "$file: $!";
    my $in_cond = 0;
    my $in_omit = 0;
    while (<$fh>) {
        if (/^#\?if\s+(!)?\s*(\w+)\s*$/) {
            die "Nested conditionals not supported" if $in_cond;
            $in_cond = 1;
            $in_omit = $1 && $2 eq $backend || !$1 && $2 ne $backend;
        }
        elsif (/^#\?endif\s*$/) {
            $in_cond = 0;
            $in_omit = 0;
        }
        elsif (!$in_omit) {
            print;
        }
    }
    close $fh;
}

print "\n# vim: set ft=perl6 nomodifiable :\n";
rakudo-2013.12/tools/build/gen-version.pl0000664000175000017500000000136512224263172017641 0ustar  moritzmoritz#! perl

=head1 TITLE

gen-version.pl -- script to generate version information for HLL compilers

=cut

use POSIX 'strftime';

open(my $fh, '<', 'VERSION') or die $!;
my $VERSION = <$fh>;
close($fh);
chomp $VERSION;
my ($version, $release, $codename) = split(' ', $VERSION, 3);

if (-d '.git' && open(my $GIT, '-|', q|git describe --match "2*"|)) {
    $version = <$GIT>;
    close($GIT);
}

chomp $version;

my $builddate = strftime('%Y-%m-%dT%H:%M:%SZ', gmtime);

print <<"END_VERSION";
sub hll-config(\$config) {
    \$config           := 'rakudo';
    \$config        := '$version';
    \$config := '$release';
    \$config       := '$codename';
    \$config     := '$builddate';
}
END_VERSION

0;

rakudo-2013.12/tools/build-localtest.pl0000664000175000017500000000111712224263172017370 0ustar  moritzmoritz#! perl

=head1 NAME

build-localtest.pl - Create a t/localtest.data file from test output.

=head1 SYNOPSIS

perl tools/build-localtest.pl t/localtest.data

=head1 DESCRIPTION

This almost doesn't deserve to be a script.  It simply reads standard
input looking for things of the form "t/spec/*/*.(t|rakudo)", then
prints those to the standard output.  Typically I simply run the
script, then copy-and-paste the summary results of a test run into
the window and capture the results to t/localtest.data .

=cut

while (<>) {
    m!t/spec/(.*?)\.(t|rakudo)! && print "$1.t\n";
}
rakudo-2013.12/tools/build/Makefile-common.in0000664000175000017500000000125512255230273020401 0ustar  moritzmoritz# Copyright (C) 2006-2013, The Perl Foundation.

PERL    = @perl@
PROVE   = prove
MKPATH  = $(PERL) -MExtUtils::Command -e mkpath
CHMOD   = $(PERL) -MExtUtils::Command -e chmod
CP      = $(PERL) -MExtUtils::Command -e cp
RM_F    = $(PERL) -MExtUtils::Command -e rm_f
RM_RF   = $(PERL) -MExtUtils::Command -e rm_rf

BOOTSTRAP_SOURCES = \
  src/Perl6/Metamodel/BOOTSTRAP.nqp \
  src/Perl6/Metamodel/EXPORTHOW.nqp \

spectest_checkout : t/spec
t/spec :
	git clone git://github.com/perl6/roast.git t/spec
	-cd t/spec/ && git config remote.origin.pushurl git@github.com:perl6/roast.git

spectest_update :
	-cd t/spec && git pull

t/localtest.data:
	$(PERL) -MExtUtils::Command -e test_f $@
rakudo-2013.12/tools/build/Makefile-JVM.in0000664000175000017500000003146112255230273017547 0ustar  moritzmoritzJAVA    = java
JAVAC   = javac
JAR     = jar
J_NQP   = @j_nqp@
J_GEN_CAT = tools/build/gen-cat.pl jvm

PREFIX = @prefix@
NQP_PREFIX = @nqp_prefix@

J_BUILD_DIR = gen/jvm

PERL6_LANG_DIR = $(PREFIX)/languages/perl6

NQP_JARS = @nqp_jars@

RUN_PERL6 = $(JAVA) -Xss1m -Xms500m -Xmx1600m -Xbootclasspath/a:.@cpsep@$(NQP_JARS)@cpsep@rakudo-runtime.jar@cpsep@perl6.jar -cp @nqp_classpath@ perl6

RUNTIME_JAVAS = src/vm/jvm/runtime/org/perl6/rakudo/*.java

RUNTIME_JAR = rakudo-runtime.jar

RUNNER = @j_runner@

# files we create
PERL6_JAR     = perl6.jar
PERL6_ML_JAR  = blib/Perl6/ModuleLoader.jar
PERL6_W_JAR   = blib/Perl6/World.jar
PERL6_G_JAR   = blib/Perl6/Grammar.jar
PERL6_OPS_JAR = blib/Perl6/Ops.jar
PERL6_A_JAR   = blib/Perl6/Actions.jar
PERL6_O_JAR   = blib/Perl6/Optimizer.jar
PERL6_P_JAR   = blib/Perl6/Pod.jar
PERL6_C_JAR   = blib/Perl6/Compiler.jar
PERL6_M_JAR   = blib/Perl6/Metamodel.jar
PERL6_B_JAR   = blib/Perl6/BOOTSTRAP.jar
SETTING_JAR   = CORE.setting.jar

PERL6_LANG_JARS = $(PERL6_ML_JAR) $(PERL6_W_JAR) $(PERL6_G_JAR) $(PERL6_OPS_JAR) $(PERL6_A_JAR) \
  $(PERL6_O_JAR) $(PERL6_P_JAR) $(PERL6_C_JAR) $(PERL6_M_JAR) $(PERL6_B_JAR)

J_METAMODEL_SOURCES = \
  src/Perl6/Metamodel/Archetypes.nqp \
  src/Perl6/Metamodel/Naming.nqp \
  src/Perl6/Metamodel/Documenting.nqp \
  src/Perl6/Metamodel/Stashing.nqp \
  src/Perl6/Metamodel/Versioning.nqp \
  src/Perl6/Metamodel/TypePretense.nqp \
  src/Perl6/Metamodel/MethodDelegation.nqp \
  src/Perl6/Metamodel/BoolificationProtocol.nqp \
  src/Perl6/Metamodel/PackageHOW.nqp \
  src/Perl6/Metamodel/ModuleHOW.nqp \
  src/Perl6/Metamodel/GenericHOW.nqp \
  src/Perl6/Metamodel/AttributeContainer.nqp \
  src/Perl6/Metamodel/MethodContainer.nqp \
  src/Perl6/Metamodel/PrivateMethodContainer.nqp \
  src/Perl6/Metamodel/MultiMethodContainer.nqp \
  src/Perl6/Metamodel/RoleContainer.nqp \
  src/Perl6/Metamodel/MultipleInheritance.nqp \
  src/Perl6/Metamodel/DefaultParent.nqp \
  src/Perl6/Metamodel/BaseType.nqp \
  src/Perl6/Metamodel/C3MRO.nqp \
  src/Perl6/Metamodel/MROBasedMethodDispatch.nqp \
  src/Perl6/Metamodel/MROBasedTypeChecking.nqp \
  src/Perl6/Metamodel/Trusting.nqp \
  src/Perl6/Metamodel/Mixins.nqp \
  src/Perl6/Metamodel/BUILDPLAN.nqp \
  src/Perl6/Metamodel/REPRComposeProtocol.nqp \
  src/Perl6/Metamodel/InvocationProtocol.nqp \
  src/Perl6/Metamodel/RolePunning.nqp \
  src/Perl6/Metamodel/ArrayType.nqp \
  src/Perl6/Metamodel/RoleToRoleApplier.nqp \
  src/Perl6/Metamodel/ConcreteRoleHOW.nqp \
  src/Perl6/Metamodel/CurriedRoleHOW.nqp \
  src/Perl6/Metamodel/ParametricRoleHOW.nqp \
  src/Perl6/Metamodel/ParametricRoleGroupHOW.nqp \
  src/Perl6/Metamodel/RoleToClassApplier.nqp \
  src/Perl6/Metamodel/ClassHOW.nqp \
  src/Perl6/Metamodel/GrammarHOW.nqp \
  src/Perl6/Metamodel/NativeHOW.nqp \
  src/Perl6/Metamodel/SubsetHOW.nqp \
  src/Perl6/Metamodel/EnumHOW.nqp \
  src/Perl6/Metamodel/ContainerDescriptor.nqp \
  src/Perl6/Metamodel/Dispatchers.nqp \
  src/vm/jvm/Perl6/Metamodel/JavaHOW.nqp \

# The ordering here is important for bootstrapping reasons. In general:
# * traits almost certainly have to come first
# * stubs have to come after traits since they use them
# * Attribute needs to come before anything that uses an attribute
# We break various other circularities in Perl6::Metamodel::BOOTSTRAP.
# Note that you only really have to worry especially about things that
# the compiler will instantiate/call methods on while compiling the
# setting - basically anything that feels MOP-ish.
J_CORE_SOURCES = \
  src/core/core_prologue.pm \
  src/core/traits.pm \
  src/core/Positional.pm \
  src/core/Associative.pm \
  src/core/Callable.pm \
  src/core/natives.pm \
  src/core/stubs.pm \
  src/core/control.pm \
  src/core/Mu.pm \
  src/core/Stringy.pm \
  src/core/Any.pm \
  src/core/array_slice.pm \
  src/core/hash_slice.pm \
  src/core/Scalar.pm \
  src/core/Code.pm \
  src/core/WhateverCode.pm \
  src/core/Block.pm \
  src/core/Attribute.pm \
  src/core/Variable.pm \
  src/core/Routine.pm \
  src/core/Sub.pm \
  src/core/Macro.pm \
  src/core/Method.pm \
  src/core/Submethod.pm \
  src/core/Junction.pm \
  src/core/Cool.pm \
  src/core/Enumeration.pm \
  src/core/Whatever.pm \
  src/core/Bool.pm \
  src/core/Numeric.pm \
  src/core/Real.pm \
  src/core/Int.pm \
  src/core/Order.pm \
  src/core/UInt64.pm \
  src/core/Num.pm \
  src/core/Buf.pm \
  src/core/Str.pm \
  src/core/Capture.pm \
  src/core/Parcel.pm \
  src/core/Iterable.pm \
  src/core/Iterator.pm \
  src/core/Nil.pm \
  src/core/Range.pm \
  src/core/ListIter.pm \
  src/core/MapIter.pm \
  src/core/GatherIter.pm \
  src/core/List.pm \
  src/core/LoL.pm \
  src/core/Array.pm \
  src/core/Enum.pm \
  src/core/Pair.pm \
  src/core/HashIter.pm \
  src/core/EnumMap.pm \
  src/core/Hash.pm \
  src/core/Stash.pm \
  src/core/PseudoStash.pm \
  src/core/Parameter.pm \
  src/core/Signature.pm \
  src/core/Rational.pm \
  src/core/Rat.pm \
  src/core/Complex.pm \
  src/core/Backtrace.pm \
  src/core/Exception.pm \
  src/core/Failure.pm \
  src/core/Match.pm \
  src/core/Cursor.pm \
  src/core/Grammar.pm \
  src/core/Regex.pm \
  src/core/IO/Spec/Unix.pm \
  src/core/IO/Spec/Win32.pm \
  src/core/IO/Spec/Cygwin.pm \
  src/core/IO/Spec.pm \
  src/core/IO.pm \
  src/core/IO/ArgFiles.pm \
  src/core/AST.pm \
  src/core/CallFrame.pm \
  src/core/Main.pm \
  src/core/tai-utc.pm \
  src/core/Instant.pm \
  src/core/Duration.pm \
  src/core/Temporal.pm \
  src/core/EXPORTHOW.pm \
  src/core/Pod.pm \
  src/core/QuantHash.pm \
  src/core/Setty.pm \
  src/core/Set.pm \
  src/core/SetHash.pm \
  src/core/Baggy.pm \
  src/core/Bag.pm \
  src/core/BagHash.pm \
  src/core/Mixy.pm \
  src/core/Mix.pm \
  src/core/MixHash.pm \
  src/core/set_operators.pm \
  src/core/ObjAt.pm \
  src/core/Version.pm \
  src/core/ForeignCode.pm \
  src/core/operators.pm \
  src/core/metaops.pm \
  src/core/precedence.pm \
  src/core/terms.pm \
  src/core/Deprecations.pm \
  src/vm/jvm/core/Thread.pm \
  src/vm/jvm/core/Lock.pm \
  src/vm/jvm/core/Scheduler.pm \
  src/vm/jvm/core/ThreadPoolScheduler.pm \
  src/vm/jvm/core/CurrentThreadScheduler.pm \
  src/vm/jvm/core/Promise.pm \
  src/vm/jvm/core/Channel.pm \
  src/vm/jvm/core/Supply.pm \
  src/vm/jvm/core/SupplyOperations.pm \
  src/vm/jvm/core/KeyReducer.pm \
  src/vm/jvm/core/IOAsyncFile.pm \
  src/vm/jvm/core/asyncops.pm \
  src/core/IO/Socket.pm \
  src/core/IO/Socket/INET.pm \
  src/core/OS.pm \
  src/core/core_epilogue.pm \

J_CLEANUPS = \
  *.manifest \
  blib/Perl6/*.jar \
  $(SETTING_JAR) \
  $(PERL6_JAR) \
  lib/Test.jar \
  lib/lib.jar \
  lib/Pod/To/Text.jar \
  blib/Test.jar \
  blib/lib.jar \
  blib/Pod/To/Text.jar \
  j-rakudo_test_run.tar.gz \
  $(J_BUILD_DIR)/* \
  $(RUNTIME_JAR) \
  perl6-eval-server \
  perl6-jdb-server \
  eval-client.pl \
  $(RUNNER)

J_HARNESS_WITH_FUDGE = $(PERL) t/harness --fudge --keep-exit-code --jvm
HARNESS = $(PERL) t/harness --jvm

j-all: $(PERL6_JAR) $(SETTING_JAR) $(RUNNER) blib/Test.jar blib/lib.jar blib/Pod/To/Text.jar

$(RUNTIME_JAR): $(RUNTIME_JAVAS)
	$(PERL) -MExtUtils::Command -e mkpath bin
	$(JAVAC) -source 1.7 -cp $(NQP_JARS) -g -d bin $(RUNTIME_JAVAS)
	$(JAR) cf0 rakudo-runtime.jar -C bin/ .

$(PERL6_ML_JAR): src/Perl6/ModuleLoader.nqp src/vm/jvm/ModuleLoaderVMConfig.nqp src/vm/jvm/Perl6/JavaModuleLoader.nqp
	$(PERL) $(J_GEN_CAT) src/vm/jvm/ModuleLoaderVMConfig.nqp src/Perl6/ModuleLoader.nqp src/vm/jvm/Perl6/JavaModuleLoader.nqp > $(J_BUILD_DIR)/ModuleLoader.nqp
	$(J_NQP) --target=jar --output=$(PERL6_ML_JAR) --encoding=utf8 \
	    $(J_BUILD_DIR)/ModuleLoader.nqp

$(PERL6_W_JAR): $(PERL6_ML_JAR) src/Perl6/World.nqp
	$(J_NQP) --target=jar --output=$(PERL6_W_JAR) --encoding=utf8 \
	    src/Perl6/World.nqp

$(PERL6_P_JAR): src/Perl6/Pod.nqp
	$(J_NQP) --target=jar --output=$(PERL6_P_JAR) --encoding=utf8 \
	    src/Perl6/Pod.nqp

$(PERL6_OPS_JAR): src/vm/jvm/Perl6/Ops.nqp
	$(J_NQP) --target=jar --output=$(PERL6_OPS_JAR) --encoding=utf8 \
	    src/vm/jvm/Perl6/Ops.nqp

$(PERL6_A_JAR): src/Perl6/Actions.nqp $(PERL6_P_JAR) $(PERL6_OPS_JAR)
	$(J_NQP) --target=jar --output=$(PERL6_A_JAR) --encoding=utf8 \
	    src/Perl6/Actions.nqp

$(PERL6_G_JAR): src/Perl6/Grammar.nqp $(PERL6_W_JAR) $(PERL6_A_JAR) $(PERL6_P_JAR)
	$(J_NQP) --target=jar --output=$(PERL6_G_JAR) --encoding=utf8 \
	    src/Perl6/Grammar.nqp

$(PERL6_O_JAR): src/Perl6/Optimizer.nqp $(PERL6_OPS_JAR)
	$(J_NQP) --target=jar --output=$(PERL6_O_JAR) --encoding=utf8 \
	    src/Perl6/Optimizer.nqp

$(PERL6_C_JAR): src/Perl6/Compiler.nqp $(PERL6_O_JAR)
	$(J_NQP) --target=jar --output=$(PERL6_C_JAR) --encoding=utf8 \
	    src/Perl6/Compiler.nqp

$(PERL6_JAR): src/main.nqp $(RUNTIME_JAR) $(PERL6_G_JAR) $(PERL6_A_JAR) $(PERL6_C_JAR) $(PERL6_P_JAR)
	$(PERL) tools/build/gen-version.pl > $(J_BUILD_DIR)/main-version.nqp
	$(PERL) $(J_GEN_CAT) src/main.nqp $(J_BUILD_DIR)/main-version.nqp > $(J_BUILD_DIR)/main.nqp
	$(J_NQP) --target=jar --javaclass=perl6 --output=$(PERL6_JAR) \
	    $(J_BUILD_DIR)/main.nqp

$(PERL6_M_JAR): $(J_METAMODEL_SOURCES) $(PERL6_OPS_JAR)
	$(PERL) $(J_GEN_CAT) $(J_METAMODEL_SOURCES) > $(J_BUILD_DIR)/Metamodel.nqp
	$(J_NQP) --target=jar --output=$(PERL6_M_JAR) --encoding=utf8 \
	    $(J_BUILD_DIR)/Metamodel.nqp

$(PERL6_B_JAR): $(BOOTSTRAP_SOURCES) $(PERL6_M_JAR)
	$(PERL) $(J_GEN_CAT) $(BOOTSTRAP_SOURCES) > $(J_BUILD_DIR)/BOOTSTRAP.nqp
	$(PERL) tools/build/nqp-jvm-rr.pl $(J_NQP) --target=jar \
        --output=$(PERL6_B_JAR) --encoding=utf8 $(J_BUILD_DIR)/BOOTSTRAP.nqp

$(SETTING_JAR): $(PERL6_JAR) $(PERL6_B_JAR) $(J_CORE_SOURCES)
	$(PERL) $(J_GEN_CAT) $(J_CORE_SOURCES) > $(J_BUILD_DIR)/CORE.setting
	@echo "The following step can take a long time, please be patient."
	$(RUN_PERL6) --setting=NULL --optimize=3 --target=jar --stagestats --output=$(SETTING_JAR) $(J_BUILD_DIR)/CORE.setting

$(RUNNER):
	$(PERL) tools/build/create-jvm-runner.pl dev . . $(NQP_PREFIX) $(NQP_JARS)

j-runner-default: j-all
	$(CP) $(RUNNER) perl6$(BAT)
	$(CHMOD) 755 perl6$(BAT)


##  testing targets
blib/Test.jar: lib/Test.pm $(PERL6_JAR) $(SETTING_JAR) $(RUNNER)
	.@slash@$(RUNNER) --target=jar --output=blib/Test.jar lib/Test.pm

blib/lib.jar: lib/lib.pm6 $(PERL6_JAR) $(SETTING_JAR) $(RUNNER)
	.@slash@$(RUNNER) --target=jar --output=blib/lib.jar lib/lib.pm6

blib/Pod/To/Text.jar: lib/Pod/To/Text.pm $(PERL6_JAR) $(SETTING_JAR) $(RUNNER)
	$(MKPATH) blib/Pod/To
	.@slash@$(RUNNER) --target=jar --output=blib/Pod/To/Text.jar lib/Pod/To/Text.pm

j-test    : j-coretest

j-fulltest: j-coretest j-stresstest

j-coretest: j-all
	$(HARNESS) t/00-parrot t/01-sanity

# Run the spectests that we know work.
j-spectest: j-testable t/spectest.data
	$(J_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data

j-spectest_full: j-testable
	$(J_HARNESS_WITH_FUDGE) t/spec

j-quicktest: j-testable t/spectest.data
	$(J_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data --long=0

j-stresstest: j-testable t/spectest.data
	$(J_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data --stress=1

j-rakudo_test_run.tar.gz: j-testable t/spectest.data
	- $(J_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data --archive j-rakudo_test_run.tar.gz

#spectest_smolder: rakudo_test_run.tar.gz
#	./perl6 -e "shell qqx[git log -1 --pretty=format:%H].fmt(qq[curl -F architecture=@cpuarch@ -F platform=@osname@ -F revision=%s -F report_file=@rakudo_test_run.tar.gz -F username=parrot-autobot -F password=qa_rocks http://smolder.parrot.org/app/projects/process_add_report/5])"

j-testable : j-all spectest_checkout spectest_update


# Run the tests in t/localtest.data
localtest: j-all spectest_checkout t/localtest.data
	@$(J_HARNESS_WITH_FUDGE) --tests-from-file=t/localtest.data

# Run the tests in t/localtest.data with a higher verbosity
localtest_loud: j-all spectest_checkout t/localtest.data
	@$(J_HARNESS_WITH_FUDGE) --tests-from-file=t/localtest.data --verbosity=1

# Run many tests of your choice.
# make sometests TESTFILES=t/foo/bar
sometests: j-all
	@$(J_HARNESS_WITH_FUDGE) $(TESTFILES)

j-install: j-all tools/build/create-jvm-runner.pl
	$(MKPATH) $(DESTDIR)$(PREFIX)/bin
	$(MKPATH) $(DESTDIR)$(PERL6_LANG_DIR)/lib/Perl6
	$(MKPATH) $(DESTDIR)$(PERL6_LANG_DIR)/runtime
	$(CP) $(PERL6_LANG_JARS) $(DESTDIR)$(PERL6_LANG_DIR)/lib/Perl6
	$(CP) $(SETTING_JAR) $(DESTDIR)$(PERL6_LANG_DIR)/runtime
	$(CP) $(PERL6_JAR) $(DESTDIR)$(PERL6_LANG_DIR)/runtime
	$(CP) $(RUNTIME_JAR) $(DESTDIR)$(PERL6_LANG_DIR)/runtime
	$(CP) blib/Test.jar $(DESTDIR)$(PERL6_LANG_DIR)/lib
	$(CP) blib/lib.jar $(DESTDIR)$(PERL6_LANG_DIR)/lib
	$(MKPATH) $(DESTDIR)$(PERL6_LANG_DIR)/lib/Pod/To
	$(CP) blib/Pod/To/Text.jar $(DESTDIR)$(PERL6_LANG_DIR)/lib/Pod/To
	$(PERL) tools/build/create-jvm-runner.pl install "$(DESTDIR)" $(PREFIX) $(NQP_PREFIX) $(NQP_JARS)

j-runner-default-install: j-install
	$(PERL) tools/build/create-jvm-runner.pl install "$(DESTDIR)" $(PREFIX) $(NQP_PREFIX) $(NQP_JARS)
	$(CP) $(DESTDIR)$(PREFIX)/bin/perl6-j$(BAT) $(DESTDIR)$(PREFIX)/bin/perl6$(BAT)
	$(CHMOD) 755 $(DESTDIR)$(PREFIX)/bin/perl6$(BAT)

##  cleaning
j-clean:
	$(RM_F) $(J_CLEANUPS)
	$(RM_RF) bin

j-distclean: realclean

j-realclean: clean
	$(RM_F) Makefile

j-testclean:
rakudo-2013.12/tools/build/Makefile-Parrot.in0000664000175000017500000005152412255230273020364 0ustar  moritzmoritzSHELL            = @shell@
PARROT_ARGS      =

# values from parrot_config
PARROT_BIN_DIR     = @bindir@
PARROT_LIB_SHARED  = @libparrot_shared@
PARROT_VERSION     = @versiondir@
PARROT_INCLUDE_DIR = @includedir@$(PARROT_VERSION)
PARROT_LIB_DIR     = @libdir@$(PARROT_VERSION)
PARROT_SRC_DIR     = @srcdir@$(PARROT_VERSION)
HAS_ICU            = @has_icu@

CC            = @cc@
CFLAGS        = @ccflags@ @cc_shared@ @cc_debug@ @ccwarn@ @gc_flag@ @optimize@
EXE           = @exe@
LD            = @ld@
LDFLAGS       = @ldflags@ @ld_debug@
LD_LOAD_FLAGS = @ld_load_flags@
LIBPARROT     = @inst_libparrot_ldflags@
O             = @o@
LOAD_EXT      = @load_ext@
POD2MAN       = @pod2man@

# locations of parrot and nqp resources
PARROT           = $(PARROT_BIN_DIR)/parrot$(EXE)
PARROT_DLL        = @dll@
PARROT_DLL_COPY   = @dllcopy@
NQP_EXE          = $(PARROT_BIN_DIR)/nqp-p$(EXE)
NQP_LANG_DIR     = $(PARROT_LIB_DIR)/languages/nqp
PBC_TO_EXE       = $(PARROT_BIN_DIR)/pbc_to_exe$(EXE)
PARROT_TOOLS_DIR = $(PARROT_LIB_DIR)/tools
PARROT_PERL_LIB  = $(PARROT_TOOLS_DIR)/lib
OPS2C            = $(PARROT_BIN_DIR)/ops2c$(EXE)
CINCLUDES        = -I$(PARROT_INCLUDE_DIR) -I$(PARROT_INCLUDE_DIR)/pmc
LINKARGS         = $(LDFLAGS) $(LD_LOAD_FLAGS) $(LIBPARROT) @libs@ @icu_shared@
P_GEN_CAT        = tools/build/gen-cat.pl parrot
P_BUILD_DIR      = gen/parrot

# rakudo directories
DYNEXT_DIR     = dynext
OPS_DIR        = src/vm/parrot/ops
P_PERL6_LANG_DIR = $(PARROT_LIB_DIR)/languages/perl6
MANDIR         = @mandir@
DOCDIR         = @prefix@/share/doc

# files we create
PERL6_PIR     = src/gen/perl6.pir
PERL6_PBC     = perl6.pbc
PERL6_EXE     = perl6-p$(EXE)
PERL6_ML      = src/gen/perl6-moduleloader.pir
PERL6_ML_PBC  = blib/Perl6/ModuleLoader.pbc
PERL6_W       = src/gen/perl6-symboltable.pir
PERL6_W_PBC   = blib/Perl6/World.pbc
PERL6_G       = src/gen/perl6-grammar.pir
PERL6_G_PBC   = blib/Perl6/Grammar.pbc
PERL6_OPS     = src/gen/perl6-ops.pir
PERL6_OPS_PBC = blib/Perl6/Ops.pbc
PERL6_A       = src/gen/perl6-actions.pir
PERL6_A_PBC   = blib/Perl6/Actions.pbc
PERL6_O       = src/gen/perl6-optimizer.pir
PERL6_O_PBC   = blib/Perl6/Optimizer.pbc
PERL6_P       = src/gen/perl6-pod.pir
PERL6_P_PBC   = blib/Perl6/Pod.pbc
PERL6_C       = src/gen/perl6-compiler.pir
PERL6_C_PBC   = blib/Perl6/Compiler.pbc
PERL6_M       = src/gen/perl6-metamodel.pir
PERL6_M_PBC   = blib/Perl6/Metamodel.pbc
PERL6_B       = src/gen/perl6-bootstrap.pir
PERL6_B_PBC   = blib/Perl6/BOOTSTRAP.pbc
SETTING_PIR   = src/gen/p-CORE.setting.pir
SETTING_PBC   = CORE.setting.pbc
R_SETTING_SRC = src/RESTRICTED.setting
R_SETTING_PIR = src/gen/RESTRICTED.setting.pir
R_SETTING_PBC = RESTRICTED.setting.pbc
GROUP         = perl6_group
OPS           = perl6_ops
DYNEXT_DYNOPS = $(DYNEXT_DIR)/$(OPS)$(LOAD_EXT)
DYNOPS        = $(OPS_DIR)/$(OPS)$(LOAD_EXT)

OPS_SOURCE   = perl6.ops

P_METAMODEL_SOURCES = \
  src/Perl6/Metamodel/Archetypes.nqp \
  src/Perl6/Metamodel/Naming.nqp \
  src/Perl6/Metamodel/Documenting.nqp \
  src/Perl6/Metamodel/Stashing.nqp \
  src/Perl6/Metamodel/Versioning.nqp \
  src/Perl6/Metamodel/TypePretense.nqp \
  src/Perl6/Metamodel/MethodDelegation.nqp \
  src/Perl6/Metamodel/BoolificationProtocol.nqp \
  src/Perl6/Metamodel/PackageHOW.nqp \
  src/Perl6/Metamodel/ModuleHOW.nqp \
  src/Perl6/Metamodel/GenericHOW.nqp \
  src/Perl6/Metamodel/AttributeContainer.nqp \
  src/Perl6/Metamodel/MethodContainer.nqp \
  src/Perl6/Metamodel/PrivateMethodContainer.nqp \
  src/Perl6/Metamodel/MultiMethodContainer.nqp \
  src/Perl6/Metamodel/RoleContainer.nqp \
  src/Perl6/Metamodel/MultipleInheritance.nqp \
  src/Perl6/Metamodel/DefaultParent.nqp \
  src/Perl6/Metamodel/BaseType.nqp \
  src/Perl6/Metamodel/C3MRO.nqp \
  src/Perl6/Metamodel/MROBasedMethodDispatch.nqp \
  src/Perl6/Metamodel/MROBasedTypeChecking.nqp \
  src/Perl6/Metamodel/Trusting.nqp \
  src/Perl6/Metamodel/Mixins.nqp \
  src/Perl6/Metamodel/BUILDPLAN.nqp \
  src/Perl6/Metamodel/REPRComposeProtocol.nqp \
  src/Perl6/Metamodel/InvocationProtocol.nqp \
  src/Perl6/Metamodel/ParrotInterop.nqp \
  src/Perl6/Metamodel/RolePunning.nqp \
  src/Perl6/Metamodel/ArrayType.nqp \
  src/Perl6/Metamodel/RoleToRoleApplier.nqp \
  src/Perl6/Metamodel/ConcreteRoleHOW.nqp \
  src/Perl6/Metamodel/CurriedRoleHOW.nqp \
  src/Perl6/Metamodel/ParametricRoleHOW.nqp \
  src/Perl6/Metamodel/ParametricRoleGroupHOW.nqp \
  src/Perl6/Metamodel/RoleToClassApplier.nqp \
  src/Perl6/Metamodel/ClassHOW.nqp \
  src/Perl6/Metamodel/GrammarHOW.nqp \
  src/Perl6/Metamodel/NativeHOW.nqp \
  src/Perl6/Metamodel/SubsetHOW.nqp \
  src/Perl6/Metamodel/EnumHOW.nqp \
  src/Perl6/Metamodel/ContainerDescriptor.nqp \
  src/Perl6/Metamodel/Dispatchers.nqp \

# The ordering here is important for bootstrapping reasons. In general:
# * traits almost certainly have to come first
# * stubs have to come after traits since they use them
# * Attribute needs to come before anything that uses an attribute
# We break various other circularities in Perl6::Metamodel::BOOTSTRAP.
# Note that you only really have to worry especially about things that
# the compiler will instantiate/call methods on while compiling the
# setting - basically anything that feels MOP-ish.
P_CORE_SOURCES = \
  src/core/core_prologue.pm \
  src/core/traits.pm \
  src/core/Positional.pm \
  src/core/Associative.pm \
  src/core/Callable.pm \
  src/core/natives.pm \
  src/core/stubs.pm \
  src/core/control.pm \
  src/core/Mu.pm \
  src/core/Stringy.pm \
  src/core/Any.pm \
  src/core/array_slice.pm \
  src/core/hash_slice.pm \
  src/core/Scalar.pm \
  src/core/Code.pm \
  src/core/WhateverCode.pm \
  src/core/Block.pm \
  src/core/Attribute.pm \
  src/core/Variable.pm \
  src/core/Routine.pm \
  src/core/Sub.pm \
  src/core/Macro.pm \
  src/core/Method.pm \
  src/core/Submethod.pm \
  src/core/Junction.pm \
  src/core/Cool.pm \
  src/core/Enumeration.pm \
  src/core/Whatever.pm \
  src/core/Bool.pm \
  src/core/Numeric.pm \
  src/core/Real.pm \
  src/core/Int.pm \
  src/core/Order.pm \
  src/core/UInt64.pm \
  src/core/Num.pm \
  src/core/Buf.pm \
  src/core/Str.pm \
  src/core/Capture.pm \
  src/core/Parcel.pm \
  src/core/Iterable.pm \
  src/core/Iterator.pm \
  src/core/Nil.pm \
  src/core/Range.pm \
  src/core/ListIter.pm \
  src/core/MapIter.pm \
  src/core/GatherIter.pm \
  src/core/List.pm \
  src/core/LoL.pm \
  src/core/Array.pm \
  src/core/Enum.pm \
  src/core/Pair.pm \
  src/core/HashIter.pm \
  src/core/EnumMap.pm \
  src/core/Hash.pm \
  src/core/Stash.pm \
  src/core/PseudoStash.pm \
  src/core/Parameter.pm \
  src/core/Signature.pm \
  src/core/Rational.pm \
  src/core/Rat.pm \
  src/core/Complex.pm \
  src/core/Backtrace.pm \
  src/core/Exception.pm \
  src/core/Failure.pm \
  src/core/Match.pm \
  src/core/Cursor.pm \
  src/core/Grammar.pm \
  src/core/Regex.pm \
  src/core/IO/Spec/Unix.pm \
  src/core/IO/Spec/Win32.pm \
  src/core/IO/Spec/Cygwin.pm \
  src/core/IO/Spec/QNX.pm \
  src/core/IO/Spec.pm \
  src/core/IO.pm \
  src/core/IO/ArgFiles.pm \
  src/core/IO/Socket.pm \
  src/core/IO/Socket/INET.pm \
  src/core/AST.pm \
  src/core/CallFrame.pm \
  src/core/Main.pm \
  src/core/tai-utc.pm \
  src/core/Instant.pm \
  src/core/Duration.pm \
  src/core/Temporal.pm \
  src/core/EXPORTHOW.pm \
  src/core/Pod.pm \
  src/core/QuantHash.pm \
  src/core/Setty.pm \
  src/core/Set.pm \
  src/core/SetHash.pm \
  src/core/Baggy.pm \
  src/core/Bag.pm \
  src/core/BagHash.pm \
  src/core/Mixy.pm \
  src/core/Mix.pm \
  src/core/MixHash.pm \
  src/core/set_operators.pm \
  src/core/ObjAt.pm \
  src/core/Version.pm \
  src/core/ForeignCode.pm \
  src/core/operators.pm \
  src/core/metaops.pm \
  src/core/precedence.pm \
  src/core/terms.pm \
  src/core/Deprecations.pm \
  src/core/OS.pm \
  src/core/core_epilogue.pm \

DOCS = README CREDITS LICENSE docs/*

P_CLEANUPS = \
  *.manifest \
  *.pdb \
  $(PERL6_PBC) \
  $(PERL6_EXE) \
  $(SETTING_PBC) \
  $(R_SETTING_PBC) \
  $(PARROT_DLL_COPY) \
  perl6-p.c \
  perl6-p$(O) \
  perl6_group.* \
  lib/Test.pir \
  lib/lib.pir \
  lib/Pod/To/Text.pir \
  p-rakudo_test_run.tar.gz \
  $(DYNEXT_DIR)/*$(LOAD_EXT) \
  src/gen/p-CORE.setting \
  src/gen/*.pir \
  src/gen/*.pbc \
  src/gen/*.pm \
  $(OPS_DIR)/*.h \
  $(OPS_DIR)/*.c \
  $(OPS_DIR)/*$(O) \
  $(OPS_DIR)/*$(LOAD_EXT) \
  src/vm/parrot/guts/*$(O) \
  blib/Perl6/*.pbc \
  gen/parrot/CORE.setting \
  gen/parrot/*.nqp \

# NOTE: eventually, we should remove --keep-exit-code and --fudge
#       as the goal is that all tests must pass without fudge
P_HARNESS_WITH_FUDGE = $(PERL) t/harness --fudge --keep-exit-code --icu=$(HAS_ICU)

STAGESTATS = @stagestats@

# the default target, TODO: make libraries in 'lib' a variable.
p-all: p-check-versions $(PERL6_EXE) $(SETTING_PBC) $(R_SETTING_PBC) lib/lib.pir lib/Test.pir lib/Pod/To/Text.pir

# the install target
p-install: p-all
	$(MKPATH)                     $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6
	$(CP) $(PERL6_ML_PBC)         $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/ModuleLoader.pbc
	$(CP) $(PERL6_W_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/World.pbc
	$(CP) $(PERL6_G_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Grammar.pbc
	$(CP) $(PERL6_OPS_PBC)        $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Ops.pbc
	$(CP) $(PERL6_A_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Actions.pbc
	$(CP) $(PERL6_O_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Optimizer.pbc
	$(CP) $(PERL6_P_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Pod.pbc
	$(CP) $(PERL6_C_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Compiler.pbc
	$(CP) $(PERL6_M_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/Metamodel.pbc
	$(CP) $(PERL6_B_PBC)          $(DESTDIR)$(NQP_LANG_DIR)/lib/Perl6/BOOTSTRAP.pbc
	$(MKPATH)                     $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(CP)     $(PERL6_PBC)        $(DESTDIR)$(P_PERL6_LANG_DIR)
	$(CP)     $(SETTING_PBC)      $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(CP)     $(R_SETTING_PBC)    $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(CP)     lib/Test.pm         $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(CP)     lib/Test.pir        $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(CP)     lib/lib.pm6         $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(CP)     lib/lib.pir         $(DESTDIR)$(P_PERL6_LANG_DIR)/lib
	$(MKPATH) 					  $(DESTDIR)$(P_PERL6_LANG_DIR)/lib/Pod/To
	$(CP)     lib/Pod/To/Text.pm  $(DESTDIR)$(P_PERL6_LANG_DIR)/lib/Pod/To
	$(CP)     lib/Pod/To/Text.pir $(DESTDIR)$(P_PERL6_LANG_DIR)/lib/Pod/To
	$(MKPATH)                     $(DESTDIR)$(PARROT_LIB_DIR)/dynext
	$(CP)     $(DYNOPS)           $(DESTDIR)$(PARROT_LIB_DIR)/dynext
	$(MKPATH)                     $(DESTDIR)$(PARROT_BIN_DIR)
	$(CP)     $(PERL6_EXE)        $(DESTDIR)$(PARROT_BIN_DIR)
	$(CHMOD)  755                 $(DESTDIR)$(PARROT_BIN_DIR)/$(PERL6_EXE)
	$(MKPATH)                     $(DESTDIR)$(DOCDIR)/rakudo
	$(MKPATH)                     $(DESTDIR)$(DOCDIR)/rakudo/announce
	-$(CP)    $(DOCS)             $(DESTDIR)$(DOCDIR)/rakudo
	$(CP)     docs/announce/*     $(DESTDIR)$(DOCDIR)/rakudo/announce
	$(MKPATH) $(DESTDIR)$(MANDIR)/man1
	-$(POD2MAN) docs/running.pod --name=perl6 > $(DESTDIR)$(MANDIR)/man1/perl6.1
	-$(POD2MAN) docs/running.pod --name=rakudo > $(DESTDIR)$(MANDIR)/man1/rakudo.1

p-runner-default-install: p-install
	$(CP)     $(PERL6_EXE)        $(DESTDIR)$(PARROT_BIN_DIR)/perl6$(EXE)
	$(CHMOD)  755                 $(DESTDIR)$(PARROT_BIN_DIR)/perl6$(EXE)

xmas: $(PERL6_EXE) $(SETTING_PBC) $(R_SETTING_PBC)

##  targets for building a standalone perl6 executable.
$(PERL6_EXE): $(PERL6_PBC) $(PARROT_DLL_COPY)
	$(PBC_TO_EXE) -o$(PERL6_EXE) $(PERL6_PBC)

p-runner-default: p-all
	$(CP) $(PERL6_EXE) perl6$(EXE)
	$(CHMOD) 755  perl6$(EXE)

@make_dllcopy@

# the complete compiler
$(PERL6_PBC): $(PERL6_G_PBC) $(PERL6_A_PBC) $(PERL6_C_PBC) $(PERL6_P_PBC) src/main.nqp
	$(PERL) tools/build/gen-version.pl > $(P_BUILD_DIR)/main-version.nqp
	$(PERL) $(P_GEN_CAT) src/main.nqp $(P_BUILD_DIR)/main-version.nqp > $(P_BUILD_DIR)/main.nqp
	$(NQP_EXE) --vmlibs=perl6_ops --target=pir --output=src/gen/perl6.pir \
	    $(P_BUILD_DIR)/main.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_PBC) src/gen/perl6.pir

$(PERL6_ML_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) src/Perl6/ModuleLoader.nqp src/vm/parrot/ModuleLoaderVMConfig.nqp
	$(PERL) $(P_GEN_CAT) src/vm/parrot/ModuleLoaderVMConfig.nqp src/Perl6/ModuleLoader.nqp > $(P_BUILD_DIR)/ModuleLoader.nqp
	$(NQP_EXE) --target=pir --output=$(PERL6_ML) --encoding=utf8 \
	    $(P_BUILD_DIR)/ModuleLoader.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_ML_PBC) $(PERL6_ML)

$(PERL6_W_PBC): $(NQP_EXE) $(PERL6_ML_PBC) src/Perl6/World.nqp
	$(NQP_EXE) --vmlibs=perl6_ops --target=pir --output=$(PERL6_W) --encoding=utf8 \
	    src/Perl6/World.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_W_PBC) $(PERL6_W)
    
$(PERL6_G_PBC): $(NQP_EXE) $(PERL6_W_PBC) $(PERL6_A_PBC) src/Perl6/Grammar.nqp $(PERL6_P_PBC)
	$(NQP_EXE) --target=pir --output=$(PERL6_G) --encoding=utf8 \
	    src/Perl6/Grammar.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_G_PBC) $(PERL6_G)

$(PERL6_OPS_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) src/vm/parrot/Perl6/Ops.nqp
	$(NQP_EXE) --vmlibs=perl6_ops  --target=pir --output=$(PERL6_OPS) --encoding=utf8 \
	    src/vm/parrot/Perl6/Ops.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_OPS_PBC) $(PERL6_OPS)

$(PERL6_A_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) src/Perl6/Actions.nqp $(PERL6_P_PBC) $(PERL6_OPS_PBC)
	$(NQP_EXE) --vmlibs=perl6_ops  --target=pir --output=$(PERL6_A) --encoding=utf8 \
	    src/Perl6/Actions.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_A_PBC) $(PERL6_A)

$(PERL6_O_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) $(PERL6_OPS_PBC) src/Perl6/Optimizer.nqp
	$(NQP_EXE) --vmlibs=perl6_ops  --target=pir --output=$(PERL6_O) --encoding=utf8 \
	    src/Perl6/Optimizer.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_O_PBC) $(PERL6_O)
    
$(PERL6_P_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) src/Perl6/Pod.nqp
	$(NQP_EXE) --vmlibs=perl6_ops  --target=pir --output=$(PERL6_P) --encoding=utf8 \
	    src/Perl6/Pod.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_P_PBC) $(PERL6_P)

$(PERL6_C_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) $(PERL6_O_PBC) src/Perl6/Compiler.nqp
	$(NQP_EXE) --target=pir --output=$(PERL6_C) --encoding=utf8 \
	    src/Perl6/Compiler.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_C_PBC) $(PERL6_C)

$(PERL6_M_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) $(P_METAMODEL_SOURCES) $(PERL6_OPS_PBC)
	$(PERL) $(P_GEN_CAT) $(P_METAMODEL_SOURCES) > $(P_BUILD_DIR)/Metamodel.nqp
	$(NQP_EXE) --target=pir --output=$(PERL6_M) --encoding=utf8 \
	    --vmlibs=perl6_ops $(P_BUILD_DIR)/Metamodel.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_M_PBC) $(PERL6_M)
    
$(PERL6_B_PBC): $(NQP_EXE) $(DYNEXT_DYNOPS) $(PERL6_M_PBC) $(BOOTSTRAP_SOURCES)
	$(PERL) $(P_GEN_CAT) $(BOOTSTRAP_SOURCES) > $(P_BUILD_DIR)/BOOTSTRAP.nqp
	$(NQP_EXE) --target=pir --output=$(PERL6_B) --encoding=utf8 \
	    --vmlibs=perl6_ops $(P_BUILD_DIR)/BOOTSTRAP.nqp
	$(PARROT) $(PARROT_ARGS) -o $(PERL6_B_PBC) $(PERL6_B)

$(SETTING_PBC): $(PERL6_B_PBC) $(PERL6_EXE) $(P_CORE_SOURCES)
	$(PERL) $(P_GEN_CAT) $(P_CORE_SOURCES) > $(P_BUILD_DIR)/CORE.setting
	@echo "The following step can take a long time, please be patient."
	./$(PERL6_EXE) --setting=NULL --optimize=3 --target=pir --stagestats --output=$(SETTING_PIR) $(P_BUILD_DIR)/CORE.setting
	$(PARROT) $(PARROT_ARGS) -o $(SETTING_PBC) $(SETTING_PIR)

$(R_SETTING_PBC): $(PERL6_B_PBC) $(PERL6_EXE) $(SETTING_PBC) $(R_SETTING_SRC)
	./$(PERL6_EXE) --target=pir $(STAGESTATS) --output=$(R_SETTING_PIR) $(R_SETTING_SRC)
	$(PARROT) $(PARROT_ARGS) -o $(R_SETTING_PBC) $(R_SETTING_PIR)

##  testing targets
lib/Test.pir: lib/Test.pm $(PERL6_EXE) $(SETTING_PBC)
	./$(PERL6_EXE) --target=pir --output=lib/Test.pir lib/Test.pm

lib/lib.pir: lib/lib.pm6 $(PERL6_EXE) $(SETTING_PBC)
	./$(PERL6_EXE) --target=pir --output=lib/lib.pir lib/lib.pm6

lib/Pod/To/Text.pir: lib/Pod/To/Text.pm $(PERL6_EXE) $(SETTING_PBC)
	./$(PERL6_EXE) --target=pir --output=lib/Pod/To/Text.pir lib/Pod/To/Text.pm

p-test    : p-coretest

p-fulltest: p-coretest p-stresstest

p-coretest: p-all
	$(PERL) t/harness t/00-parrot t/01-sanity

# Run the spectests that we know work.
p-spectest: p-testable t/spectest.data
	$(P_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data

p-spectest_full: p-testable
	$(P_HARNESS_WITH_FUDGE) t/spec

p-quicktest: p-testable t/spectest.data
	$(P_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data --long=0

p-stresstest: p-testable t/spectest.data
	$(P_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data --stress=1

p-rakudo_test_run.tar.gz: p-testable t/spectest.data
	- $(P_HARNESS_WITH_FUDGE) --tests-from-file=t/spectest.data --archive p-rakudo_test_run.tar.gz --parrot_revision @git_describe@

p-spectest_smolder: rakudo_test_run.tar.gz
	./perl6 -e "shell qqx[git log -1 --pretty=format:%H].fmt(qq[curl -F architecture=@cpuarch@ -F platform=@osname@ -F revision=%s -F report_file=@p-rakudo_test_run.tar.gz -F username=parrot-autobot -F password=qa_rocks http://smolder.parrot.org/app/projects/process_add_report/5])"

p-testable : p-all spectest_checkout spectest_update

# Run the tests in t/localtest.data
p-localtest: p-all spectest_checkout t/localtest.data
	@$(P_HARNESS_WITH_FUDGE) --tests-from-file=t/localtest.data

# Run the tests in t/localtest.data with a higher verbosity
p-localtest_loud: p-all spectest_checkout t/localtest.data
	@$(P_HARNESS_WITH_FUDGE) --tests-from-file=t/localtest.data --verbosity=1

# Run many tests of your choice.
# make sometests TESTFILES=t/foo/bar
p-sometests: p-all
	@$(P_HARNESS_WITH_FUDGE) $(TESTFILES)


##  cleaning
p-clean:
	$(RM_RF) $(P_CLEANUPS)

p-distclean: realclean

p-realclean: clean
	$(RM_RF) Makefile

p-testclean:


##  miscellaneous targets
# a listing of all targets meant to be called by users
help:
	@echo ""
	@echo "Following targets are available for the user:"
	@echo ""
	@echo "  all:               perl6.pbc"
	@echo "                     This is the default."
	@echo "  $(PERL6_EXE):      Some want a pony, others are satisfied with an executable."
	@echo "  xmas:              Christmas is when Perl 6 is released. Alias of perl6$(EXE)."
	@echo ""
	@echo "Testing:"
	@echo "  test:              Run Rakudo's sanity tests."
	@echo "  spectest:          Run the tests of the official test suite that are expected to pass."
	@echo "  fulltest:          Run sanity tests and spectests."
	@echo "  spectest_full:     Run all tests of the official test suite."
	@echo "  localtest:         Run the official tests given in t/localtest.data."
	@echo "  spectest_checkout: Performs git checkout of official test suite."
	@echo "  spectest_update:   Performs git update of official test suite."
	@echo "  testable:          Create the perl6 executable, compile the Test library,"
	@echo "                     and update official test suite."
	@echo ""
	@echo "Maintenance:"
	@echo "  perlcritic:        Run Perl::Critic on all the Perl 5 code."
	@echo ""
	@echo "Cleaning:"
	@echo "  clean:             Basic cleaning up."
	@echo "  distclean:         Removes also anything built, in theory."
	@echo "  realclean:         Removes also files generated by 'Configure.pl'."
	@echo "  testclean:         Clean up test results."
	@echo ""
	@echo "Misc:"
	@echo "  help:              Print this help message."
	@echo ""

p-check-versions:
	@$(PERL) tools/build/check-versions.pl  $(NQP_EXE)

config:
	$(PERL) Configure.pl

$(PARROT):

CRITIC_FILES=Configure.pl t/harness build/ tools/

perlcritic:
	perlcritic -1 --profile tools/util/perlcritic.conf $(CRITIC_FILES)

manifest:
	echo MANIFEST >MANIFEST
	git ls-files | $(PERL) -ne '/^\./ || print' >>MANIFEST
	cd t/spec && git clean -xdf
	find t/spec -type f | grep -v '\.git' >>MANIFEST
	sort -u -o MANIFEST MANIFEST

release: manifest
	[ -n "$(VERSION)" ] || ( echo "\nTry 'make release VERSION=yyyy.mm'\n\n"; exit 1 )
	[ -d rakudo-$(VERSION) ] || ln -s . rakudo-$(VERSION)
	$(PERL) -ne 'print "rakudo-$(VERSION)/$$_"' MANIFEST | \
	    tar -zcv -T - -f rakudo-$(VERSION).tar.gz
	rm rakudo-$(VERSION)

$(DYNEXT_DYNOPS): $(DYNOPS)
	$(CP) $(DYNOPS) $(DYNEXT_DIR)
	$(CHMOD) 755 $(DYNEXT_DYNOPS)

# (at)cc_o_out(at) and (at)ld_out(at) below cannot be assigned to
# makefile macros, because some make utilities drop the trailing
# spaces and some compilers/linkers forbid a (forced) space.
# See RT #66558 and TT #700.

$(DYNOPS): $(OPS_DIR)/$(OPS_SOURCE) src/vm/parrot/guts/bind.c src/vm/parrot/guts/bind.h src/vm/parrot/guts/container.c src/vm/parrot/guts/container.h src/vm/parrot/guts/types.c src/vm/parrot/guts/types.h src/vm/parrot/guts/sixmodelobject.h src/vm/parrot/guts/storage_spec.h src/vm/parrot/guts/exceptions.h src/vm/parrot/guts/exceptions.c
	cd $(OPS_DIR) && $(OPS2C) C --dynamic $(OPS_SOURCE)
	cd $(OPS_DIR) && $(CC) -c @cc_o_out@$(OPS)$(O) $(CINCLUDES) $(CFLAGS) $(OPS).c
	cd src/vm/parrot/guts && $(CC) -c @cc_o_out@exceptions$(O) $(CINCLUDES) $(CFLAGS) exceptions.c
	cd src/vm/parrot/guts && $(CC) -c @cc_o_out@bind$(O) $(CINCLUDES) $(CFLAGS) bind.c
	cd src/vm/parrot/guts && $(CC) -c @cc_o_out@container$(O) $(CINCLUDES) $(CFLAGS) container.c
	cd src/vm/parrot/guts && $(CC) -c @cc_o_out@types$(O) $(CINCLUDES) $(CFLAGS) types.c
	cd $(OPS_DIR) && $(LD) @ld_out@$(OPS)$(LOAD_EXT) $(OPS)$(O) ../guts/bind$(O) ../guts/exceptions$(O) ../guts/container$(O) ../guts/types$(O) $(LINKARGS)

# nqp::makefile <-- tells NQP::Configure to treat this file as a makefile,
#                   performing win32 slash and makefile conversions
rakudo-2013.12/tools/build/nqp-jvm-rr.pl0000664000175000017500000000110612224263172017407 0ustar  moritzmoritz#!/usr/bin/perl
# Copyright (C) 2013, The Perl Foundation.

use strict;
use warnings;
use 5.008;

my ($existing) = shift @ARGV;

unless (-e $existing) {
    $existing = "$existing.bat";
}
unless (-e $existing) {
    die "Could not find " . $ARGV[0];
}

open my $fh, "<", $existing;
my $runner;
while (<$fh>) {
    $runner = $_;
}
close $fh;

$runner =~ s/nqp-runtime\.jar\;/nqp-runtime.jar;rakudo-runtime.jar;/;
$runner =~ s/nqp-runtime\.jar\:/nqp-runtime.jar:rakudo-runtime.jar:/;

my $args = join ' ', @ARGV;
$runner =~ s/"\$\@"/$args/;
$runner =~ s/\%\*/$args/;

system $runner;
rakudo-2013.12/tools/build/NQP_REVISION0000664000175000017500000000001212255236026016735 0ustar  moritzmoritz2013.12.1
rakudo-2013.12/tools/commit-stats.pl0000664000175000017500000000276512224263172016737 0ustar  moritzmoritz#!/usr/bin/perl
use strict;
use warnings;
use GD::Graph::linespoints;
use List::Util qw(max);
use POSIX qw(log10 ceil);

open my $c, '-|', qw(git log --pretty=format:%ae|%ci) 
    or die "Can't run git log: $!";

my %email;
my %month;

while (<$c>) {
    chomp;
    my ($email, $date) = split /\|/;
    $email{$email}++;
    $month{substr $date, 0, 7}++;
}
close $c or die $!;

{
    my $max = max values %month;
    my $round = 10 ** int(log10 $max);
    $max = $round * (1 + int($max / $round));
    my $label_skip = int .5 + (values %month) / 20;

    my $g = GD::Graph::linespoints->new(600, 400);
    $g->set(
            x_label         => 'Month',
            y_label         => 'Number of commits',
            title           => 'Commits to Rakudo per Month',
            x_label_skip    => $label_skip,
            x_labels_vertical => 1,
            y_max_value     => $max,
            y_min_value     => 0,

    ) or die $g->error;
    my @data;
    my $c = 0;
    for (sort keys %month){
        push @{$data[0]}, $_;
        push @{$data[1]}, $month{$_};
    }
    my $filename = $ARGV[0] || 'commits.png';
    open my $img, '>', $filename
        or die "Can't open `$filename' for writing: $!";
    binmode $img;
    print $img $g->plot(\@data)->png;
    close $img;
}

{
    my $top = 15;
    my $c = 0;
    print "Top $top commit authors\n";
    for (sort { $email{$b} <=> $email{$a} } keys %email) {
        $c++;
        printf "%-2d % 5d  %s\n", $c,  $email{$_}, $_;
        last if $c >= $top;
    }
}
rakudo-2013.12/tools/contributors.pl0000664000175000017500000000443312224263172017042 0ustar  moritzmoritz#!/usr/bin/env perl
use strict;
use warnings;
binmode STDOUT, ':encoding(UTF-8)';
#use 5.010;
use utf8;

use Date::Simple qw(today ymd);

my %contrib;

my $last_release = shift;
$last_release = release_date_of_prev_month() if not defined $last_release;
my $nick_to_name = nick_to_name_from_CREDITS();
open my $c, '-|', 'git', 'log', "--since=$last_release", '--pretty=format:%an|%cn|%s'
    or die "Can't open pipe to git log: $!";
binmode $c, ':encoding(UTF-8)';
while (my $line = <$c>) {
    my ($author, $comitter, $msg) = split /\|/, $line, 3;
    $contrib{nick_to_name($author)}++;
    $contrib{nick_to_name($comitter)}++ if $comitter ne 'Rakudo Perl';
    while ($msg =~ /\(([^)]{2,})\)\+\+/g) {
        $contrib{nick_to_name($1)}++;
    }
    while ($msg =~ /([^\s():]{2,})\+\+/g) {
        my $nick = $1;
        next if $nick =~ /^[\$\@]/;
        $contrib{nick_to_name($nick)}++;
    }
    while ($msg =~ /courtesy of:?\s*(\S.*)/gi) {
        $contrib{nick_to_name($1)}++;
    }
}
close $c or warn $!;

my @contrib = reverse sort { $contrib{$a} <=> $contrib{$b} } keys %contrib;

print "Contributors to Rakudo since the release on $last_release:\n";
print join(', ', @contrib), "\n";


sub release_date_of_prev_month {
    my $release_date;
    my $last_month = today();
    $last_month-- while $last_month->month == today->month;
    $release_date = ymd(
                        $last_month->year,
                        $last_month->month,
                        1,
                    );
    $release_date++ while $release_date->day_of_week != 2;
    $release_date += 14;
    $release_date++ while $release_date->day_of_week != 4;
    return $release_date;
}

sub nick_to_name_from_CREDITS {
    open my $f, '<:utf8', 'CREDITS' or die "Can't open file CREDITS for reading: $!";
    local $/ = '';
    my %nicks;
    while (my $para = <$f>) {
        my @nicks;
        my $name;
        for (split /\n/, $para) {
            if (/^N: (.*)/) {
                $name = $1;
            } elsif (/^U: (.*)/) {
                push @nicks, $1;
            }
        }
        if (defined $name) {
            $nicks{lc $_} = $name for @nicks;
        }
    }
    close $f;
    return \%nicks;
}

sub nick_to_name {
    my $nick = shift;
    return defined $nick_to_name->{lc $nick}? $nick_to_name->{lc $nick} : $nick;
}

rakudo-2013.12/tools/distro/rakudo.spec0000664000175000017500000000350112224263172017410 0ustar  moritzmoritz%define parrot_version 1.4.0

Name:           rakudo
Version:        2009.08
Release:        1
Summary:        Rakudo Perl 6
License:        Artistic 2.0
Group:          Development/Libraries
URL:            http://www.rakudo.org/
Source0:        http://cloud.github.com/downloads/rakudo/rakudo/rakudo-%{version}.tar.gz
BuildRoot:      %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
BuildRequires:  parrot           >= %parrot_version
BuildRequires:  parrot-devel     >= %parrot_version

%define parrot_versiondirname %{parrot_version}-devel
%define parrot_versiondirpath  %{_libdir}/parrot/%{parrot_versiondirname}

%define parrot_dynext %{parrot_versiondirpath}/dynext

%define rakudo_libs %{parrot_versiondirpath}/languages/perl6/lib

# Versions don't go easily in install_files.pl yet

%description
Rakudo Perl 6 is an implementation of the Perl 6 language for
the Parrot virtual machine.  More information about Perl 6 is
available from http://perl6-projects.org/ .

%prep
%setup -q

%build
echo Building with root $RPM_BUILD_ROOT
%{__perl} Configure.pl
make

%install
rm -rf $RPM_BUILD_ROOT

make install DESTDIR=$RPM_BUILD_ROOT

%check
make test < /dev/null

%clean
rm -rf $RPM_BUILD_ROOT

%post -p /sbin/ldconfig

%postun -p /sbin/ldconfig

%files
%defattr(-,root,root,-)
%doc CREDITS README
%doc docs
%{parrot_dynext}/perl6_group.so
%{parrot_dynext}/perl6_ops.so
%{parrot_dynext}/perl6_ops_cg.so
%{parrot_dynext}/perl6_ops_cgp.so
%{parrot_dynext}/perl6_ops_switch.so
%{_bindir}/perl6
%{parrot_versiondirpath}/languages/perl6/perl6.pbc
%{rakudo_libs}/Test.pm
%{rakudo_libs}/Safe.pm

%changelog
* Wed Jul 22 2009 wayland  0.20
- Updated to latest version

* Fri Mar  6 2009 wayland  0.17
- created from parrot.spec
- Didn't redo any of the files stuff
- Played with things 'til it worked
rakudo-2013.12/tools/lib/NQP/Configure.pm0000664000175000017500000003133012255230273017427 0ustar  moritzmoritzpackage NQP::Configure;
use strict;
use warnings;
use Cwd;
use File::Copy qw(copy);

use base qw(Exporter);
our @EXPORT_OK = qw(sorry slurp system_or_die
                    cmp_rev 
                    read_parrot_config read_config
                    fill_template_file fill_template_text 
                    git_checkout
                    verify_install gen_moar
                    gen_nqp gen_parrot);

our $exe = $^O eq 'MSWin32' ? '.exe' : '';
our $bat = $^O eq 'MSWin32' ? '.bat' : '';

our @required_parrot_files = qw(
    @bindir@/parrot@exe@
    @bindir@/pbc_to_exe@exe@
    @bindir@/ops2c@exe@
    @libdir@@versiondir@/tools/build/pmc2c.pl
    @srcdir@@versiondir@/pmc
    @includedir@@versiondir@/pmc
);

our @required_nqp_files = qw(
    @bindir@/nqp-p@exe@
);

our $nqp_git = 'http://github.com/perl6/nqp.git';
our $par_git = 'http://github.com/parrot/parrot.git';
our $moar_git= 'https://github.com/MoarVM/MoarVM.git';

our $nqp_push = 'git@github.com:perl6/nqp.git';
our $par_push = 'git@github.com:parrot/parrot.git';
our $moar_push= 'git@github.com:MoarVM/MoarVM.git';

sub sorry {
    my @msg = @_;
    die join("\n", '', '===SORRY!===', @msg, "\n");
}

sub slurp {
    my $filename = shift;
    open my $fh, '<', $filename
        or die "Unable to read $filename\n";
    local $/ = undef;
    my $text = <$fh>;
    close $fh or die $!;
    return $text;
}


sub system_or_die {
    my @cmd = @_;
    system( @cmd ) == 0
        or die "Command failed (status $?): @cmd\n";
}


sub parse_revision {
    my $rev = shift;
    my $sep = qr/[_.]/;
    $rev =~ /(\d+)$sep(\d+)(?:$sep(\d+))?(?:-(\d+)-g[a-f0-9]*)?$/
        or die "Unrecognized revision specifier '$rev'\n";
    return ($1, $2, $3 || 0, $4 || 0);
}


sub cmp_rev {
    my ($a, $b) = @_;
    my @a = parse_revision($a);
    my @b = parse_revision($b);
    my $cmp = 0;
    for (0..3) {
        $cmp = $a[$_] <=> $b[$_];
        last if $cmp;
    }
    $cmp;
}


sub read_config {
    my @config_src = @_;
    my %config = ();
    local $_;
    for my $file (@config_src) {
        no warnings;
        if (open my $CONFIG, '-|', "$file --show-config") {
            while (<$CONFIG>) {
                if (/^([^\s=]+)=(.*)/) { $config{$1} = $2 }
            }
            close($CONFIG);
        }
        last if %config;
    }
    return %config;
}


sub read_parrot_config {
    my @parrot_config_src = @_;
    my %config = ();
    open my $CONFIG_PIR, '>', 'parrot-config.pir'
      or die "Unable to write parrot-config.pir\n";
    print $CONFIG_PIR <<'END';
        .include 'iglobals.pasm'
        .sub "main" :main
            .local pmc interp, config_hash, config_iter
            interp = getinterp
            config_hash = interp[.IGLOBALS_CONFIG_HASH]
            config_iter = iter config_hash
          config_loop:
            unless config_iter goto config_done
            $P0 = shift config_iter
            print "parrot::"
            $S0 = $P0.'key'()
            print $S0
            print "="
            $S0 = $P0.'value'()
            print $S0
            print "\n"
            goto config_loop
          config_done:
            .return ()
        .end
END
    close($CONFIG_PIR);
    
    for my $file (@parrot_config_src) {
        no warnings;
        if ($file =~ /.pir$/ && open my $PARROT_CONFIG, '<', $file) {
            while (<$PARROT_CONFIG>) {
                if (/P0\["(.*?)"\], "(.*?)"/) { $config{"parrot::$1"} = $2 }
            }
            close($PARROT_CONFIG) or die $!;
        }
        elsif (open my $PARROT, '-|', "\"$file\" parrot-config.pir") {
            while (<$PARROT>) {
                if (/^([\w:]+)=(.*)/) { $config{$1} = $2 }
            }
            close($PARROT);
        }
        last if %config;
    }
    unlink('parrot-config.pir');
    return %config;
}


sub fill_template_file {
    my $infile = shift;
    my $outfile = shift;
    my %config = @_;

    my $OUT;
    if (ref $outfile) {
        $OUT = $outfile;
    }
    else {
        print "\nCreating $outfile ...\n";
        open($OUT, '>', $outfile)
            or die "Unable to write $outfile\n";
    }

    my @infiles = ref($infile) ? @$infile : $infile;
    for my $if (@infiles) {
        my $text = slurp( $if );
        $text = fill_template_text($text, %config);
        print $OUT $text;
    }
    unless (ref $outfile) {
        close($OUT) or die "Error while writing '$outfile': $!";
    }
}


sub fill_template_text {
    my $text = shift;
    my %config = @_;

    my $escape = sub {
        my $str = $_[0];
        $str =~ s{ }{\\ }g;
        $str;
    };

    $text =~ s/@@([:\w]+)@@/$escape->($config{$1} || $config{"parrot::$1"} || '')/ge;
    $text =~ s/@([:\w]+)@/$config{$1} || $config{"parrot::$1"} || ''/ge;
    if ($text =~ /nqp::makefile/) {
        if ($^O eq 'MSWin32') {
            $text =~ s{/}{\\}g;
            $text =~ s{\\\*}{\\\\*}g;
            $text =~ s{(?:git|http):\S+}{ do {my $t = $&; $t =~ s'\\'/'g; $t} }eg;
            $text =~ s/.*curl.*/do {my $t = $&; $t =~ s'%'%%'g; $t}/meg;
        }
        if ($config{'makefile-timing'}) {
            $text =~ s{ (?@?[ \t]*)) # capture tab, optional @, and hspace
                        (?!-)            # not before - (ignore error) lines
                        (?!cd)           # not before cd lines
                        (?!echo)         # not before echo lines
                        (?=\S)           # must be before non-blank
                      }
                      {$1time\ }mgx;
        }
    }
    $text;
}


sub git_checkout {
    my $repo = shift;
    my $dir  = shift;
    my $checkout = shift;
    my $pushurl = shift;
    my $pwd = cwd();

    # get an up-to-date repository
    if (! -d $dir) {
        system_or_die('git', 'clone', $repo, $dir);
        chdir($dir);
        system('git', 'config', 'remote.origin.pushurl', $pushurl)
            if defined $pushurl;
    }
    else {
        chdir($dir);
        system_or_die('git', 'fetch');
    }

    if ($checkout) {
        system_or_die('git', 'checkout', $checkout);
        system_or_die('git', 'pull') 
            if slurp('.git/HEAD') =~ /^ref:/;
    }

    my $git_describe;
    if (open(my $GIT, '-|', "git describe --tags")) {
        $git_describe = <$GIT>;
        close($GIT);
        chomp $git_describe;
    }
    chdir($pwd);
    $git_describe;
}


sub verify_install {
    my $files = shift;
    my %config = @_;
    print "Verifying installation ...\n";
    my @missing;
    for my $reqfile ( @{$files} ) {
        my $f = fill_template_text($reqfile, %config);
        push @missing, "    $f" unless -e $f;
    }
    if (@missing) {
        unshift @missing, "I'm missing some needed files:";
    }
    @missing;
}


sub gen_nqp {
    my $nqp_want = shift;
    my %options  = @_;

    my $backends    = $options{'backends'};
    my $gen_nqp     = $options{'gen-nqp'};
    my $gen_parrot  = $options{'gen-parrot'};
    my $prefix      = $options{'prefix'} || cwd().'/install';
    my $startdir    = cwd();

    my $PARROT_REVISION = 'nqp/tools/build/PARROT_REVISION';

    my (%impls, %need);

    if ($backends =~ /parrot/) {
        my %c = read_parrot_config("$prefix/bin/parrot");

        if (%c) {
            my $bin = fill_template_text('@bindir@/nqp-p@ext@', %c);
            $impls{parrot}{bin} = $bin;
            %c  = read_config($bin);
            $impls{parrot}{config} = \%c;
            my $nqp_have = $c{'nqp::version'};
            my $nqp_ok   = $nqp_have && cmp_rev($nqp_have, $nqp_want) >= 0;
            if ($nqp_ok) {
                $impls{parrot}{ok} = 1;
            }
            else {
                $need{parrot} = 1;
            }
        }
        else {
            $need{parrot} = 1;
        }
    }
    for my $b (qw/jvm moar/) {
        if ($backends =~ /$b/) {
            my $postfix = substr $b, 0, 1;
            my $bin = "$prefix/bin/nqp-$postfix$bat";
            $impls{$b}{bin} = $bin;
            my %c = read_config($bin);
            my $nqp_have = $c{'nqp::version'} || '';
            $impls{$b}{config} = \%c;
            my $nqp_ok   = $nqp_have && cmp_rev($nqp_have, $nqp_want) >= 0;
            if ($nqp_ok) {
                $impls{$b}{ok} = 1;
            }
            else {
                $need{$b} = 1;
            }
        }
    }

    return %impls unless %need;

    if (defined $gen_nqp || defined $gen_parrot) {
        git_checkout($nqp_git, 'nqp', $gen_nqp || $nqp_want, $nqp_push);
    }

    if ($need{parrot} && defined $gen_parrot) {
        my ($par_want) = split(' ', slurp($PARROT_REVISION));
        my $parrot = gen_parrot($par_want, %options, prefix => $prefix);
        my %c = read_parrot_config($parrot);
        $impls{parrot}{bin} = fill_template_text('@bindir@/nqp-p@ext@', %c);
        $impls{parrot}{ok} = 1;
        $impls{parrot}{config} = \%c;
    }

    return %impls unless defined($gen_nqp) || defined($gen_parrot);

    my $backends_to_build = join ',', sort keys %need;
    my @cmd = ($^X, 'Configure.pl', "--prefix=$prefix",
               "--backends=$backends", "--make-install");
    print "Building NQP ...\n";
    chdir("$startdir/nqp");
    print "@cmd\n";
    system_or_die(@cmd);
    chdir($startdir);

    for my $k (keys %need) {
        my %c = read_config($impls{$k}{bin});
        %c = (%{ $impls{$k}{config} || {} }, %c);
        $impls{$k}{config} = \%c;
        $impls{$k}{ok} = 1;
    }
    return %impls;
}


sub gen_parrot {
    my $par_want = shift;
    my %options  = @_;

    my $prefix     = $options{'prefix'} || cwd()."/install";
    my $gen_parrot = $options{'gen-parrot'};
    my @opts       = @{ $options{'parrot-option'} || [] };
    push @opts, "--optimize";
    my $startdir   = cwd();

    my $par_exe  = "$options{'prefix'}/bin/parrot$exe";
    my %config   = read_parrot_config($par_exe);

    my $par_have = $config{'parrot::git_describe'} || '';
    my $par_ok   = $par_have && cmp_rev($par_have, $par_want) >= 0;
    if ($gen_parrot) {
        my $par_repo = git_checkout($par_git, 'parrot', $gen_parrot, $par_push);
        $par_ok = $par_have eq $par_repo;
    }
    elsif (!$par_ok) {
        git_checkout($par_git, 'parrot', $par_want, $par_push);
    }

    if ($par_ok) {
        print "$par_exe is Parrot $par_have.\n";
        return $par_exe;
    }
    chdir("$startdir/parrot") or die $!;
    if (-f 'Makefile') {
        %config = read_parrot_config('config_lib.pir');
        my $make = $config{'parrot::make'};
        if ($make) {
            print "\nPerforming '$make realclean' ...\n";
            system_or_die($make, 'realclean');
        }
    }

    $prefix =~ s{\\}{/}g;

    print "\nConfiguring Parrot ...\n";
    my @cmd = ($^X, "Configure.pl", @opts, "--prefix=$prefix");
    print "@cmd\n";
    system_or_die(@cmd);

    print "\nBuilding Parrot ...\n";
    %config = read_parrot_config('config_lib.pir');
    my $make = $config{'parrot::make'} or
        die "Unable to determine value for 'make' from parrot config\n";
    system_or_die($make, 'install-dev');
    chdir($startdir);

    # That is a hack to get the import-lib in place. Parrot seems unpatchable because
    # its static build shares the same libname as the import-lib.
    if (-e "$startdir/parrot/libparrot.lib" && !-e "$startdir/install/bin/libparrot.lib") {
        copy("$startdir/parrot/libparrot.lib", "$startdir/install/bin/libparrot.lib");
    }

    print "Parrot installed.\n";
    return fill_template_text('@bindir@/parrot@exe@', %config);
}

sub gen_moar {
    my $moar_want = shift;
    my %options  = @_;

    my $prefix     = $options{'prefix'} || cwd()."/install";
    my $gen_moar   = $options{'gen-moar'};
    my @opts       = @{ $options{'moar-option'} || [] };
    push @opts, "--optimize";
    my $startdir   = cwd();

    my $moar_exe   = "$prefix/bin/moar$exe";
    my $moar_have  = qx{ $moar_exe --version };
    if ($moar_have) {
        $moar_have = $moar_have =~ /version (\S+)/ ? $1 : undef;
    }

    my $moar_ok   = $moar_have && cmp_rev($moar_have, $moar_want) >= 0;
    if ($moar_ok) {
        print "Found $moar_exe version $moar_have, which is new enough.\n";
        return $moar_exe;
    }
    elsif ($moar_have) {
        print "Found $moar_exe version $moar_have, which is too old.\n";
    }

    return unless defined $gen_moar;

    my $moar_repo = git_checkout($moar_git, 'MoarVM', $gen_moar || $moar_want, $moar_push);

    unless (cmp_rev($moar_repo, $moar_want) >= 0) {
        die "You asked me to build $gen_moar, but $moar_repo is not new enough to satisfy version $moar_want\n";
    }

    chdir("$startdir/MoarVM") or die $!;

    $prefix =~ s{\\}{/}g;
    print "\nConfiguring and building MoarVM ...\n";
    my @cmd = ($^X, "Configure.pl", @opts, "--prefix=$prefix", '--make-install');
    print "@cmd\n";
    system_or_die(@cmd);

    chdir($startdir);

    return $moar_exe;
}


1;
rakudo-2013.12/tools/perl6-limited.pl0000775000175000017500000000011412224263172016755 0ustar  moritzmoritz#!/usr/bin/env perl

exec "ulimit -t 45; ulimit -v 2048576; ./perl6 @ARGV";
rakudo-2013.12/tools/progress-graph.pl0000664000175000017500000000665312224263172017256 0ustar  moritzmoritz#! perl
# Copyright (C) 2008, The Perl Foundation
# $Id$

=head1 NAME

progress-graph.pl - generate a chart that displays rakudo's progress with
passing tests.

=head1 SYNOPSIS

perl tools/progress-graph.pl [input_file [output_file]]

=head1 DESCRIPTION

Create a chart that displays the number of passed, skipped and TODO tests.

If C is given at the command line, it is read and parsed as a CSV
file. if absent F is used.

If C is given, the image is written to that file. If not, the
file name C is used, where C<%s> stands for the last
processed date.

=cut


use strict;
use warnings;
use GD;
use GD::Graph::bars;
use Text::CSV_XS;
use List::Util qw(max sum);
use POSIX qw(log10 ceil);
use Getopt::Long;

# column names
use constant DATE       => 0;
use constant REVISION   => 1;
use constant PASS       => 2;
use constant FAIL       => 3;
use constant TODO       => 4;
use constant SKIP       => 5;
use constant REGR       => 6;
use constant SPEC       => 7;
use constant FILES      => 8;
use constant SPECSKIP   => 9;

use constant MAX_COL    => 9;

my $size = '850x500';

GetOptions
    'size=s'    => \$size,
    or usage();

my $fn = $ARGV[0] || 'docs/spectest-progress.csv';
open my $f, '<', $fn or die "Can't open file '$fn' for reading: $!";
my @data = map [], 0 .. MAX_COL;

my $csv = Text::CSV_XS->new({
        quote_char  => q{"},
        sep_char    => q{,},
    });

my $max = 0;
my @columns_to_plot = (PASS, FAIL, TODO, SKIP, SPECSKIP);
my $rows = 0;

while (<$f>) {
    next if m/^"[a-z]+"/i; # skip header line
    next unless m/\d/;     # empty lines and such
    $csv->parse($_);
    my @cols = $csv->fields();
    push @{$data[0]}, substr $cols[0], 0, 10;
    $cols[SPECSKIP] = $cols[SPEC] - sum @cols[PASS, FAIL, TODO, SKIP];
    for (1..MAX_COL){
        push @{$data[$_]}, $cols[$_];
    }
    $max = max $max, sum @cols[@columns_to_plot];
    $rows++;
}

my $last_date = $data[DATE][-1];

# GD::Graph always prints the last label, which leads to overlapping
# labels. Better remove it.
$data[DATE][-1] = '';

my $p = GD::Graph::bars->new(split m/x/, $size, 2);
no warnings 'qw';
$p->set(
        x_label             => 'Date',
        y_label             => 'Tests',
        title               => 'Rakudo Spectest Progress',
        x_label_skip        => int($rows / 20),
        x_labels_vertical   => 1,
        cumulate            => 1,
        borderclrs          => [undef],
        dclrs               => [qw(#00FF00 #FF0000 #0000FF #FFFF00 #DDDDDD)]
    ) or die $p->error;

$p->set_legend('Pass', 'Fail', 'Todo', 'Regr', 'Spec');
$p->set_x_axis_font(gdSmallFont);
$p->set_y_axis_font(gdLargeFont);

# determine a better y_max_value - GD::Graph wastes much space by default
my $round_to = 10 ** int(log10 $max) / 5;
$max = $round_to * (1 + int($max / $round_to));
$p->set(y_max_value => $max );

my $g = $p->plot([@data[DATE, @columns_to_plot]]) or die $p->error;
my $out_file = $ARGV[1] || "rakudo-tests-$last_date.png";
open my $o, '>', $out_file
    or die "Can't open file `$out_file' for writing: $!";
binmode $o;
print $o $g->png;
close $o;
print "Image written to file '$out_file'\n";

sub usage {
    print < \$help,
           'verbose!'   => \$verbose,
           'realclean!' => \$realclean,
           'jit!'       => \$jit,
           'test!'      => \$test,
           'codetest!'  => \$codetest,
           'spectest!'  => \$spectest,
          );

die <<"USAGE" if $help;
usage:   $0 [options]
options:
  -h|--help        print this usage info
  -v|--verbose     show verbose output
  -j|--jit         enable JIT during configuration
  -t|--test        run '$make test'      after build
  -c|--codetest    run '$make codetest'  after build
  -s|--spectest    run '$make spectest'  after build
  -r|--realclean   run '$make realclean' before rebase, and configure after
                   (default on; use --no-realclean to turn it off)

For extra golfing goodness, try creating a shell alias
to run this script with your favorite options.
USAGE

print "Looking for Parrot root ...\n";
chdir '..' until -f 'parrotbug' || cwd eq File::Spec->rootdir;
die "Couldn't find Parrot root at or above current directory.\n"
    unless -f 'parrotbug';
print "... found at '" . cwd . "'.\n\n" if $verbose;

if ($realclean && -e 'Makefile') {
    print "Cleaning old build ...\n";
    run_command( $make, 'realclean' );
}

print "Rebasing Parrot ...\n";
my @rebase = -e '.git' ? qw( git svn rebase ) :
             -e '.svn' ? qw( svn up         ) :
                         qw( svk pull       ) ;
run_command(@rebase);

unless (-e 'Makefile') {
    print "Configuring Parrot ...\n";
    my   @config = qw( perl Configure.pl );
    push @config,  qw( --jitcapable=0    ) unless $jit;
    run_command(@config);
}

print "Making Parrot ...\n";
run_command( $make );

print "Making Rakudo ...\n";
run_command( $make, 'perl6' );

if ($test) {
    print "Running standard Parrot tests ...\n";
    run_command( $make, 'test' );
}

if ($codetest) {
    print "Running coding standard compliance tests ...\n";
    run_command( $make, 'codetest' );
}

if ($spectest) {
    print "Running Perl 6 spec tests ...\n";
    chdir 'languages/perl6';
    run_command( $make, 'spectest' );
}

print "Done.\n";

sub run_command {
    if ($verbose) {
        my $status = system @_;
        die "Could not '@_': $!\n" if $status == -1;
        print "\n";
    }
    else {
        my $output = `@_ 2>&1`;
        die "Could not '@_': $!\n" unless defined $output;
        print $output if $?;
    }

    die "\n'@_' reports error, exiting.\n" if $?;
}
rakudo-2013.12/tools/release-dates.pl0000664000175000017500000000137012224263172017020 0ustar  moritzmoritzuse v6;

constant release-number-offset = 2010;
my @first-rn = (
    25,     # 2010
    37,     # 2011
    48,     # 2012
    60,     # 2013
);

sub MAIN ($year = Date.today.year) {
    if $year < 2010 {
        die "No support for pre-historic release dates";
    }
    my $first-rn = @first-rn[release-number-offset - $year]
                   // 12 * ($year - @first-rn - release-number-offset + 1) + @first-rn[*-1];
    for 1..12 -> $month {
        my $d = Date.new($year, $month, 1);
        ++$d until $d.day-of-week == 2;     # $d is now first Tuesday
        $d += 14;                           # ... third Tuesday
        $d += 2;                            # the release is on Thursday
        say "  $d   Rakudo #", $first-rn + $month - 1;
    }
}
rakudo-2013.12/tools/update_passing_test_data.pl0000664000175000017500000000704112224263172021341 0ustar  moritzmoritz#! perl
# Copyright (C) 2008, The Perl Foundation.

=head1 DESCRIPTION

This tool runs all spectests, except those that C runs (that
means all tests of which we don't know yet if they will pass or not).

For each file that passes at least one test (criterion might change in future)
it prints out a short summary about the status of this file.

This is primarily used to identify tests that could be added to
F, and those that are worth a closer look. But
please don't add them blindly just because they all pass - chances are that
there's a good reason for them not already being included.

This script should be called from the main Rakudo directory.

=cut

use strict;
use warnings;
use TAP::Harness;
use TAP::Parser::Aggregator 3.01;

use File::Find;

my %not_process = map { $_ => 1 } read_specfile('t/spectest.data');

print <<'KEY';
Key:
[S  ]   = some tests passed
[ P ]   = plan ok (ran all tests)
[  A]   = all passed
      ( passed / planned or ran )
==================================
KEY

my @wanted;

find({ wanted => \&queue, no_chdir => 1 }, 't/spec/');

sub queue {
    return if -d $_;
    return if m/\.sv[nk]/;
    return unless m/\.t$/;
    return if $not_process{$_};

    push @wanted, $_;
}

if ( ! defined $ENV{TEST_JOBS} || int $ENV{TEST_JOBS} <= 1 ) {
    go( $_ ) for @wanted;
}
else {
    my $jobs_wanted = int $ENV{TEST_JOBS};
    my %running;

    while( @wanted || %running ) {
        if ( @wanted && $jobs_wanted > keys %running ) {
            my $file = shift @wanted;
            my $pid = fork;
            if ( $pid ) {                # parent
                $running{ $pid } = $file;
            }
            elsif ( defined $pid ) {     # child
                go( $file );
                exit;
            }
            else {
                die "Can't fork: $!";
            }
        }
        else {
            my $pid = wait;
            if ( ! defined delete $running{ $pid } ) {
                die "reaped unknown child PID '$pid'";
            }
        }
    }
}

sub go {
    my $orig = shift @_;

    my $fudged = qx{t/spec/fudge --keep-exit-code rakudo $orig};
    chomp $fudged;

    my $H = get_harness();
    my $agg = TAP::Parser::Aggregator->new();
    $agg->start();
    $H->aggregate_tests($agg, $fudged);
    $agg->stop();

    # "older" version (prior to 3.16, which isn't released at the time
    # of writing) don't have a planned() method, so fall back on
    # total() instead
    my $planned = eval { $agg->cplanned };
    $planned    =  $agg->total unless defined $planned;

    my ($some_passed, $plan_ok, $all_passed) = (' ', ' ', ' ');
    my $actually_passed = $agg->passed - $agg->skipped - $agg->todo;
    $some_passed = 'S' if $actually_passed;
    $plan_ok     = 'P' if !scalar($agg->parse_errors);
    $all_passed  = 'A' if !       $agg->has_errors;
    printf "[%s%s%s] (% 3d/%-3d) %s\n", $some_passed, $plan_ok, $all_passed,
           $actually_passed, $planned, $orig
}

sub read_specfile {
    my $fn = shift;
    my @res;
    open (my $f, '<', $fn) or die "Can't open file '$fn' for reading: $!";
    while (<$f>){
        s/\s*\#.*//;   # strip out comments and any spaces before them
        m/(\S+)/ && push @res, "t/spec/$1";
    }
    close $f or die $!;
    return @res;
}

sub get_harness {
    return TAP::Harness->new({
            verbosity   => -2,
            exec        => [$^X, 'tools/perl6-limited.pl', qw/-Ilib -I./],
            merge       => 1,
    });
}

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
rakudo-2013.12/tools/update-tai-utc.pl0000664000175000017500000000243712224263172017135 0ustar  moritzmoritz#!/usr/bin/perl
# Updates src/core/tai-utc.pm.

use warnings;
use strict;
use Time::y2038 'timegm';
use File::Slurp qw(slurp write_file);
use LWP::Simple 'get';

my $url = 'ftp://hpiers.obspm.fr/iers/bul/bulc/TimeSteps.history';

$ARGV[0] ||= 'src/core/tai-utc.pm';
my $tu_path = $ARGV[0];

my @dates = do {
    my @lines = split /\n/, get $url;
    pop @lines;
    shift @lines until $lines[0] =~ /\A 1972  Jul\.   1/;
    map {
        /(\d{4})  (Jan|Jul)/;
        $2 eq 'Jan' ? [$1 - 1, 12, 31] : [$1, 6, 30]
    } @lines
};

my $tu = slurp $tu_path;
sub replace {
    my ($find, $fmt, $f) = @_;
    $tu =~ s
        {^( *)#BEGIN $find\n.+?^ *#END $find\n}
        { sprintf "$1#BEGIN $find\n$1<\n%s\n$1>\n$1#END $find\n", join "\n",
              map { sprintf "%s$fmt", $1, $f->(@$_) } @dates }ems
      or die "Couldn't replace $find";
}
replace 'leap-second-dates', '%d-%02d-%02d', sub { @_ };
replace 'leap-second-posix', '%10d', sub {
    my ($y, $m, $d) = @_;
    1 + timegm 59, 59, 23, $d, $m - 1, $y - 1900;
};
write_file $tu_path, $tu;
print "Updated.\n";

# The IERS announces midyear leap seconds in early January and
# end-of-year leap seconds in early July. So:

my $month = (gmtime)[4];
printf "This program should next be run in %s.\n",
    1 < $month && $month < 8 ? 'August' : 'February';
rakudo-2013.12/tools/util/perlcritic.conf0000664000175000017500000000177712224263172017744 0ustar  moritzmoritz# A more stringent set of rules for cage cleaners

[-CodeLayout::ProhibitParensWithBuiltins]
[CodeLayout::ProhibitHardTabs]
allow_leading_tabs = 0
 
[-CodeLayout::RequireTidyCode]

[-ControlStructures::ProhibitPostfixControls]
[-ControlStructures::ProhibitUnlessBlocks]

[-Documentation::PodSpelling]
[-Documentation::RequirePodAtEnd]
[-Documentation::RequirePodSections]

[-ErrorHandling::RequireCarping]

[-InputOutput::ProhibitBacktickOperators]
[-InputOutput::ProhibitInteractiveTest]
[-InputOutput::RequireCheckedSyscalls]
functions = :builtins
exclude_functions = print

[-Miscellanea::RequireRcsKeywords]

[-Modules::RequireVersionVar]

[-RegularExpressions::ProhibitEscapedMetacharacters]
[-RegularExpressions::RequireDotMatchAnything]
[-RegularExpressions::RequireExtendedFormatting]
[-RegularExpressions::RequireLineBoundaryMatching]

[-ValuesAndExpressions::ProhibitConstantPragma]
[-ValuesAndExpressions::ProhibitEmptyQuotes]
[-ValuesAndExpressions::ProhibitMagicNumbers]

[-Variables::ProhibitPunctuationVars]
rakudo-2013.12/t/spec/fudge0000775000175000017500000001662712224265625015042 0ustar  moritzmoritz#!/usr/bin/perl

use strict;
use warnings;

my %OPTS;
while( $_ = $ARGV[0], /^-/ ) {
    shift;
    last if /^--$/;
    $OPTS{$_} = $_;
}

my $ME;  # implementation
my $IN;  # test file
my $OUT; # fudged file

if (-f ".spec_config") {
    open my $cf, "<", ".spec_config";
    while (<$cf>) {
        if (m/^\bname\b\s*=\s*(\w+)/) {
           $ME = $1;
        }
    }
}

if (@ARGV == 3) {
    # impl test fudged
    $ME = shift;
    $IN = shift;
    $OUT = shift;
} elsif (@ARGV == 1) {
    # test
    $IN = shift; 
} elsif (@ARGV == 2) {
    my $arg = shift;
    if ($arg =~ /\.t$/) {
        # test fudged
        $IN = $arg;
        $OUT = shift;
    } else {
        # impl test
        $ME = $arg;
        $IN = shift; 
    }
}

if (!$OUT and $IN) {
    ($OUT = $IN) =~ s/\.t$/.$ME/ or $OUT .= ".$ME";
}

unless ($ME and $IN and $OUT) {

    die <<"USAGE";
Usage: $0 [options] [implname] testfilename [fudgedtestfilename]

    implname, if not specified on the command line, is pulled from the
        .spec_config file in your compiler's directory.

    Options:
    --keep-exit-code
        by default, fudge modifies the exit code for fudged test files to 1.
        supplying this option will suppress that behavior.

    Verbs:
    #?implname [num] skip 'reason'
        comment out num tests or blocks and call skip(num)

    #?implname [num] eval 'reason'
        eval num tests or blocks and skip(num) on parsefail

    #?implname [num] try 'reason'
        try num tests or blocks and fail on exception

    #?implname [num] todo 'reason', :by<1.2.3>
        run num tests or blocks with todo() preset

    #?implname emit your_ad_here();
        just pass through your_ad_here();

    #?DOES count
        for all implementations, the following thing does count tests
        (disables any attempt to autocount tests within the construct)
        when construct is a sub, registers the sub name as tester
        (and multiplies calls to tester sub by count tests)

    where
    implname is the lc name of your implementation, e.g. pugs or rakudo
    num is the number of statements or blocks to preprocess, defaults to 1
    count is how many tests the following construct counts as
    implnames are compared as a prefix match on sequences of components,
    i.e. #?rakudo matches rakudo.jvm

USAGE
}
unless (-e $IN) {
    die "$0: No such test file '$IN'\n";
}

unlink $OUT;        # old fudged version, may or may not regenerate...

my $REALLY_FUDGED = 0;
my $OUTPUT = "";
my $FUDGE = "";
our $PENDING = 0;
my $ARGS = '';
my $IS = '\\b(?:is|ok|nok|is_deeply|is_approx|isnt|like|unlike|eval_dies_ok|cmp_ok|isa_ok|use_ok|throws_ok|dies_ok|lives_ok|eval_lives_ok|pass|flunk|throws_like)(?:\\b|_)';
my %DOES;
my $DOES = 0;
my $EXIT = $OPTS{'--keep-exit-code'} ? '' : 'exit(1);';

@ARGV = ($IN);
fudgeblock();

if ($REALLY_FUDGED) {
    open OUT, ">", $OUT or die "Can't create $OUT: $!";
    print OUT $OUTPUT;
    print OUT <<"END";

say "# FUDGED!";
$EXIT
END
    close OUT;
    print "$OUT\n"; # pick the output file to run
}
else {
    print "$IN\n";  # pick the input file to run
}

sub fudgeblock {
    while (<>) {
        if (/^\s*\#\?DOES[:\s] \s* (.*)/x) {
            $DOES = $1;
            next;
        }
        if (/^\s*\#\? (\S+?)[:\s] \s* ((\S*).*)/x) {
            if (substr("$ME.",0,length($1)+1) eq "$1.") {
                $REALLY_FUDGED = 1;
                $ARGS = $2;
                if ($ARGS =~ s/^emit\s*//) {
                    $_ = $ARGS;
                    next;
                }
                if ($ARGS =~ s/^(\d+)\s*//) {
                    $PENDING = $1;
                }
                else {
                    $PENDING = 1;
                }
                $ARGS =~ s/^(\w+)\s*//;
                $FUDGE = $1;
            } elsif ($3 eq 'emit') {
                $_ = '';
                next;
            }
        }

        next if /^\s*#/;
        next if /^\s*$/;

        if ($DOES) {
            if (/^\s*(sub|multi|proto)\b/) {
                my $tmp = $_;
                $tmp =~ s/^\s*proto\s+//;
                $tmp =~ s/^\s*multi\s+//;
                $tmp =~ s/^\s*sub\s+//;
                $tmp =~ /^(\w+)/;
                $DOES{$1} = $DOES;
                $DOES = 0;
                next;
            }
        }

        next unless $PENDING > 0;

        if (/^\{/) {
            $PENDING--;
            if ($FUDGE eq 'todo') {
                local $PENDING = 999999;    # do all in block as one action
                $OUTPUT .= $_;
                $DOES = 0;  # XXX ignore?
                fudgeblock();
                $_ = '';
            }
            else {
                my $more;
                while (defined($more = <>)) {
                    $_ .= $more;
                    last if $more =~ /^\}/;
                }
                my $numtests = $DOES || do {
                    my $tmp = $_;
                    my $nt = 0;
                    $nt += $1 while $tmp =~ s/^#\?DOES[:\s]\s*(\d+).*\n.*\n//m;
                    if (%DOES) {
                            my $does = join('|',keys(%DOES));
                            $nt += $DOES{$1} while $tmp =~ s/^\s*($does)\b//mx;
                    }
                    $nt += () = $tmp =~ m/^(\s*$IS)/mgx;
                    $nt;
                };
                if ($FUDGE eq 'skip') {
                    s/^/# /mg;
                    $_ = "skip($ARGS, $numtests);" . $_;
                }
                elsif ($FUDGE eq 'try') {
                    chomp;
                    $_ = "(try $_) // flunk($ARGS);\n";
                }
                elsif ($FUDGE eq 'eval') {
                    chomp;
                    s/(['\\])/\\$1/g;
                    $_ = "eval('$_') // skip($ARGS, $numtests);\n";
                }
                else {
                    warn "Don't know how to mark block for $FUDGE!\n";
                }
            }
        }
        else {
            if ($FUDGE eq 'todo') {
                $DOES = 0;  # XXX ignore?
                my $does = join '|', keys %DOES;
                $PENDING -= s/^(\s*)/${1}todo($ARGS); / if /^\s*(?:$IS|$does)\b/;
            }
            else {
                while ($_ !~ /;[ \t]*(#.*)?$/) {
                    my $more = <>;
                    last unless $more;
                    $_ .= $more;
                }
                my ($keyword) = /^\s*(\w+)/ || '';
                my $numtests;
                if ($DOES{$keyword}) {
                    $numtests = $DOES{$keyword};
                }
                elsif ($DOES) {
                    $numtests = $DOES;
                }
                else {
                    my $does = join '|', keys %DOES;
                    next unless /^\s*($IS|$does)/;
                    $numtests = defined $DOES{$1}? $DOES{$1} : 1;
                }
                $PENDING--;
                $_ = "{ " . $_ . " }";
                if ($FUDGE eq 'skip') {
                    s/^/# /mg;
                    $_ = "skip($ARGS, $numtests); $_\n";
                }
                elsif ($FUDGE eq 'try') {
                    $_ = "(try $_) // flunk($ARGS);\n";
                }
                elsif ($FUDGE eq 'eval') {
                    s/(['\\])/\\$1/g;
                    $_ = "eval('$_') // skip($ARGS, $numtests);\n";
                }
                else {
                    warn "Don't know how to mark statement for $FUDGE!\n";
                }
            }
        }
    }
    continue {
        $OUTPUT .= $_;
        return if /^\}/ and $PENDING > 0;
    }
}
rakudo-2013.12/t/spec/fudgeall0000775000175000017500000000146412224265625015524 0ustar  moritzmoritz#!/usr/bin/perl

use strict;
use warnings;

my @opts;
while( $_ = $ARGV[0], /^-/ ) {
    shift;
    last if /^--$/;
    push @opts, $_;
}

my $platform = shift;

use Cwd;
my $top = getcwd;
my $fudge;

TOP:
while ($top) {
    for ("$top/fudge",
	"$top/spec/fudge",
	"$top/t/spec/fudge",
	"$top/perl6/t/spec/fudge",
	"$top/languages/perl6/t/spec/fudge",
    ) {
	if (-f $_) {
	    $fudge = $_;
	    last TOP;
	}
    }
    $top =~ s!(.*)/(.*)!!;
}
if (not $fudge) {
    for (split(/[:;]/, $ENV{PATH})) {
	if (-f "$_/fudge") {
	    $fudge = "$_/fudge";
	    last;
	}
    }
}

print join(' ',
    map {
        my $pick;
        if ( $_ !~ m/\.$platform$/ ) {
            my $cmd = "$^X \"$fudge\" @opts $platform $_";
            chomp( $pick = `$cmd` );
        }
        defined $pick ? $pick : ();
    } @ARGV
), "\n";


rakudo-2013.12/t/spec/integration/99problems-01-to-10.t0000664000175000017500000001536112224265625021605 0ustar  moritzmoritzuse v6;
use Test;
plan 22;

#?pugs todo
{
    # P01 (*) Find the last box of a list.
    # 
    # Example:
    # * (my-last '(a b c d))
    # (D)

    is .[*-1], 'd', 'Find the last box of a list.';

    sub my_last (@xs) {
        return @xs[*-1];
    }

    is my_last(), 'd', 'Find the last box of a list via func.';
}

#?pugs todo
{
    # P02 (*) Find the last but one box of a list.
    # 
    # Example:
    # * (my-but-last '(a b c d))
    # (C D)
    
    is [*-2, *-1], ,
        'We should be able to grab the last two items from a list';
    
    sub my_but_last (@xs) {
        return @xs[*-2,*-1];
    }
    
    is my_but_last(), ,
        'We should be able to grab the last two items from a list by func';
}

{
    # P03 (*) Find the K'th element of a list.
    # 
    # The first element in the list is number 1.
    # Example:
    # * (element-at '(a b c d e) 3)
    # C
    
    is [3], 'd', 'We should be able to index into lists';
    my @array = ;
    is @array[3], 'd', '... and arrays';
    
    sub element_at (@xs, $pos) {
        return @xs[$pos];
    }
   
    is element_at(, 3), 'd',
        'We should be able to index into lists by func';
    is element_at(@array, 3), 'd', '... and arrays by func';
    
}

{
    # P04 (*) Find the number of elements of a list.

    is .elems, 5, 'We should be able to count the items in a list';
    my @array = ;
    is @array.elems, 5, '... and arrays';
}

#?niecza skip 'Unable to resolve method reverse in class Parcel'
{
    # P05 (*) Reverse a list.

    is .reverse, , 
        'We should be able to reverse a list';
    my @array = ;
    is @array.reverse, , '... and arrays';
}

{
    # P06 (*) Find out whether a list is a palindrome.
    # 
    # A palindrome can be read forward or backward; e.g. (x a m a x).
    
    my @list = < a b c d e >;
    isnt @list.reverse, @list, " is not a palindrome";
    
    @list = < a b c b a >;
    is @list.reverse, @list, " is a palindrome";
}

{
    # P07 (**) Flatten a nested list structure.
    # 
    # 
    # Transform a list, possibly holding lists as elements into a `flat' list by
    # replacing each list with its elements (recursively).
    # 
    # Example:
    # * (my-flatten '(a (b (c d) e)))
    # (A B C D E)
    # 
    # Hint: Use the predefined functions list and append.
    
    my $flatten = { $_ ~~ List ?? ( map $flatten, @($_) ) !! $_ }; 
    my @flattened = map $flatten, ('a', ['b', ['c', 'd', 'e']]);
    is @flattened, , 'We should be able to flatten lists';
    
    # XXX this doesn't work that way...
    sub my_flatten (@xs) {
        sub inner_flatten (*@xs) { return @xs; }
    
        return inner_flatten(@xs);
    }
    
    is my_flatten( ('a', ['b', ['c', 'd', 'e']]) ), ,
        'We should be able to flatten lists by func';
}

{
    # P08 (**) Eliminate consecutive duplicates of list elements.
    # 
    # 
    # If a list contains repeated elements they should be replaced with a single
    # copy of the element. The order of the elements should not be changed.
    # 
    # Example:
    # * (compress '(a a a a b c c a a d e e e e))
    # (A B C A D E)
    
    # parens required in the assignment.  See http://perlmonks.org/?node=587242
    my $compress = sub ($x) {
        state $previous;
        return $x ne $previous ?? ($previous = $x) !! ();
    }
    my @compressed = map $compress, ;
    #?niecza todo
    is @compressed, , 'We should be able to compress lists';
}

#?pugs todo
{
    multi compress2 () { () }
    multi compress2 ($a) { $a }
    multi compress2 ($x, $y, *@xs) { $x xx ($x !=== $y), compress2($y, |@xs) }
    
    my @x = ;
    is compress2(|@x), , '... even with multi subs';
}

#?pugs skip 'todo'
{
    # P09 (**) Pack consecutive duplicates of list elements into sublists.
    # 
    # If a list contains repeated elements they should be placed in separate sublists.
    # 
    # Example:
    # * (pack '(a a a a b c c a a d e e e e))
    # ((A A A A) (B) (C C) (A A) (D) (E E E E))
    
    sub pack (*@array is copy) returns Array {
        my @packed;
        while @array {
            my @list;
            @list.push(@array.shift) while !@list || @list[0] eq @array[0];
            @packed.push([@list]);
        }
        return @packed;
    }
    
    is pack().join('+'),
        'a a a a+b+c c+a a+d+e e e e',
        'We should be able to pack lists';
    
    # From Larry, http://perlmonks.org/?node_id=590147
    sub group (*@array is copy) {
        gather {
            while @array {
                take [ 
                    gather {
                        my $h = shift @array;
                        take $h;
                        while @array and $h eq @array[0] {
                            take shift @array;
                        }
                    }.eager
                ];
            }
        }
    }
    is group().join('+'),
        'a a a a+b+c c+a a+d+e e e e',
        '... even using gather/take';
}
#?rakudo skip 'groupless gather/take'
#?niecza skip 'Unable to resolve method reverse in class Parcel'
#?pugs skip "Cannot 'shift' scalar"
{    
    sub group2 (*@array is copy) {
        gather while @array {
            take [ 
                my $h = shift @array,
                gather while @array and $h eq @array[0] {
                    take shift @array;
                }
            ];
        }
    }
    is group2().join('+'),
        'a a a a+b+c c+a a+d+e e e e',
        '... even using blockless gather/take';
    
}

{
    # P10 (*) Run-length encoding of a list.
    # 
    # 
    # Use the result of problem P09 to implement the so-called run-length encoding
    # data compression method. Consecutive duplicates of elements are encoded as
    # lists (N E) where N is the number of duplicates of the element E.
    # 
    # Example:
    # * (encode '(a a a a b c c a a d e e e e))
    # ((4 A) (1 B) (2 C) (2 A) (1 D)(4 E))
    
    sub encode (*@list) {
        my $count = 1;
        my ( @encoded, $previous, $x );
        
        for @list {
            $x = $_;
            if $x eq $previous {
                $count++;
                next;
            }
            if defined $previous {
                @encoded.push([$count, $previous]);
                $count = 1;
            }
            $previous = $x;
        }
        @encoded.push([$count, $x]);
        return @encoded;
    }
    
    is encode().join('+'),
        '4 a+1 b+2 c+2 a+1 d+4 e',
        'We should be able to run-length encode lists';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/99problems-11-to-20.t0000664000175000017500000002120612224265625021602 0ustar  moritzmoritzuse v6;
use Test;
plan 25;

{
    # P11 (*) Modified run-length encoding.
    # 
    # Modify the result of problem P10 in such a way that if an element has no
    # duplicates it is simply copied into the result list. Only elements with
    # duplicates are transferred as (N E) lists.
    # 
    # Example:
    # * (encode-modified '(a a a a b c c a a d e e e e))
    # ((4 A) B (2 C) (2 A) D (4 E))
    
    sub encode (*@list)returns Array {
        my $count = 1;
        my (@encoded, $previous, $x);
        
        for @list {
            $x = $_;
            if $x eq $previous {
                $count++;
                next;
            }
            if defined $previous {
                @encoded.push( 1 == $count ?? $previous !! [$count, $previous]);
                $count = 1;
            }
            $previous = $x;
        }
        @encoded.push([$count, $x]);
        return @encoded;
    }
    is encode(),
        [ [<4 a>], 'b', [<2 c>], [<2 a>], 'd', [<4 e>] ],
        'We should be able to run-length encode lists';
}

{
    # P12 (**) Decode a run-length encoded list.
    # 
    # Given a run-length code list generated as specified in problem P11.
    # Construct its uncompressed version.
    
    sub decode(*@list) returns List {
        gather {
            for @list -> $elem {
                take $elem.isa(Array) ?? $elem[1] xx $elem[0] !! $elem;
            }
        }
    }
    is decode( [4, "a"], "b", [2, "c"], [2, "a"], "d", [4, "e"] ),
        ,
        'We should be able to decode run-length encoded lists';
    
}

{
    # P13 (**) Run-length encoding of a list (direct solution).
    # 
    # Implement the so-called run-length encoding data compression method directly.
    # I.e. don't explicitly create the sublists containing the duplicates, as in
    # problem P09, but only count them. As in problem P11, simplify the result list
    # by replacing the singleton lists (1 X) by X.
    # 
    # Example:
    # * (encode-direct '(a a a a b c c a a d e e e e))
    # ((4 A) B (2 C) (2 A) D (4 E))
    
    sub encode_direct {
        my @chars = @_;
        my $encoded;
        my $prev_ch = '';
        my $ch_cnt = 0;
        while (my $ch = @chars.shift) {
            if ($ch ~~ $prev_ch) {
                $ch_cnt++;
                # If it's the last char, add it.
                if (@chars.elems == 0) {
                    if ($ch_cnt != 1) {
                        $encoded ~= $ch_cnt;
                    }
                    $encoded ~= $ch;
                }
            }
            # the very first one..
            elsif ($prev_ch eq '') { 
                $ch_cnt++;
                # If it's the last char, add it.
                if (@chars.elems == 1) {
                    if ($ch_cnt != 1) {
                        $encoded ~= $ch_cnt;
                    }
                    $encoded ~= $ch;
                }
            }
            # not a match, but a new letter
            else {
                if ($ch_cnt != 1) {
                    $encoded ~= $ch_cnt;
                }
                $encoded ~= $prev_ch;
                $ch_cnt = 1;
            }
            $prev_ch = $ch;
        }
    
        return $encoded;
    }
    
    
    # Alternative solution
    
    sub encode_direct2(*@array is copy) returns Str {
        my ($packed, $count);
        while @array {
          if @array[0] eq @array[1] {
              $count++;
          }
          else {
              $packed ~=( $count ?? ($count+1) ~ @array[0] !! @array[0] );
              $count=0;
          }
          @array.shift;
        }
        return $packed // '';
    }
    
    is encode_direct(()),'', 'We should be able to encode_direct an empty list';
    #?niecza todo
    #?rakudo todo 'unknown'
    is encode_direct(), 'a', '.. or a one-element iist';
    #?niecza todo
    #?rakudo todo 'unknown'
    is encode_direct(), '2a', '.. or a n-ary list with always same element';
    is encode_direct(),
        '4ab2c2ad4e',
        '.. or a generic list'; 
    is encode_direct2(()),'', 'We should be able to encode_direct2 an empty list';
    is encode_direct2(), 'a', '.. or a one-element iist';
    is encode_direct2(), '2a', '.. or a n-ary list with always same element';
    is encode_direct2(),
        '4ab2c2ad4e',
        '.. or a generic list'; 
}

{
    # P14 (*) Duplicate the elements of a list.
    # 
    # Example:
    # * (dupli '(a b c c d))
    # (A A B B C C C C D D)
    
    is map({ $_ xx 2 }, ), ,
        'We should be able to duplicate the elements of a list';
}

#?niecza skip 'Feed ops NYI'
{    
    my @result = eval ' ==> map { $_ xx 2 }';
    is @result, ,
        'We should be able to duplicate the elements of a list';
}

{
    # P15 (**) Replicate the elements of a list a given number of times.
    # 
    # Example:
    # * (repli '(a b c) 3)
    # (A A A B B B C C C)
    
    sub repli (@list, Int $count) {
        return map { $_ xx $count }, @list;
    }
    is repli(, 3), ,
        'We should be able to replicate array elements';
}

{
    # P16 (**) Drop every N'th element from a list.
    # 
    # Example:
    # * (drop '(a b c d e f g h i k) 3)
    # (A B D E G H K)
    
    sub drop(@list, Int $nth) {
        return map { @list[$_] }, grep { ($_+1) % $nth }, 0 .. @list.elems - 1;
    }
    is drop(, 3), ,
        'We should be able to drop list elements';
    
    sub drop2(@list, Int $nth) {
        return map { @list[$_] if ($_+1) % $nth }, ^@list;
    }
    #?niecza todo "https://github.com/sorear/niecza/issues/180"
    is drop2(, 3), ,
        'We should be able to drop list elements based on if returning ()';
    
    sub drop3(@list, Int $nth) {
        gather for ^@list {
            take @list[$_] if ($_+1) % $nth;
        }
    }
    is drop3(, 3), ,
        'We should be able to drop list elements using gather';
    
    sub drop4(@list, Int $nth) {
        (@list[$_] if ($_+1) % $nth) for ^@list;
    }
    #?niecza todo
    is drop4(, 3), ,
        'We should be able to drop list elements using (statement if) for';
    
    sub drop5(@list, Int $nth) {
        @list[$_] if ($_+1) % $nth for ^@list;
    }
    #?niecza todo
    is drop5(, 3), ,
        'We should be able to drop list elements using list comprehension';
}

#?niecza todo "Get Capture, not array"
{
    # P17 (*) Split a list into two parts; the length of the first part is given.
    # 
    # Do not use any predefined predicates.
    # 
    # Example:
    # * (split '(a b c d e f g h i k) 3)
    # ( (A B C) (D E F G H I K))
    
    sub splitter ( @array is copy, Int $length ) {
        my @head = @array.splice(0, $length);
        return (\@head, \@array);
    }
    my ( $a, $b ) = splitter(, 3);
    is $a, ,
        'The first array in the split should be correct';
    is $b, , '... as should the second';
}

{
    # P18 (**) Extract a slice from a list.
    # 
    # Given two indices, I and K, the slice is the list containing the elements
    # between the I'th and K'th element of the original list 
    # (both limits included).
    # Start counting the elements with 1.
    # 
    # Example:
    # * (slice '(a b c d e f g h i k) 3 7)
    # (C D E F G)
    
    my @array = ;
    is @array[3..7], , 'We should be able to slice lists';
}

{
    # P19 (**) Rotate a list N places to the left.
    # 
    # Examples:
    # * (rotate '(a b c d e f g h) 3)
    # (D E F G H A B C)
    # 
    # * (rotate '(a b c d e f g h) -2)
    # (G H A B C D E F)
    # 
    # Hint: Use the predefined functions length and append, as well as the result of
    # problem P17.
    
    sub rotate (Int $times is copy, *@list is copy) returns Array {
        if $times < 0 {
            $times += @list.elems;
        }
        @list.push: @list.shift for 1 .. $times;
        return @list;
    }
    is rotate(3, ), ,
        'We should be able to rotate lists forwards';
    is rotate(-2, ), ,
        '... and backwards';
}

{
    # P20 (*) Remove the K'th element from a list.
    # 
    # Example:
    # * (remove-at '(a b c d) 2)
    # (A C D)
    
    my @array = ;
    is @array.splice(1,1), , 
        'We should be able to remove elements from a list';
    is @array, , '... and have the correct list as the result';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/99problems-21-to-30.t0000664000175000017500000002067712224265625021617 0ustar  moritzmoritzuse v6;
use Test;
plan 15;

{
    # P21 (*) Insert an element at a given position into a list.
    # 
    # Example:
    # * (insert-at 'alfa '(a b c d) 2)
    # (A ALFA B C D)
    
    my @array = ;
    @array.splice(1, 0, 'alfa');
    is @array, , 'We should be able to splice into an array';
}

{
    # P22 (*) Create a list containing all integers within a given range.
    # 
    # If first argument is smaller than second, produce a list in decreasing order.
    # Example:
    # * (range 4 9)
    # (4 5 6 7 8 9)
    
    is list(4 .. 9), <4 5 6 7 8 9>, 'We should be able to create ranges';
}

#?pugs skip 'pick not defined: VInt 3'
{
    # P23 (**) Extract a given number of randomly selected elements from a list.
    # 
    # The selected items shall be returned in a list.
    # Example:
    # * (rnd-select '(a b c d e f g h) 3)
    # (E D A)
    # 
    # Hint: Use the built-in random number generator and the result of problem P20.
    my @letters = 'a' .. 'h';
    my @rand = pick(3, @letters);
    is @rand.elems, 3, 'pick() should return the correct number of items';
    
    # of course the following is wrong, but it also confuses test output!
    #ok all(@rand) ~~ none(@letters), '... and they should be in the letters';
    #?rakudo todo 'unknown'
    #?niecza todo 'unknown'
    ok ?(all(@rand) ~~ any(@letters)), '... and they should be in the letters';
    
    @rand = .pick(3);
    is @rand.elems, 3, 'pick() should return the correct number of items';
    #?rakudo todo 'unknown'
    #?niecza todo 'unknown'
    ok ?(all(@rand) ~~ any(@letters)), '... and they should be in the letters';
}
    
{
    my $compress = sub ($x) {
        state $previous;
        return $x ne $previous ?? ($previous = $x) !! ();
    }

    my @rand = .pick(3);
    @rand = map $compress, @rand;
    is @rand.elems, 3, '... and pick() should return unique elements';
}

{
    # P24 (*) Lotto: Draw N different random numbers from the set 1..M.
    # 
    # The selected numbers shall be returned in a list.
    # Example:
    # * (lotto-select 6 49)
    # (23 1 17 33 21 37)
    # 
    # Hint: Combine the solutions of problems P22 and P23.
    
    # subset Positive::Int of Int where { $_ >= 0 };
    # sub lotto (Positive::Int $count, Positive::Int $range) returns List {
    
    sub lotto (Int $count, Int $range) returns List {
        return (1 .. $range).pick($count);
    }
    
    my @numbers = lotto(6, 49);
    is @numbers.elems, 6, 'lotto() should return the correct number of numbers';
    #?rakudo todo 'unknown'
    #?niecza todo 'unknown'
    #?pugs skip 'autothread'
    ok ?(all(@numbers) ~~ any(1..49)), '... and they should be in the correct range';
    #?pugs emit # Missing required parameters: $_
    my %unique = map { ($_ => 1) }, @numbers;
    #?pugs emit #
    diag %unique.perl;
    #?pugs skip 'Missing required parameters: $_'
    is %unique.keys.elems, 6, '... and they should all be unique numbers';
}

{
    # P25 (*) Generate a random permutation of the elements of a list.
    # 
    # Example:
    # * (rnd-permu '(a b c d e f))
    # (B A D C E F)
    # 
    # Hint: Use the solution of problem P23.
    
    my @array = ('a' .. 'f');
    my @permute = @array.pick(*);
    is @permute.sort, @array.sort,
        '.pick(*) should return a permutation of a list';
}

# P26 (**) Generate the combinations of K distinct objects chosen from the N
# elements of a list
#
# In how many ways can a committee of 3 be chosen from a group of 12 people? We
# all know that there are C(12,3) = 220 possibilities (C(N,K) denotes the
# well-known binomial coefficients). For pure mathematicians, this result may be
# great. But we want to really generate all the possibilities in a list.
#
# Example:
# * (combination 3 '(a b c d e f))
# ((A B C) (A B D) (A B E) ... )

sub combination($n, @xs) {
    if $n > @xs {
        ()
    } elsif $n == 0 {
        ([])
    } elsif $n == @xs {
        [@xs]
    } else {
        (map { [@xs[0],$_.list] },combination($n-1,@xs[1..*])), combination($n,@xs[1..*])
    }
}

#?niecza skip 'hangs'
{
    
    is combination(3, (1..5)),
    ([1, 2, 3],
     [1, 2, 4],
     [1, 2, 5],
     [1, 3, 4],
     [1, 3, 5],
     [1, 4, 5],
     [2, 3, 4],
     [2, 3, 5],
     [2, 4, 5],
     [3, 4, 5]), "combinations work.";
}

#?niecza skip 'hangs'
#?pugs todo
{
    # P27 (**) Group the elements of a set into disjoint subsets.
    # 
    # a) In how many ways can a group of 9 people work in 3 disjoint subgroups of 2,
    # 3 and 4 persons? Write a function that generates all the possibilities and
    # returns them in a list.
    # 
    # Example:
    # * (group3 '(aldo beat carla david evi flip gary hugo ida))
    # ( ( (ALDO BEAT) (CARLA DAVID EVI) (FLIP GARY HUGO IDA) )
    # ... )
    # 
    # b) Generalize the above predicate in a way that we can specify a list of group
    # sizes and the predicate will return a list of groups.
    # 
    # Example:
    # * (group '(aldo beat carla david evi flip gary hugo ida) '(2 2 5))
    # ( ( (ALDO BEAT) (CARLA DAVID) (EVI FLIP GARY HUGO IDA) )
    # ... )
    # 
    # Note that we do not want permutations of the group members; i.e. ((ALDO BEAT)
    # ...) is the same solution as ((BEAT ALDO) ...). However, we make a difference
    # between ((ALDO BEAT) (CARLA DAVID) ...) and ((CARLA DAVID) (ALDO BEAT) ...).
    # 
    # You may find more about this combinatorial problem in a good book on discrete
    # mathematics under the term "multinomial coefficients".
    
    # XXX treats @elems as a set; i.e. duplicated values are 
    # treated as identical, not distinct.
    sub group(@sizes, @elems) {
        return [] if @sizes == 0;
        map -> $e {
            map -> $g {
                [ [@$e], @$g ]
            }, group(@sizes[1..*], grep { not $_ === any(@$e) }, @elems)
        }, combination(@sizes[0], @elems)
    }

    is group((2,1), (1,2,3,4)),
    (((1,2),(3,))
    ,((1,2),(4,))
    ,((1,3),(2,))
    ,((1,3),(4,))
    ,((1,4),(2,))
    ,((1,4),(3,))
    ,((2,3),(1,))
    ,((2,3),(4,))
    ,((2,4),(1,))
    ,((2,4),(3,))
    ,((3,4),(1,))
    ,((3,4),(2,))), 'group works';
}

#?pugs todo
{
    # P28 (**) Sorting a list of lists according to length of sublists
    # 
    # a) We suppose that a list contains elements that are lists themselves. The
    # objective is to sort the elements of this list according to their length. E.g.
    # short lists first, longer lists later, or vice versa.
    # 
    # Example:
    # * (lsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
    # ((O) (D E) (D E) (M N) (A B C) (F G H) (I J K L))
    # 
    # b) Again, we suppose that a list contains elements that are lists themselves.
    # But this time the objective is to sort the elements of this list according to
    # their length frequency; i.e., in the default, where sorting is done
    # ascendingly, lists with rare lengths are placed first, others with a more
    # frequent length come later.
    # 
    # Example:
    # * (lfsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
    # ((i j k l) (o) (a b c) (f g h) (d e) (d e) (m n))
    # 
    # Note that in the above example, the first two lists in the result have length 4
    # and 1, both lengths appear just once. The third and forth list have length 3
    # which appears twice (there are two list of this length). And finally, the last
    # three lists have length 2. This is the most frequent length.
    # 
    # Arithmetic
    
    my @input= [],[],[],[],[],[],[];
    my @expected= [],[],[],[],[],[],[];
    
    my @sorted=@input.sort: { +$_ };
    #?niecza todo 'sort order incorrect.'
    is @expected, 
       @sorted,
       "We should be able to sort a list of lists according to length of sublists";
    
    # the list is not the same as in the sample text, when two lists have the
    # same frequency of length the ordering is unspecified, so this should be ok
}

#?rakudo.parrot todo 'autovivification'
#?niecza skip 'Unable to resolve method push in class Any'
#?pugs todo
{
    my @input= [],[],[],[],[],[],[];
    my @expected= [],[],[],[],[],[],[];
    
    # group lists by length
    
    my %grouped;
    for (@input) {push %grouped{+$_}, $_}
    
    # now sort the values by frequency, again can't use
    #  sort: {+$_}
    
    my @sorted= %grouped.values.sort: +*;
    is @expected,@sorted, "..or according to frequency of length of sublists" 
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/99problems-31-to-40.t0000664000175000017500000001711412224265625021611 0ustar  moritzmoritzuse v6;
use Test;
plan 67;

{
    # P31 (**) Determine whether a given integer number is prime.
    # 
    # Example:
    # * (is-prime 7)
    # T
    
    # Very Naive implementation and 
    # could probably use something like: 
    #  subset Divisible::Int of Int where { $_ > 1 };
    #  sub is_prime(Divisible::Int $num) {
    # but "subset" is not working yet.
    
    sub is_prime(Int $num) returns Bool {
        
        # 0 and 1 are not prime by definition
        return Bool::False if $num < 2;
        
        # 2 and 3 are
        return Bool::True  if $num < 4;
    
        # no even number is prime
        return Bool::False if $num % 2 == 0;
    
        # let's try what's left
        my $max=floor(sqrt($num));
    
        # we could use
        #  for  3 ... *+2, $max -> $i {
        # but it doesn't seem to work yet
        loop (my $i=3; $i <= $max ; $i+=2) {
            return Bool::False if $num % $i == 0;
        }
        return Bool::True;
    }
    
    ok !is_prime(0), "We should find that 0 is not prime";
    ok !is_prime(1), ".. and neither is 1";
    ok  is_prime(2), ".. 2 is prime";
    ok  is_prime(3), ".. 3 is prime";
    ok !is_prime(4), ".. 4 is not";
    ok  is_prime(5), ".. 5 is prime";
    ok !is_prime(6), ".. 6 is even, thus not prime";
    ok !is_prime(15), ".. 15 is product of two primes, but not prime";
    ok  is_prime(2531), ".. 2531 is a larger prime";
    ok !is_prime(2533), ".. 2533 is not";
}

{
    # P32 (**) Determine the greatest common divisor of two positive 
    # integer numbers.
    # 
    # Use Euclid's algorithm.
    # Example:
    # * (gcd 36 63)
    # 9
    
    # Makes sense to declare types since gcd makes sense only for Ints.
    # Yet, it should be possible to define it even for commutative rings
    # other than Integers, so we use a multi sub.
    
    multi sub gcd(Int $a, Int $b){
        return $a if $b == 0;
        return gcd($b,$a % $b);
    }

    is gcd(36,63), 9, "We should be able to find the gcd of 36 and 63";
    is gcd(63,36), 9, ".. and viceversa";
    is gcd(0,5)  , 5, '.. and that gcd(0,$x) is $x';
    is gcd(0,0)  , 0, '.. even when $x is 0';
}

{
    # P33 (*) Determine whether two positive integer numbers are coprime.
    # 
    # Two numbers are coprime if their greatest common divisor equals 1.
    # Example:
    # * (coprime 35 64)
    # T

    sub coprime(Int $a, Int $b) { $a gcd $b == 1}
    ok  coprime(35,64), "We should be able to tell that 35 and 64 are coprime";
    ok  coprime(64,35), ".. and viceversa";
    ok !coprime(13,39), ".. but 13 and 39 are not";
}

{
    sub totient_phi(Int $num) {
        +grep({$_ gcd $num == 1}, 1 .. $num);
    }

    # TODO: s/my/constant/
    my @phi = *,1,1,2,2,4,2,6,4,6,4,10,4,12,6,8,8,16,6,18,8;

    # from Sloane OEIS A000010
    for 1..20 -> $n {
        is @phi[$n], totient_phi($n), "totient of $n is @phi[$n]";
    }
}

{
    # P35 (**) Determine the prime factors of a given positive integer.
    #
    # Construct a flat list containing the prime factors in ascending order.
    # Example:
    # * (prime-factors 315)
    # (3 3 5 7)
    sub prime_factors($n is copy) {
        my @factors;

        my $cand = 2;
        while ($n > 1) {
            if $n % $cand == 0 {
                @factors.push($cand);
                $n /= $cand;
            }
            else {
                $cand++;
            }
        }
        return @factors
    }

    is prime_factors(315), (3,3,5,7), 'prime factors of 315 are 3,3,5,7';
}

#?DOES 5
{
    # P36 (**) Determine the prime factors of a given positive integer (2).
    # 
    # Construct a list containing the prime factors and their multiplicity.
    # Example:
    # * (prime-factors-mult 315)
    # ((3 2) (5 1) (7 1))
    # 
    # Hint: The problem is similar to problem P13.
    
    our sub prime_factors_mult(Int $n is copy){
      return () if $n == 1;
      my $count = 0;
      my $cond = 2;
      return gather {
        while $n > 1 {
          if $n % $cond == 0 {
    	$count++;
    	$n div= $cond;
          }
          else {
    	if $count > 0 {
    	  take [$cond,$count];
    	  $count = 0;
    	}
    	$cond++;
          }
        }
        take [$cond,$count];
      }
    }
    is prime_factors_mult(1),(), "We ignore 1";
    is prime_factors_mult(2),([2,1]), "We get prime numbers prime";
    is prime_factors_mult(4),([2,2]),  ".. and multiplicity right";
    is prime_factors_mult(12),([2,2],[3,1]), ".. and products of primes";
    is prime_factors_mult(315),([3,2],[5,1],[7,1]), ".. and ignore multiplicity 0"
}

#?DOES 20
{
    # P37 (**) Calculate Euler's totient function phi(m) (improved).
    # 
    # See problem P34 for the definition of Euler's totient function. If the list of
    # the prime factors of a number m is known in the form of problem P36 then the
    # function phi(m) can be efficiently calculated as follows: Let ((p1 m1) (p2 m2)
    # (p3 m3) ...) be the list of prime factors (and their multiplicities) of a given
    # number m. Then phi(m) can be calculated with the following formula:
    # 
    # phi(m) = (p1 - 1) * p1 ** (m1 - 1) + (p2 - 1) * p2 ** (m2 - 1) + (p3 - 1) * p3 ** (m3 - 1) + ...
    # 
    # Note that a ** b stands for the b'th power of a.
    
    # This made me mad, the above formula is wrong
    # where it says + it should be *
    # based on the fact that
    #  phi(prime**m)=prime**(m-1)*(prime-1)
    # and
    #  some_number=some_prime**n * some_other_prime**m * ....
    
    our &prime_factors_mult;
    
    sub phi($n) {
      my $result=1;
      
      # XXX - I think there is a way of doing the unpacking + assignment 
      # in one step but don't know how
    
      for prime_factors_mult($n) -> @a  {
        my ($p,$m) = @a;
        $result *= $p ** ($m - 1) * ($p - 1);
      }
      $result;
    }
    
    
    my @phi = *,1,1,2,2,4,2,6,4,6,4,10,4,12,6,8,8,16,6,18,8;

    for 1..20 -> $n {
        is phi($n), @phi[$n], "totient of $n is {@phi[$n]}";
    }
}

{
    # P38 (*) Compare the two methods of calculating Euler's totient function.
    # 
    # Use the solutions of problems P34 and P37 to compare the algorithms. Take the
    # number of logical inferences as a measure for efficiency. Try to calculate
    # phi(10090) as an example.

    skip 'No Benchmark module yet', 1
}

#?DOES 2
{
    # P39 (*) A list of prime numbers.
    #
    # Given a range of integers by its lower and upper limit, construct a list of all
    # prime numbers in that range.
    
    our sub primes($from, $to) {
        my @p = (2);
        for 3..$to -> $x {
            push @p, $x unless grep { $x % $_ == 0 }, 2..ceiling sqrt $x;
        }
        grep { $_ >= $from }, @p;
    }
    
    is primes(2,11), (2,3,5,7,11), "a few.";
    is primes(16,100), (17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97), "a few more.";
}

#?DOES 1
{
    # P40 (**) Goldbach's conjecture.
    #
    # Goldbach's conjecture says that every positive even number greater than 2 is
    # the sum of two prime numbers. Example: 28 = 5 + 23. It is one of the most
    # famous facts in number theory that has not been proved to be correct in the
    # general case. It has been numerically confirmed up to very large numbers (much
    # larger than we can go with our Prolog system). Write a predicate to find the
    # two prime numbers that sum up to a given even integer.
    #
    # Example:
    # * (goldbach 28)
    # (5 23)
    
    our ℙ
    
    sub goldbach($n) {
        my @p = primes(1, $n-1);
        for @p -> $x {
            for @p -> $y {
                return ($x,$y) if $x+$y == $n;
            }
        }
        0;
    }
    
    is goldbach(28), (5, 23), "Goldbach works.";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/99problems-41-to-50.t0000664000175000017500000002264112231672766021622 0ustar  moritzmoritzuse v6;
use Test;
plan 13;

{
    # P41 (**) A list of Goldbach compositions.
    #
    # Given a range of integers by its lower and upper limit, print a list
    # of all even numbers and their Goldbach composition.
    #
    # Example:
    # * (goldbach-list 9 20)
    # 10 = 3 + 7
    # 12 = 5 + 7
    # 14 = 3 + 11
    # 16 = 3 + 13
    # 18 = 5 + 13
    # 20 = 3 + 17
    #
    # In most cases, if an even number is written as the sum of two prime 
    # numbers, one of them is very small. Very rarely, the primes are both 
    # bigger than say 50. Try to find out how many such cases there are in
    # the range 2..3000.
    #
    # Example (for a print limit of 50):
    # * (goldbach-list 1 2000 50)
    # 992 = 73 + 919
    # 1382 = 61 + 1321
    # 1856 = 67 + 1789
    # 1928 = 61 + 1867
    
    sub primes($from, $to) {
        my @p = (2);
        for 3..$to -> $x {
            push @p, $x unless grep { $x % $_ == 0 }, 2..ceiling sqrt $x;
        }
        grep { $_ >= $from }, @p;
    }
    
    sub goldbach($n) {
        my @p = primes(1, $n-1);
        for @p -> $x {
            for @p -> $y {
                return ($x,$y) if $x+$y == $n;
            }
        }
        0;
    }
    
    sub goldbachs($from, $to) {
        [ map { [$_, goldbach $_] }, grep { $_ % 2 == 0 }, $from .. $to ]
    }
    
    is goldbachs(3, 11), [[4, 2, 2], [6, 3, 3], [8, 3, 5], [10, 3, 7]], "yep.";
}

#?rakudo skip 's:P5///'
{
    # P46 (**) Truth tables for logical expressions.
    #
    # Define predicates and/2, or/2, nand/2, nor/2, xor/2, impl/2 and equ/2 (for
    # logical equivalence) which succeed or fail according to the result of their
    # respective operations; e.g. and(A,B) will succeed, if and only if both A and B
    # succeed. Note that A and B can be Prolog goals (not only the constants true and
    # fail).
    #
    # A logical expression in two variables can then be written in prefix notation,
    # as in the following example: and(or(A,B),nand(A,B)).
    #
    # Now, write a predicate table/3 which prints the truth table of a given logical
    # expression in two variables.
    #
    # Example:
    # * table(A,B,and(A,or(A,B))).
    # true true true
    # true fail true
    # fail true fail
    # fail fail fail
    
    
    # --
    
    
    sub stringify($Thing) {
        if $Thing {
            return 'true';
        } else {
            return 'fail'; # as per problem description
        };
    };
    
    # Obviously we can't just make 'or' respective 'and' subs
    # because those are builtin operators.  Maybe there's a way
    # around that, but I wouldn't know how to call the original
    # operator in the sub (core::and?), so I bend the task
    # description a little and just prefix the subs with
    # an underscore.
    sub _or($A, $B) {return ($A or $B)};
    sub _and($A, $B) {return ($A and $B)};
    sub _nand($A, $B) {return !($A and $B)};
    sub _nor($A, $B) {return !($A or $B)};
    sub _xor($A, $B) { # FIXME if you know DeMorgan
        return False if $A and $B;
        return ($A or $B);
    };
    sub _impl($A, $B) {
        if $A and !$B {
            return False;
        } else {
            return True;
        };
    };
    sub _equ($A, $B) {return $A == $B};
    
    sub table($expr is copy) {
    # I have to copy this around or else I get
    # "Can't modify constant item: VStr"
    # error as soon as I want to modify it
    
        $expr ~~ s:P5/^A,B,//;
        $expr ~~ s:P5:g/([AB])/$$0/;
    # first capture is now $0
        $expr ~~ s:P5:g/([nx]?or|n?and|impl|equ)/_$0/;     #:
    
        my @table;
        for (True, False) -> $A {
            for (True, False) -> $B {
                push @table, (
                    join ' ', (
                        stringify $A,
                        stringify $B,
                        stringify eval $expr
                    )
                ) ~ "\n";
            };
        };
    
        return @table;
    };
   
    #?pugs todo 
    is q[true true true
true fail true
fail true fail
fail fail fail
]
    , join('',
        table('A,B,and(A,or(A,B))')
    ), 'P46 (**) Truth tables for logical expressions.';
}

{
    # P47 (*) Truth tables for logical expressions (2).
    # 
    # Continue problem P46 by defining and/2, or/2, etc as being operators. This
    # allows to write the logical expression in the more natural way, as in the
    # example: A and (A or not B). Define operator precedence as usual; i.e.
    # as in  Java.
    # 
    # Example:
    # * table(A,B, A and (A or not B)).
    # true true true
    # true fail true
    # fail true fail
    # fail fail fail

    skip "Test(s) not yet written: (*) Truth tables for logical expressions (2).", 1;
}

{
    # P48 (**) Truth tables for logical expressions (3).
    # 
    # Generalize problem P47 in such a way that the logical expression may contain
    # any number of logical variables. Define table/2 in a way that table(List,Expr)
    # prints the truth table for the expression Expr, which contains the logical
    # variables enumerated in List.
    # 
    # Example:
    # * table([A,B,C], A and (B or C) equ A and B or A and C).
    # true true true true
    # true true fail true
    # true fail true true
    # true fail fail true
    # fail true true true
    # fail true fail true
    # fail fail true true
    # fail fail fail true
    
    skip "Test(s) not yet written: (**) Truth tables for logical expressions (3).", 1;

}

{
    # P49 (**) Gray code.
    # 
    # An n-bit Gray code is a sequence of n-bit strings constructed according to
    # certain rules. For example,
    # 
    # n = 1: C(1) = ['0','1'].
    # n = 2: C(2) = ['00','01','11','10'].
    # n = 3: C(3) = ['000','001','011','010',´110´,´111´,´101´,´100´].
    # 
    # Find out the construction rules and write a predicate with the following
    # specification:
    # 
    # % gray(N,C) :- C is the N-bit Gray code
    # 
    # Can you apply the method of "result caching" in order to make the predicate
    # more efficient, when it is to be used repeatedly?

    # TODO: add an 'is cached' trait once that's implemented
    sub gray($n) {
        return ('',) if $n == 0;
        '0' xx 2**($n-1) >>~<< gray($n-1), 
            '1' xx 2 ** ($n-1) >>~<< gray($n-1).reverse;
    }
    is gray(0), ();
    is gray(1), <0 1>;
    is gray(2), <00 01 11 10>;
    #?rakudo todo "making Parcel.reverse return a Parcel seems to break this"
    is gray(3), <000 001 011 010 110 111 101 100>;
}

#?rakudo skip 'Shaped variable declarations'
{    
    sub gray2($n) {
        return ('',) if $n == 0;
        state @g[$n] //= ('0' >>~<< gray2($n-1), '1' >>~<< gray2($n-1).reverse);
    }
    is gray2(0), ();
    is gray2(1), <0 1>, 'gray code for n = 1';
    is gray2(2), <00 01 11 10>, 'gray code for n = 2';
    is gray2(3), <000 001 011 010 110 111 101 100>, 'gry code for n = 3';
}

#?pugs skip "Cannot 'shift' scalar"
{
    # P50 (***) Huffman code.
    # 
    # First of all, consult a good book on discrete mathematics or algorithms
    # for a  detailed description of Huffman codes!
    # 
    # We suppose a set of symbols with their frequencies, given as a list of 
    # fr(S,F) terms. 
    # Example: [fr(a,45),fr(b,13),fr(c,12),fr(d,16),fr(e,9),fr(f,5)]. 
    # 
    # Our objective is to construct a list hc(S,C) terms, where C is the
    # Huffman code word for the symbol S. In our example, the result could
    # be Hs = [hc(a,'0'), # hc(b,'101'), hc(c,'100'), hc(d,'111'), 
    # hc(e,'1101'), hc(f,'1100')] [hc(a,'01'),...etc.]. The task shall be
    # performed by the predicate huffman/2
    # defined as follows:
    # 
    # % huffman(Fs,Hs) :- Hs is the Huffman code table for the frequency table Fs
    # 
    # Binary Trees
    # 
    # A binary tree is either empty or it is composed of a root element and two
    # successors, which are binary trees themselves.  In Lisp we represent the empty
    # tree by 'nil' and the non-empty tree by the list (X L R), where X denotes the
    # root node and L and R denote the left and right subtree, respectively. The
    # example tree depicted opposite is therefore represented by the following list:
    # 
    # (a (b (d nil nil) (e nil nil)) (c nil (f (g nil nil) nil)))
    # 
    # Other examples are a binary tree that consists of a root node only:
    # 
    # (a nil nil) or an empty binary tree: nil.
    # 
    # You can check your predicates using these example trees. They are given as test
    # cases in p54.lisp.
    
    my @fr = (
            ['a', 45],
            ['b', 13],
            ['c', 12],
            ['d', 16],
            ['e', 9 ],
            ['f', 5 ],
    	 );
    
    my %expected = (
            'a' => '0',
            'b' => '101',
            'c' => '100',
            'd' => '111',
            'e' => '1101',
            'f' => '1100'
            );
    
    my @c = @fr;
    
    # build the tree:
    while @c.elems > 1 {
        # Choose lowest frequency nodes and combine.  Break ties
        # to create the tree the same way each time.
        @c = sort { $^a[1] <=> $^b[1] || $^a[0] cmp $^b[0] }, @c;
        my $a = shift @c;
        my $b = shift @c;
        unshift @c, [[$a[0], $b[0]], $a[1] + $b[1]];
    }
    
    my %res;
    
    sub traverse ($a, Str $code = "") {
        if $a ~~ Str {
            %res{$a} = $code;
        } else {
            traverse($a[0], $code ~ '0');
            traverse($a[1], $code ~ '1');
        }
    }
    traverse(@c[0][0]);
    
    is(~%res.sort, ~%expected.sort, "Huffman tree builds correctly");
    
        
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/99problems-51-to-60.t0000664000175000017500000002354512224265625021622 0ustar  moritzmoritzuse v6;
use Test;
plan 37;

{
    # P54A (*) Check whether a given term represents a binary tree
    # 
    # Write a predicate istree which returns true if and only if its argument is a
    # list representing a binary tree.
    # 
    # Example:
    # * (istree (a (b nil nil) nil))
    # T
    # * (istree (a (b nil nil)))
    # NIL
    
    # We keep representing trees as lists
    # but it could be interesting to use something like
    #  subtype List::Tree of List where {istree($_)}
    # or to define a proper class Node
    
    sub istree($obj) returns Bool {
      return Bool::True unless $obj.defined;
      return +$obj==3 and istree($obj[1]) and istree($obj[2]);
    }
        
    ok istree(Any), "We tell that an empty tree is a tree";
    ok istree(['a',Any,Any]), ".. and a one-level tree is a tree";
    ok istree(['a',Any,['c',Any,Any]]), ".. and n-level trees";
    ok !istree([]), ".. and fail with empty lists";
    ok !istree(),".. or other malformed trees";
}

{
    # P55 (**) Construct completely balanced binary trees
    # 
    # In a completely balanced binary tree, the following property holds for
    # every node: The number of nodes in its left subtree and the number of
    # nodes in its right subtree are almost equal, which means their
    # difference is not greater
    # than one.
    # 
    # Write a function cbal-tree to construct completely balanced binary
    # trees for a given number of nodes. The predicate should generate all
    # solutions via
    # backtracking. Put the letter 'x' as information into all nodes of the
    # tree.
    # 
    # Example:
    # * cbal-tree(4,T).
    # T = t(x, t(x, nil, nil), t(x, nil, t(x, nil, nil))) ;
    # T = t(x, t(x, nil, nil), t(x, t(x, nil, nil), nil)) ;
    # etc......No

    sub cbal-tree(Int $n) {
        return Any if $n == 0;
        gather {
            if $n % 2 == 1 {
                my $k = ($n - 1) div 2;
                for cbal-tree($k) -> $a {
                    for cbal-tree($k) -> $b {
                        take ['x', $a, $b];
                    }
                }
            } else {
                my $k = $n div 2;
                for cbal-tree($k) -> $a {
                    for cbal-tree($k - 1) -> $b {
                        take ['x', $a, $b];
                    }
                }
                for cbal-tree($k - 1) -> $a {
                    for cbal-tree($k) -> $b {
                        take ['x', $a, $b];
                    }
                }
            }
        }
    }

    is cbal-tree(1),
       (['x', Any, Any],),
       'built a balanced binary tree with 1 item';

    is cbal-tree(2), 
       (['x', ['x', Any, Any], Any],
        ['x', Any,               ['x', Any, Any]],),
       'built a balanced binary tree with 2 items';

    is cbal-tree(3),
       (['x', ['x', Any, Any], ['x', Any, Any]],),
       'built a balanced binary tree with 3 items';

    is +cbal-tree(4), 4, 'built the right number of balanced trees with 4 items';
}

{
    # P56 (**) Symmetric binary trees
    # 
    # Let us call a binary tree symmetric if you can draw a vertical line
    # through the root node and then the right subtree is the mirror image
    # of the left subtree.
    # Write a predicate symmetric/1 to check whether a given binary tree is
    # symmetric. Hint: Write a predicate mirror/2 first to check whether one
    # tree is
    # the mirror image of another. We are only interested in the structure,
    # not in
    # the contents of the nodes.
    
    sub symmetric($tree) {
        mirror(left($tree),right($tree))
    }
    
     
    # We use multi subs so that in theory we can replace this definitions 
    # for example using classes or Array subtyping instead of lispish trees
    
    # in Rakudo you can't pass a Mu to where an Array is expected,
    # so we add multis for explicit undefined values
    multi sub mirror(Mu:U $a, Mu:U $b) { return True;  }   #OK not used
    multi sub mirror(Mu:U $a, @b)      { return False; }   #OK not used
    multi sub mirror(@a,      Mu:U $b) { return False; }   #OK not used

    multi sub mirror(@first, @second) {
        if (@first|@second == (Mu,)) {
            return @first == @second ;
        }
        mirror(left(@first),right(@second)) and mirror(right(@first),left(@second))
    }

    multi sub left(@tree) {
        @tree[1]
    }
    multi sub right(@tree) {
        @tree[2]
    }

    is left(('a',1,2)), 1, "left()  works";
    is right(('b',1,2)), 2, "right() works";

    ok mirror(Mu,Mu),"mirror works with empty trees";
    ok !mirror(Mu,[]),"mirror spots differences";
    ok mirror((1,Mu,Mu),(2,Mu,Mu)),"mirror can recurse";
    ok !mirror((1,Mu,[]),(2,Mu,Mu)),"mirror spots differences recurring";

    ok symmetric([1,Mu,Mu]), "symmetric works with 1-level trees";
    ok !symmetric([1,Mu,[2,Mu,Mu]]),"symmetric find asymettric trees";
    ok symmetric([1,
            [11,
            [111,Mu,Mu],
            [112,[1121,Mu,Mu],Mu]],
            [12,
            [121,Mu,[1221,Mu,Mu]],
            [122,Mu,Mu]]]),
       "symmetric works with n-level trees"; 
}

{
    # P57 (**) Binary search trees (dictionaries)
    # 
    # Use the predicate add/3, developed in chapter 4 of the course, to write a
    # predicate to construct a binary search tree from a list of integer numbers.
    # 
    # Example:
    # * construct([3,2,5,7,1],T).
    # T = t(3, t(2, t(1, nil, nil), nil), t(5, nil, t(7, nil, nil)))
    # 
    # Then use this predicate to test the solution of the problem P56.
    # Example:
    # * test-symmetric([5,3,18,1,4,12,21]).
    # Yes
    # * test-symmetric([3,2,5,7,1]).
    # No

    sub add-to-tree($tree, $node) {
        if not $tree.defined {
            return [$node, Any, Any] 
        } elsif $node <= $tree[0] {
            return [$tree[0], add-to-tree($tree[1], $node), $tree[2]];
        } else {
            return [$tree[0], $tree[1], add-to-tree($tree[2], $node)];
        }
    }
    sub construct(*@nodes) {
        my $tree;
        for @nodes {
            $tree = add-to-tree($tree, $_);
        }
        return $tree;
    }

    is construct(3, 2, 5, 7, 1), 
       [3, [2, [1, Any, Any], Any], [5, Any, [7, Any, Any]]],
       'Can construct a binary search tree';
}

{
    # P58 (**) Generate-and-test paradigm
    # 
    # Apply the generate-and-test paradigm to construct all symmetric, completely
    # balanced binary trees with a given number of nodes. Example:
    # 
    # * sym-cbal-trees(5,Ts).
    # 
    # Ts = [t(x, t(x, nil, t(x, nil, nil)), t(x, t(x, nil, nil), nil)), t(x, t(x, t(x, nil, nil), nil), t(x, nil, t(x, nil, nil)))]
    # 
    # How many such trees are there with 57 nodes? Investigate about how many
    # solutions there are for a given number of nodes? What if the number is even?
    # Write an appropriate predicate.

    skip "Test(s) not yet written: (**) Generate-and-test paradigm", 1;
}

{
    # P59 (**) Construct height-balanced binary trees
    # 
    # In a height-balanced binary tree, the following property holds for every
    # node: The height of its left subtree and the height of its right subtree
    # are almost equal, which means their difference is not greater than one.
    # 
    # Write a predicate hbal-tree/2 to construct height-balanced binary trees
    # for a given height. The predicate should generate all solutions via
    # backtracking. Put the letter 'x' as information into all nodes of the
    # tree.
    # 
    # Example:
    # * hbal-tree(3,T).
    # T = t(x, t(x, t(x, nil, nil), t(x, nil, nil)), t(x, t(x, nil, nil), t(x, nil, nil))) ;
    # T = t(x, t(x, t(x, nil, nil), t(x, nil, nil)), t(x, t(x, nil, nil), nil)) ;
    # etc......No

    sub heights(Mu $x) {
        return 0 unless $x.defined;
        gather {
            for heights($x[1]) { take 1 + $_ };
            for heights($x[2]) { take 1 + $_ };
        }
    }

    sub is-hbal($x) {
        my @heights = heights($x).sort;
        return @heights[*-1] - @heights[0] <= 1;
    }

    sub hbal-tree(Int $n) {
        return Mu if $n == 0;
        return ['x', Mu, Mu] if $n == 1;
        gather {
            for hbal-tree($n - 1) -> $a {
                for hbal-tree($n - 1) -> $b {
                    take ['x', $a, $b];
                }
                for hbal-tree($n - 2) -> $b {
                    if is-hbal(['x', $a, $b]) {
                        take ['x', $a, $b];
                        take ['x', $b, $a];
                    }
                }
            }
        }
    };

    # XXX somebody please check if 15 is really the expected number
    my @results = hbal-tree(3);
    is +@results, 15, 'Found 15 height balanced trees of height 3';
    for ^15  {
        ok is-hbal(@results[$_]), "tree {$_+1} is really balanced";

    }
}

{
    # P60 (**) Construct height-balanced binary trees with a given number
    # of nodes
    # 
    # Consider a height-balanced binary tree of height H. What is the maximum
    # number of nodes it can contain?  Clearly, MaxN = 2**H - 1. However, 
    # what is the minimum number MinN? This question is more difficult. 
    # Try to find a recursive
    # statement and turn it into a predicate minNodes/2 defined as follwos:
    # 
    # % minNodes(H,N) :- N is the minimum number of nodes in a 
    # height-balanced binary tree of height H.
    # 
    # (integer,integer), (+,?)
    # 
    # On the other hand, we might ask: what is the maximum height H a
    # height-balanced  binary tree with N nodes can have?
    # 
    # % maxHeight(N,H) :- H is the maximum height of a height-balanced
    # binary tree with N nodes
    # (integer,integer), (+,?)
    # 
    # Now, we can attack the main problem: construct all the height-balanced
    # binary trees with a given nuber of nodes.
    # 
    # % hbal-tree-nodes(N,T) :- T is a height-balanced binary tree with N nodes.
    # 
    # Find out how many height-balanced trees exist for N = 15.

    skip "Test(s) not yet written: (**) Construct height-balanced binary trees with a given number of nodes", 1;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/99problems-61-to-70.t0000664000175000017500000003624112224265625021621 0ustar  moritzmoritzuse v6;
use Test;
plan 15;

{
    # P61 (*) Count the leaves of a binary tree
    
    # A leaf is a node with no successors. 
    # Write a predicate count_leaves/2 to count them.
    #
    #  % count_leaves(T,N) :- the binary tree T has N leaves
    
    # only 'C' and 'D' are leaves
    my $tree = ['A', ['B', ['C', Any, Any], ['D', Any, Any]], Any];
    
    sub count_leaves($tree){
        return 0 unless defined($tree);
        return 1 if (not defined($tree[1])) and (not defined($tree[2]));
        return count_leaves($tree[1]) + count_leaves($tree[2]);
    }
    
    is(count_leaves($tree), 2, "count_leaves works");
}

{
    # P61A (*) Collect the leaves of a binary tree in a list
    # 
    # A leaf is a node with no successors. Write a predicate leaves/2 to collect them
    # in a list.
    # 
    # % leaves(T,S) :- S is the list of all leaves of the binary tree T
    
    # the spec does not specify if the tree should be flattened in pre/infix or
    # postfix order, let's just assue prefix or infix

    my $tree = ['A', ['B', ['C', Any, Any], ['D', Any, Any]], Any];
    
    my @expected = ('C', 'D');
    
    sub leaves($tree){
        return () unless defined($tree);
        return ($tree[0],) if (not defined($tree[1])) and (not defined($tree[2]));
        return leaves($tree[1]), leaves($tree[2]);
    }
    
    is(leaves($tree), @expected, "leaves() works");
}

{
    #P62 (*) Collect the internal nodes of a binary tree in a list
    
    # An internal node of a binary tree has either one or two non-empty 
    # successors. Write a predicate internals/2 to collect them in a list.
    #
    #    % internals(T,S) :- S is the list of internal nodes of the binary tree T.
     
    my $tree = ['A', ['B', ['C', Any, Any], ['D', Any, Any]], ['E', Any, Any]];
    
    my @expected = ('A', 'B');
    
    # assume preorder traversal
    
    sub internals($tree){
        return () unless defined($tree);
        if defined($tree[1]) and defined($tree[2]) {
            gather {
                take $tree[0];
                take internals($tree[1]); 
                take internals($tree[2]);
            }
        } else {
            gather { 
                take internals($tree[1]); 
                take internals($tree[2]);
            }
        }
    }
    
    is(internals($tree), @expected, "internals() collects internal nodes");
    
    # P62B (*) Collect the nodes at a given level in a list
    # 
    # A node of a binary tree is at level N if the path from the root to the node has
    # length N-1. The root node is at level 1. Write a predicate atlevel/3 to collect
    # all nodes at a given level in a list.
    # 
    # % atlevel(T,L,S) :- S is the list of nodes of the binary tree T at level L
    # 
    # Using atlevel/3 it is easy to construct a predicate levelorder/2 which creates
    # the level-order sequence of the nodes. However, there are more efficient ways
    # to do that.
    
    sub atlevel($tree, $level) {
        return unless defined($tree);
        return $tree[0] if $level == 1;
        gather {
           take atlevel($tree[1], $level - 1);
           take atlevel($tree[2], $level - 1);
        }
    }
    
    my @e1 = 'A', ;
    my @e2 = 'B', 'E';
    my @e3 = 'C', 'D';
    is(atlevel($tree, 1), @e1, "atlevel() works at level 1");
    is(atlevel($tree, 2), @e2, "atlevel() works at level 2");
    #?pugs todo
    is(atlevel($tree, 3), @e3, "atlevel() works at level 3");
}

{
    # P63 (**) Construct a complete binary tree
    # 
    # A complete binary tree with height H is defined as follows: The levels
    # 1,2,3,...,H-1 contain the maximum number of nodes (i.e 2**(i-1) at the
    # level i, note that we start counting the levels from 1 at the root).
    # In level H, which may contain less than the maximum possible number of
    # nodes, all the nodes are "left-adjusted". This means that in a
    # levelorder tree traversal all internal nodes come first, the leaves
    # come second, and empty successors (the nil's which are not really
    # nodes!) come last.
    # 
    # Particularly, complete binary trees are used as data structures (or
    # addressing schemes) for heaps.
    # 
    # We can assign an address number to each node in a complete binary tree
    # by enumerating the nodes in levelorder, starting at the root with
    # number 1. In doing so, we realize that for every node X with
    # address A the following property holds: The address of X's left and
    # right successors are 2*A and 2*A+1, respectively, supposed the
    # successors do exist. This fact can be used to elegantly construct a
    # complete binary tree structure. Write a predicate
    # complete-binary-tree/2 with the following specification:
    # 
    # % complete-binary-tree(N,T) :- T is a complete binary tree with N nodes. (+,?)
    # 
    # Test your predicate in an appropriate way.
    
    skip "Test(s) not yet written: (**) Construct a complete binary tree", 1;
}

sub count($tree) {
    return 0 unless $tree.defined;
    return 1 + count($tree[1]) + count($tree[2]);
}
    
{
    # P64 (**) Layout a binary tree (1)
    # 
    # Given a binary tree as the usual Prolog term t(X,L,R) (or nil). As a
    # preparation for drawing the tree, a layout algorithm is required to determine
    # the position of each node in a rectangular grid. Several layout methods are
    # conceivable, one of them is shown in the illustration below.
    # 
    # In this layout strategy, the position of a node v is obtained by the following
    # two rules:
    # 
    # * x(v) is equal to the position of the node v in the inorder sequence
    # * y(v) is equal to the depth of the node v in the tree
    # 
    # 
    # 
    # In order to store the position of the nodes, we extend the Prolog term
    # representing a node (and its successors) as follows:
    # 
    # % nil represents the empty tree (as usual)
    # % t(W,X,Y,L,R) represents a (non-empty) binary tree with root W "positioned" at (X,Y), and subtrees L and R
    # 
    # Write a predicate layout-binary-tree/2 with the following specification:
    # 
    # % layout-binary-tree(T,PT) :- PT is the "positioned" binary tree obtained from
    # the binary tree T. (+,?)
    # 
    # Test your predicate in an appropriate way.
     
    my $tree = ['n', ['k', ['c', ['a', Any, Any], ['h', ['g', ['e', Any, Any], Any], Any]], ['m', Any, Any]], ['u', ['p', Any, ['s', ['q', Any, Any]], Any], Any]];
      
    my $expected = ['n', 8, 1, 
            ['k', 6, 2, 
                ['c', 2, 3, 
                    ['a', 1, 4,  Any, Any], 
                    ['h', 5, 4,  
                        ['g', 4, 5, 
                            ['e', 3, 6, Any, Any], Any], Any]], 
                ['m', 7, 3, Any, Any]], 
            ['u', 12, 2, 
                ['p', 9, 3, Any, 
                    ['s', 11, 4,
                        ['q', 10, 5, Any, Any]], Any], Any]];
    
    sub align($tree, $prev_x, $prev_y, $lr){
        return Any unless defined($tree);
        my $y = $prev_y + 1;
        my $x = 0;
        if $lr eq "l" {
            $x = $prev_x - 1 - count($tree[2]);
        } else {
            $x = $prev_x + 1 + count($tree[1]);
        }
        return [$tree[0], 
               $x, 
               $y, 
               align($tree[1], $x, $y, "l"),
               align($tree[2], $x, $y, "r")];
    }
    my $result = align($tree, 0, 0, "r");
    
    is($result, $expected, "tree alignment works");
}

{
    # P64 (**) Layout a binary tree (1)
    # 
    # Given a binary tree as the usual Prolog term t(X,L,R) (or nil). As a
    # preparation for drawing the tree, a layout algorithm is required to determine
    # the position of each node in a rectangular grid. Several layout methods are
    # conceivable, one of them is shown in the illustration below.
    # 
    # In this layout strategy, the position of a node v is obtained by the following
    # two rules:
    # 
    # * x(v) is equal to the position of the node v in the inorder sequence
    # * y(v) is equal to the depth of the node v in the tree
    # 
    # 
    # 
    # In order to store the position of the nodes, we extend the Prolog term
    # representing a node (and its successors) as follows:
    # 
    # % nil represents the empty tree (as usual)
    # % t(W,X,Y,L,R) represents a (non-empty) binary tree with root W "positioned" at (X,Y), and subtrees L and R
    # 
    # Write a predicate layout-binary-tree/2 with the following specification:
    # 
    # % layout-binary-tree(T,PT) :- PT is the "positioned" binary tree obtained from
    # the binary tree T. (+,?)
    # 
    # Test your predicate in an appropriate way.
     
    my $tree = ['n', ['k', ['c', ['a', Any, Any], ['h', ['g', ['e', Any, Any], Any], Any]], ['m', Any, Any]], ['u', ['p', Any, ['s', ['q', Any, Any]], Any], Any]];
      
    my $expected = ['n', 8, 1, 
            ['k', 6, 2, 
                ['c', 2, 3, 
                    ['a', 1, 4,  Any, Any], 
                    ['h', 5, 4,  
                        ['g', 4, 5, 
                            ['e', 3, 6, Any, Any], Any], Any]], 
                ['m', 7, 3, Any, Any]], 
            ['u', 12, 2, 
                ['p', 9, 3, Any, 
                    ['s', 11, 4,
                        ['q', 10, 5, Any, Any]], Any], Any]];
    
    sub align2($tree, $prev_x, $prev_y, $lr){
        return Any unless defined($tree);
        my $y = $prev_y + 1;
        my $x = 0;
        if $lr eq "l" {
            $x = $prev_x - 1 - count($tree[2]);
        } else {
            $x = $prev_x + 1 + count($tree[1]);
        }
        return [$tree[0], 
               $x, 
               $y, 
               align2($tree[1], $x, $y, "l"),
               align2($tree[2], $x, $y, "r")];
    }
    my $result = align2($tree, 0, 0, "r");
    
    is($result, $expected, "tree alignment works");
}

{
    # P66 (***) Layout a binary tree (3)
    # 
    # Yet another layout strategy is shown in the illustration opposite. The
    # method yields a very compact layout while maintaining a certaing
    # symmetry in every node. Find out the rules and write the corresponding
    # Prolog predicate. Hint: Consider the horizontal distance between a node
    # and its successor nodes. How tight can you pack together two subtrees
    # to construct the combined binary tree?
    # 
    # Use the same conventions as in problem P64 and P65 and test your
    # predicate in an appropriate way. Note: This is a difficult problem.
    # Don't give up too early!
    # 
    # Which layout do you like most?
    
    skip "Test(s) not yet written: (***) Layout a binary tree (3)", 1;
}

{
    # P67 (**) A string representation of binary trees
    # 
    # 
    # Somebody represents binary trees as strings of the following type
    # (see example opposite):
    # 
    # a(b(d,e),c(,f(g,)))
    # 
    # a) Write a Prolog predicate which generates this string representation,
    # if the tree is given as usual (as nil or t(X,L,R) term). Then write a
    # predicate which does this inverse; i.e. given the string representation,
    # construct the tree in the usual form. Finally, combine the two
    # predicates in a single predicate tree-string/2 which can be used in
    # both directions.
    
    my $tree = ['a', ['b', ['d'], ['e']], ['c', Any, ['f', ['g']]]]; 
    my $expected = "a(b(d,e),c(,f(g,)))";
    
    sub stringify($tree) {
        return '' unless defined($tree);
        return $tree[0] if not defined($tree[1]) and (not defined($tree[2]));
        return $tree[0] ~ '(' ~ stringify($tree[1]) ~ ',' ~ stringify($tree[2]) ~ ')';
    }
    
    is(stringify($tree), $expected, "string representation of binary tree");
    
    # b) Write the same predicate tree-string/2 using difference lists and a single
    # predicate tree-dlist/2 which does the conversion between a tree and a
    # difference list in both directions.
    # 
    # For simplicity, suppose the information in the nodes is a single letter
    # and there are no spaces in the string.
    
    skip "Test(s) not yet written: (**) A string representation of binary trees", 1;
}

{
    # P68 (**) Preorder and inorder sequences of binary trees
    # 
    # We consider binary trees with nodes that are identified by single lower-case
    # letters, as in the example of problem P67.
    # 
    # a) Write predicates preorder/2 and inorder/2 that construct the preorder and
    # inorder sequence of a given binary tree, respectively. The results should be
    # atoms, e.g. 'abdecfg' for the preorder sequence of the example in problem P67.
    # 
    # b) Can you use preorder/2 from problem part a) in the reverse direction; i.e.
    # given a preorder sequence, construct a corresponding tree? If not, make the
    # necessary arrangements.
    # 
    # c) If both the preorder sequence and the inorder sequence of the nodes of a
    # binary tree are given, then the tree is determined unambiguously. Write a
    # predicate pre-in-tree/3 that does the job.
    # 
    # d) Solve problems a) to c) using difference lists. Cool! Use the predefined
    # predicate time/1 to compare the solutions.
    # 
    # What happens if the same character appears in more than one node. Try for
    # instance pre-in-tree(aba,baa,T).
    
    skip "Test(s) not yet written: (**) Preorder and inorder sequences of binary trees", 1;
}

{
    # P69 (**) Dotstring representation of binary trees
    # 
    # We consider again binary trees with nodes that are identified by single
    # lower-case letters, as in the example of problem P67. Such a tree can be
    # represented by the preorder sequence of its nodes in which dots (.) are
    # inserted where an empty subtree (nil) is encountered during the tree
    # traversal. For example, the tree shown in problem P67 is represented as
    # 'abd..e..c.fg...'. First, try to establish a syntax (BNF or syntax diagrams)
    # and then write a predicate tree-dotstring/2 which does the conversion in both
    # directions. Use difference lists.
    # 
    # Multiway Trees
    # 
    # A multiway tree is composed of a root element and a (possibly empty) set of
    # successors which are multiway trees themselves. A multiway tree is never
    # empty. The set of successor trees is sometimes called a forest.
    # 
    # 
    # In Prolog we represent a multiway tree by a term t(X,F), where X denotes the
    # root node and F denotes the forest of successor trees (a Prolog list). The
    # example tree depicted opposite is therefore represented by the following
    # Prolog term:
    # 
    # T = t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])
    
    skip "Test(s) not yet written: (**) Dotstring representation of binary trees", 1;
}

{
    # P70 (**) Tree construction from a node string
    # 
    # We suppose that the nodes of a multiway tree contain single characters. In the
    # depth-first order sequence of its nodes, a special character ^ has been
    # inserted whenever, during the tree traversal, the move is a backtrack to the
    # previous level.
    # 
    # By this rule, the tree in the figure opposite is represented as: afg^^c^bd^e^^^
    # 
    # Define the syntax of the string and write a predicate tree(String,Tree) to
    # construct the Tree when the String is given. Work with atoms (instead of
    # strings). Make your predicate work in both directions.
    
    skip "Test(s) not yet written: (**) Tree construction from a node string", 1;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/advent2009-day01.t0000664000175000017500000000037012224265625021226 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/01/day-1-getting-rakudo/

use v6;
use Test;

plan(2);

# say "Hello World";

is( (10/7).WHAT.gist, '(Rat)', 'WHAT');

is(([+] (1..999).grep( { $_ % 3 == 0 || $_ % 5 == 0 } )), 233168, 'Project Euler #1');
rakudo-2013.12/t/spec/integration/advent2009-day02.t0000664000175000017500000000155312224265625021233 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/02/day-2-the-beauty-of-formatting/

use v6;
use Test;
plan 10;

#?niecza skip 'invalid format specifier'
is(42.fmt('%+d'),           '+42'     );
is(42.fmt('%4d'),           '  42'    );
is(42.fmt('%04d'),          '0042'    );
is(:16<1337f00d>.fmt('%X'), '1337F00D');

is(.fmt,    'huey dewey louie');
is(<10 11 12>.fmt('%x'),      'a b c');
is(<1 2 3>.fmt('%02d', '; '), '01; 02; 03');

#?niecza 2 todo "junction match fails"
is {foo => 1, bar => 2}.fmt, "foo\t1\nbar\t2"|"bar\t2\nfoo\t1", 'Hash.fmt';

is { Apples => 5, Oranges => 10 }.fmt('%s cost %d euros'),
    "Apples cost 5 euros\nOranges cost 10 euros"|"Oranges cost 10 euros\nApples cost 5 euros";
is { huey => 1, dewey => 2, louie => 3 }.fmt('%s', ' -- ').split(' -- ').sort.join(' -- '),
    'dewey -- huey -- louie', 'Hash with two-arg fmt';


done;
rakudo-2013.12/t/spec/integration/advent2009-day03.t0000664000175000017500000000241512224265625021232 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/03/day-3-static-types-and-multi-subs/

use v6;
use Test;
plan 6;

my Int $days = 24;

my Str $phrase = "Hello World";
my Num $pi = 3.141e0;
my Rat $other_pi = 22/7;

multi sub identify(Int $x) {
    return "$x is an integer.";
}

multi sub identify(Str $x) {
    return qq<"$x" is a string.>;
}

multi sub identify(Int $x, Str $y) {
    return "You have an integer $x, and a string \"$y\".";
}

multi sub identify(Str $x, Int $y) {
    return "You have a string \"$x\", and an integer $y.";
}

multi sub identify(Int $x, Int $y) {
    return "You have two integers $x and $y.";
}

multi sub identify(Str $x, Str $y) {
    return "You have two strings \"$x\" and \"$y\".";
}

is identify(42), "42 is an integer.", 'MMD with one Int';
#?pugs todo
is identify("This rules!"), '"This rules!" is a string.', 'MMD with one Str';
is identify(42, "This rules!"), 'You have an integer 42, and a string "This rules!".' , "MMD with Int and Str";
#?pugs todo
is identify("This rules!", 42), 'You have a string "This rules!", and an integer 42.' , "MMD with Int and Str";
#?pugs todo
is identify("This rules!", "I agree!"), "You have two strings \"This rules!\" and \"I agree!\".", 'Str, Str';
#?pugs todo
is identify(42, 24), "You have two integers 42 and 24.";
rakudo-2013.12/t/spec/integration/advent2009-day04.t0000664000175000017500000000056712224265625021241 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/04/day-4-testing/

use v6;

sub fac(Int $n) {
    [*] 1..$n
}

use Test;
plan 6;

is fac(0), 1,  'fac(0) works';
is fac(1), 1,  'fac(1) works';
is fac(2), 2,  'fac(2) works';
is fac(3), 6,  'fac(3) works';
is fac(4), 24, 'fac(4) works';

#?pugs todo
dies_ok { eval(q[ fac('oh noes i am a string')]) }, 'Can only call it with ints';
rakudo-2013.12/t/spec/integration/advent2009-day05.t0000664000175000017500000000312712224265625021235 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/05/day-5-metaoperator/

use v6;
use Test;

plan 17;

my $a = 4;
my $b = 2;
my @a = 2, 4, 6, 8;
my @b = 16, 14, 12, 10;

my @a_copy;
my $a1;
my $a2;

is ([+]  1, $a, 5, $b), (1 + $a + 5 + $b), 'Reduce metaop becomes an infix list op';
is ([+] @a), 20, 'Sum all elements in a list';
is ([*] @a), 384, 'Multiply all elements in a list';
ok ([<=] @a), 'All elements of list are numerically sorted';
nok ([<=] @b), 'Not all elements of list are numerically sorted';
is ([min] @a, @b), 2, 'Find the smallest element of two lists';
is (@a »+« @b), [18, 18, 18, 18], 'Hyper operator - pairwise addition';
is (@a_copy = @a; @a_copy»++; @a_copy), [3, 5, 7, 9], 'Hyper operator - increment all elements in a list';
is (@a »min« @b), [2, 4, 6, 8], 'Hyper operator - finding minimum elements';
is (@a »*» 3.5), [7, 14, 21, 28], 'Hyper operator - multiply each element by 3.5';
is (@a »*» $a »+» $b), [10, 18, 26, 34], 'Hyper operator - multiple each element by $a and add $b';
is (1 «/« @a;), [1/2, 1/4, 1/6, 1/8], 'Hyper operator - invert all elements';
is ((@a »~» ', ') »~« @b), ["2, 16", "4, 14", "6, 12", "8, 10"], 'Hyper operator - concat @a and @b';
is ([+] ( @b »**» 2)), 696, 'Hyper operator - sum of squares';
is ($a1 = $a; $a1 += 5;), ($a2 = $a; $a2 = $a2 + 5), 'In-place += operator is a meta form of + with = suffix';
is ($a1 = $a; $a1 //= 7;), ($a2 = $a; $a2 = $a2 // 7), 'In-place //= operator is a meta form of // with = suffix';
is ($a1 = $a; $a1 min= $b;), ($a2 = $a; $a2 = $a2 min $b), 'In-place min= operator is a meta form of min with = suffix';

done;
rakudo-2013.12/t/spec/integration/advent2009-day06.t0000664000175000017500000000240012224265625021227 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/06/day-6-going-into-hyperspace/

use v6;
use Test;

plan 15;

my @a = 1, 2, 3, 4;
my @b = 3, 1;
my @c = 3, 1, 3, 1;

my @a-copy;
my @pi = 0, pi/4, pi/2, pi, 2*pi;
my @pi-sin = @pi>>.sin;

is (@a <<+>> @c), [4, 3, 6, 5], 'Dwimmy hyperoperator on arrays of the same length';
is (@a >>+<< @c), [4, 3, 6, 5], 'Non-dwimmy hyperoperator on arrays of the same length';
is (@a <<+>> @b), [4, 3, 6, 5], 'Dwimmy hyperoperator on arrays of different size';
dies_ok {@a >>+<< @b}, 'Non-dwimmy hyperoperator on arrays of different size fails';
is (@a >>+>> 2), [3, 4, 5, 6], 'Single scalars extend to the right';
is (3 <<+<< @a), [4, 5, 6, 7], 'Single scalars extend to the left';
is (~<<@a), ["1", "2", "3", "4"], 'Hyperoperator with prefix operator';
is (@a-copy = @a; @a-copy>>++; @a-copy), [2, 3, 4, 5], 'Hyperoperator with postfix operator';
for @pi Z @pi-sin -> $elem, $elem-sin {
    is_approx $elem.sin, $elem-sin, 'Hyperoperator used to call .sin on each list element';
}
is ((-1, 0, 3, 42)>>.Str), ["-1", "0", "3", "42"], 'Hyperoperator used to call .Str on each list element';

#?rakudo todo "Cannot assign to readonly value"
#?niecza todo
{
	is (@a-copy = @a; @a-copy >>/=>> 2; @a-copy), [2, 3, 4, 5], 'in-place operators work';
}

done;
rakudo-2013.12/t/spec/integration/advent2009-day07.t0000664000175000017500000000353212224265625021237 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/07/day-7-looping-for-fun-and-profit/

use v6;
use Test;

plan 13;

my $a = '';
for 1, 2, 3, 4 { $a ~= $_ }
is $a, '1234', '$_ is default topic';

$a = 0;
for 1, 2, 3, 4 -> $i { $a += $i }
is $a, 10, 'explicit topic';

$a = '';
for 1, 2, 3, 4 -> $i, $j { $a ~= "$j $i " }
is $a, '2 1 4 3 ', '2 topics';

my @array = ;

$a = '';
for @array { $a ~= $_ }
is $a, 'abcd', '$_ is default topic, variable list';

# XXX These need to be converted to something testable.
# @array.map: *.say;
#?rakudo skip "No candidates found to invoke"
#?niecza skip 'Excess arguments to CORE Any.map, used 2 of 4 positionals'
#?pugs skip 'No compatible multi variant found: "&is"'
{
	is @array.map: *.Int , (1, 2, 3, 4) , 'Testing map form';
}
# @array>>.say;
is @array».Str ,  , 'Testing hyperoperator form';


$a = '';
for 1..4 { $a ~= $_ };
is $a, '1234', 'simple range';

$a = '';
for ^4 { $a ~= $_ };
is $a, '0123', 'upto';

my @array1 = <11 12 13>;
my @array2 = <21 22 23>;

$a = '';
for @array1 Z @array2 -> $one, $two { $a ~= "$one $two " };
#?pugs todo
is $a, '11 21 12 22 13 23 ', 'zip with multiple topics';

$a = '';
for ^Inf Z @array -> $index, $item { $a ~= "$index $item " };
is $a, '0 a 1 b 2 c 3 d ', 'infinite upto, zip with multiple topics';

$a = '';
for ^@array.elems Z @array -> $index, $item { $a ~= "$index $item " };
is $a, '0 a 1 b 2 c 3 d ', 'elems upto, zip with multiple topics';

$a = '';
for @array.kv -> $index, $item { $a ~= "$index $item " };
is $a, '0 a 1 b 2 c 3 d ', '.kv, multiple topics';

#?pugs todo
{
    my @one   = <11 12 13>;
    my @two   = <21 22 23>;
    my @three = <31 32 33>;
    my @four  = <41 42 43>;

    $a = '';
    for @one Z @two Z @three Z @four -> $one, $two, $three, $four {
        $a ~= "$one $two $three $four "
    };
    is $a, '11 21 31 41 12 22 32 42 13 23 33 43 ';
}

done;
rakudo-2013.12/t/spec/integration/advent2009-day08.t0000664000175000017500000000254712224265625021245 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/08/day-8-comb-your-constraints/

use v6;
use Test;

plan 8;

multi sub very_odd(Int $odd where {$odd % 2}) { Bool::True }
multi sub very_odd(Int $odd) { Bool::False }   #OK not used

ok very_odd(1), 'Type constraint - odd number';
nok very_odd(2), 'Type constraint - even number';

{
    is "Perl 6 Advent".comb(//).join('|'), 'P|e|r|l|A|d|v|e|n|t', 'Comb for  and join on |';
    is "Perl 6 Advent".comb(/+/).join('|'), 'Perl|Advent', 'Comb for + and join on |';
}
is "5065726C36".comb(/**2/)».fmt("0x%s")».chr.join, 'Perl6', 'Comb ASCII hex chars with hyperop to convert to ASCII equivalent';

is ("5065726C36".comb(/**2/).map: { chr "0x" ~ $_ }).join, 'Perl6', 'Comb ASCII hex chars using map to convert to ASCII equivalent';

sub rotate_one( Str $c where { $c.chars == 1 }, Int $n ) {
    return $c if $c !~~ //;
    my $out = $c.ord + $n;
    $out -= 26 if $out > ($c eq $c.uc ?? 'Z'.ord !! 'z'.ord);
    return $out.chr;
}

sub rotate(Str $s where {$s.chars}, Int $n = 3)
{
    return ($s.comb.map: { rotate_one( $_, $n % 26 ) }).join( '' );
}

my Str $mess = 'Perl6 Advent Calendar';
my Int $rotate = 10;

is rotate($mess,$rotate), 'Zobv6 Knfoxd Mkvoxnkb', "Caesar Cipher using .comb and .map";
is rotate($mess), 'Shuo6 Dgyhqw Fdohqgdu', 'Caesar Cipher using parameter defaults';
rakudo-2013.12/t/spec/integration/advent2009-day09.t0000664000175000017500000000545612224265625021250 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/09/day-9-having-beautiful-arguments-and-parameters/

use v6;
use Test;
plan 17;

sub sum {
    [+] @_ ;
}

sub grade_essay(Str $essay, Int $grade where 0..5) { #Type Essay replace w/ Str to avoid extraneous programming.
    my %grades;
    %grades{$essay} = $grade;
}

sub entreat($message = 'Pretty please, with sugar on top!', $times = 1) {
    $message x $times
}

sub xml_tag ($tag, $endtag = ($tag ~ ">") ) {
    $tag ~ $endtag;
}

sub deactivate(Str $plant, Str $comment?) {   #OK not used
    return 1 if $comment;
}

sub drawline($x1,$x2,$y1,$y2) {
    $x1,$x2,$y1,$y2;
}
sub drawline2(:$x1,:$x2,:$y1,:$y2) {
    $x1,$x2,$y1,$y2;
}

sub varsum(*@terms) {
    [+] @terms
}

sub detector(:$foo!, *%bar) {
    %bar.keys.fmt("'%s'", ', ');
}
sub up1($n) {
    ++$n;
}
sub up1_2($n is rw) {
    ++$n;
}
sub up1_3($n is copy) {
    ++$n;
}
sub namen($x, $y, $z) {
    $x,$y,$z;
}

is (sum 100,20,3), 123, 'Parameter handling in subroutines (@_)';
is grade_essay("How to eat a Fish", 0), 0, 'P6 auto unpacking/verification';
ok (entreat()), 'Default values for parameters works';
is (xml_tag("hi")), "hihi>", 'Default values using previously supplied arguments';
nok deactivate("Rakudo Quality Fission"), 'optional parameters';
dies_ok {drawline2(1,2,3,4)}, 'Must be named';
ok (drawline2(:x1(3))), 'When you force naming, they are not all required.';
#the required & must-be named (:$var!) test not here, its opposite is 1 up
is (varsum(100,200,30,40,5)), 375, 'Parameters with a * in front can take as many items as you wish';
#?niecza todo 'Capturing arbitrary named parameters'
is detector(:foo(1), :bar(2), :camel(3)), ("'bar', 'camel'"|"'camel', 'bar'"), 'Capturing arbitrary named parameters';
#?niecza todo 'Capturing arbitrary named parameters as hash'
is (detector(foo => 1, bar => 2, camel => 3)), ("'bar', 'camel'"|"'camel', 'bar'"), 'Same as above test, only passed as hash';
my $t = 3;
dies_ok {up1($t)}, "Can't modify parameters within by default.";
up1_2($t);
is $t, 4, 'Set a parameter to "is rw", and then you can modify';
up1_3($t);
is $t, 4, '"is copy" leaves original alone"';
my @te = ;
dies_ok {eval 'namen(@te)' }, 'Autoflattening doesnt exist';
is (namen(|@te)), ('a','b','c'), "Put a | in front of the variable, and you're ok!";

is <734043054508967647390469416144647854399310>.comb(/.**7/).join('|') , '7340430|5450896|7647390|4694161|4464785|4399310' , 'Test one liner at end of post (part1)';
{
	is '7340430'.fmt("%b").trans("01" => " #") , '###           ##   ### ' , 'Test one liner at end of post (part2)';
}

done;
#type constraint on parameters skipped, due to that part of Day 9 being just a caution

#test done, below is the day's one-liner (in case you wish to enable it :) )
#.fmt("%b").trans("01" => " #").say for <734043054508967647390469416144647854399310>.comb(/.**7/)
rakudo-2013.12/t/spec/integration/advent2009-day10.t0000664000175000017500000000161412224265625021230 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/10/day-10-a-regex-story/

use v6;
use Test;

plan 5;

grammar Inventory {
    regex product { \d+ }
    regex quantity { \d+ }
    regex color { \S+ }
    regex description { \N* }
    regex TOP { ^^  \s+   \s+
                [
                |  \s+ '(' \s*  \s*  ')'
                |  \s+ 
                ]
                $$
    }
}


nok Inventory.parse('abc') , 'Incorrect line does not parse';

ok Inventory.parse('1234 3 red This is a description') , "Standard line parsed ok";
is ($,$,$,$) , ('1234' ,'3','red','This is a description') , "Result OK";

ok Inventory.parse('1234 3 This is a description (red)') , "Color in description";
is ($,$,$,$) , ('1234' ,'3','red','This is a description') , "Result OK";


done;
rakudo-2013.12/t/spec/integration/advent2009-day11.t0000664000175000017500000000161012224265625021225 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/11/day-11-classes-attributes-methods-and-more/

use v6;
use Test;

plan 6;

class Dog {
    has $.name;
    method bark($times) {
        "w00f! " x $times;
    }
}

my $fido = Dog.new(name => 'Fido');
is $fido.name, 'Fido', 'correct name';
is $fido.bark(3), 'w00f! w00f! w00f! ', 'Can bark';

class Puppy is Dog {
    method bark($times) {
        "yap! " x $times;
    }
}

is Puppy.new.bark(2), 'yap! yap! ', 'a Puppy can bark, too';

class DogWalker {
    has $.name;
    has Dog $.dog handles (dog_name => 'name');
}
my $bob = DogWalker.new(name => 'Bob', dog => $fido);
is $bob.name, 'Bob', 'dog walker has a name';
#?pugs skip 'no such method'
is $bob.dog_name, 'Fido', 'dog name can be accessed by delegation';

# RT 75180
#?pugs skip 'no such ^methods'
is Dog.^methods(:local).map({.name}).sort.join('|'),
    'bark|name', 'can introspect Dog';

done;
rakudo-2013.12/t/spec/integration/advent2009-day12.t0000664000175000017500000000245312224265625021234 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/12/day-12-modules-and-exporting/

use v6;
use Test;

plan 9;

BEGIN {
    @*INC.push: 't/spec/packages';
}

{
    eval_lives_ok 'use Fancy::Utilities', 'Can use Fancy::Utilities';

    use Fancy::Utilities :greet;
    is Fancy::Utilities::lolgreet('Tene'), 'O HAI TENE', 'Referencing subs by fullname works';
    is lolgreet('Jnthn'), 'O HAI JNTHN', 'Exporting symbols works';
}

#?rakudo skip "Importing symbols by name doesn't work in current Rakudo"
{
    eval_lives_ok 'use Fancy::Utilities :shortgreet, :lolgreet;', 'Can import symbols by name';

    use Fancy::Utilities :shortgreet, :lolgreet;
    is lolgreet('Tene'), 'O HAI TENE', 'Explicitly importing symbols by name works';
    #?pugs todo
    nok nicegreet('Jnthn'), 'Good morning, Jnthn!', 'Cannot use a sub not explicitly imported';
}

{
    eval_lives_ok 'use Fancy::Utilities :ALL;', 'Can import everything marked for export using :ALL';

    use Fancy::Utilities :ALL;
    is lolrequest("Cake"), 'I CAN HAZ A CAKE?', 'Can use a sub marked as exported and imported via :ALL';
}

#?rakudo skip "Multi subs aren't imported by default in current Rakudo - is this to spec?"
#?pugs skip "No such subroutine"
{
    use Fancy::Utilities;
    is greet(), 'Hi!', "Multi subs are imported by default - is this to spec?";
}
rakudo-2013.12/t/spec/integration/advent2009-day13.t0000664000175000017500000000200012224265625021221 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/13/day-13-junctions/

use v6;
use Test;

plan 16;

my @a = 1,2,3;
my @b = 1,2,3;
my @c = 0,4;

my $in  = 3;
my $out = 0;

ok ($in == any(3, 5, 7)), '$var == any(3,5,7)';
nok ($out == any(3, 5, 7)), '$var == any(3,5,7)';
ok ($in == 3|5|7), '$var == 3|5|7';
nok ($out == 3|5|7), '$var == 3|5|7';
ok ($out == none(3,5,7)), '$var == none(3,5,7)';
nok ($in == none(3,5,7)), '$var == none(3,5,7)';

ok ( (any(1, 2, 3) + 2).perl , any(3, 4, 5) , 'Junction + Int gives Junction');

ok 'testing' ~~ /t/ & /s/ & /g/ , "'testing' ~~ /t/ & /s/ & /g/";
nok 'testing' ~~ /x/ & /s/ & /g/ , "'testing' ~~ /x/ & /s/ & /g/";
ok 'testing' ~~ /t/ | /s/ | /g/ , "'testing' ~~ /t/ | /s/ | /g/";
ok 'testing' ~~ /x/ | /s/ | /g/ , "'testing' ~~ /x/ | /s/ | /z/";
nok 'testing' ~~ /x/ | /y/ | /z/ , "'testing' ~~ /x/ | /y/ | /z/";

ok (any(@a) == $in), 'any(@list) == $var';
ok (all(@a) > 0), 'all(@list) > 0';
ok (all(@a) == any(@b)), 'all(@a) == any(@b)';
nok (all(@c) == any(@b)), 'all(@a) == any(@b)';
rakudo-2013.12/t/spec/integration/advent2009-day14.t0000664000175000017500000000201512224265625021230 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/14/day-14-going-to-the-rats/

use v6;
use Test;

plan 21;

is (3/7).WHAT, Rat;
is_approx (3/7), 0.4285714;

is_approx (3/7).Num + (2/7).Num + (2/7).Num - 1, -1.1102230e-16;
is 3/7 + 2/7 + 2/7 - 1,  0;

#?pugs todo "<>"
is (3/7).perl, "<3/7>";

is (3/7).numerator, 3;
is (3/7).denominator, 7;
#?pugs skip 'nude'
is (3/7).nude.join('|'), "3|7";

my $a = 1/60000 + 1/60000; 
is $a.WHAT, Rat;
is_approx $a, 3.3333333e-05;
#?pugs todo "<>"
is $a.perl, "<1/30000>";

$a = 1/60000 + 1/60001;
ok $a ~~ Rat || $a ~~ Num, "1/60000 + 1/60001 must be a Rat or a Num";
is_approx $a, 3.333305e-05;

$a = cos(1/60000);
ok $a ~~Num, 'cos() returned a Num';
is_approx $a, 0.99999999;

# I'm not at all convinced the next three are sensible tests -- colomon
#?pugs todo "<>"
is 3.14.Rat.perl, "3.14";
#?pugs todo "<>"
is pi.Rat.perl, "<355/113>";
#?pugs todo "<>"
is pi.Rat(1e-10).perl, "<312689/99532>";

is 1.75.WHAT, Rat;
#?pugs todo "<>"
is 1.75.perl, "1.75";
#?pugs todo "<>"
is 1.752.perl, "1.752";

done;
rakudo-2013.12/t/spec/integration/advent2009-day15.t0000664000175000017500000000123712224265625021236 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/15/day-15-pick-your-game/

use v6;
use Test;

plan 4;

my @dice = 1..6;
is @dice.pick(2).elems, 2, 'Picking two elements using pick()';
is @dice.pick(10).elems, @dice.elems, 'Picking all elements using pick()';
#?pugs skip 'roll'
is @dice.roll(10).elems, 10, 'Picking 10 elements from a list of 6 using roll';

class Card
{
  has $.rank;
  has $.suit;

  multi method Str()
  {
    return $.rank ~ $.suit;
  }
}

my @deck;
for  -> $rank
{
  for <♥ ♣ ♦ ♠> -> $suit
  {
    @deck.push(Card.new(:$rank, :$suit));
  }
}

{
    @deck .= pick(*);
    is @deck.elems, 4 * 13, 'Shuffled card deck';
}
rakudo-2013.12/t/spec/integration/advent2009-day16.t0000664000175000017500000000463012224265625021237 0ustar  moritzmoritz# 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)=.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)=.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;
rakudo-2013.12/t/spec/integration/advent2009-day17.t0000664000175000017500000000644512224265625021246 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/17/day-17-making-snowmen/

use v6;
use Test;

plan 62;

my $height = @*ARGS[0] // 31;
my $width = $height;
my $max_iterations = 50;

my $upper-right = -2 + (5/4)i;
my $lower-left = 1/2 - (5/4)i;

sub mandel(Complex $c) {
    my $z = 0i;
    for ^$max_iterations {
        $z = $z * $z + $c;
        return 1 if ($z.abs > 2);
    }
    return 0;
}

sub subdivide($low, $high, $count) {
    (^$count).map({ $low + ($_ / ($count - 1)) * ($high - $low) });
}

# RAKUDO - needs 'our' here
our sub postfix:<☃>(Complex $c) {
    my $z = 0i;
    for ^$max_iterations {
        $z = $z * $z + $c;
        return 1 if ($z.abs > 2);
    }
    return 0;
}

my $snowman =
Q{1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1
1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1
1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1
1 1 1 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 1 1 1
1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 1 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
};

my @snowman-data = $snowman.split("\n");

# using map
for ^$height Z subdivide($upper-right.re, $lower-left.re, $height) -> $i, $re {
    my @line = subdivide($re + ($upper-right.im)i, $re + 0i, ($width + 1) / 2).map({ mandel($_) });
    my $middle = @line.pop;
    is (@line, $middle, @line.reverse).join(' ').trim, @snowman-data[$i].trim, "Line $i matched using map()";
}

# using the >>☃ hyperoperator
for ^$height Z subdivide($upper-right.re, $lower-left.re, $height) -> $i, $re {
    my @line = subdivide($re + ($upper-right.im)i, $re + 0i, ($width + 1) / 2)>>☃;
    my $middle = @line.pop;
    is (@line, $middle, @line.reverse).join(' ').trim, @snowman-data[$i].trim, "Line $i matched using >>☃ hyperoperator";
}

done;
rakudo-2013.12/t/spec/integration/advent2009-day18.t0000664000175000017500000000425612224265625021245 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/18/day-18-roles/

use v6;
use Test;
plan 6;

role BatteryPower {
    has $.battery-type;
    has $.batteries-included;
    method find-power-accessories() {
        return ProductSearch::find($.battery-type);
    }
}

class ElectricCar does BatteryPower {
    has $.manufacturer;
    has $.model;
}

role SocketPower {
    has $.adapter-type;
    has $.min-voltage;
    has $.max-voltage;
    method find-power-accessories() {
        return ProductSearch::find($.adapter-type);
    }
}

#~ class Laptop does BatteryPower does SocketPower {}
eval_dies_ok 'class Laptop does BatteryPower does SocketPower {}' , "Method 'find-power-accessories' collides and a resolution must be provided by the class";

class Laptop does BatteryPower does SocketPower {
    method find-power-accessories() {
        my $ss = $.adapter-type ~ ' OR ' ~ $.battery-type;
        return ProductSearch::find($ss);
    }
}

my Laptop $l ;
is $l.WHAT.gist , '(Laptop)' , 'If we resolve the conflict we can create laptops';

role Cup[::Contents] { }
role Glass[::Contents] { }
class EggNog { }
class MulledWine { }

my Cup of EggNog $mug ;
my Glass of MulledWine $glass ;

role Tray[::ItemType] { }
my Tray of Glass of MulledWine $valuable;

is $mug.WHAT.perl , 'Cup[EggNog]' , 'the $mug is a Cup of EggNog';
is $glass.WHAT.perl , 'Glass[MulledWine]' , 'the $glass is a Glass of MulledWine';
is $valuable.WHAT.perl , 'Tray[Glass[MulledWine]]' , 'the $valuable is a Tray of Glass of MulledWine';

#?rakudo skip 'parse error'
lives_ok 'role DeliveryCalculation[::Calculator] {has $.mass;method calculate($destination) {my $calc = Calculator.new(:$!mass);}}' , 'Refering to $.mass and $!mass';

#TODO: When rakudo can pass the previous test we can add full tests for the role.
#~ role DeliveryCalculation[::Calculator] {
    #~ has $.mass;
    #~ has $.dimensions;
    #~ method calculate($destination) {
        #~ my $calc = Calculator.new(
            #~ :$!mass,
            #~ :$!dimensions
        #~ );
        #~ return $calc.delivery-to($destination);
    #~ }
#~ }

#~ class Furniture does DeliveryCalculation[ByDimension] {
#~ }
#~ class HeavyWater does DeliveryCalculation[ByMass] {
#~ }

done();
rakudo-2013.12/t/spec/integration/advent2009-day19.t0000664000175000017500000000121612224265625021237 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/19/day-19-whatever/

use v6;
use Test;

plan 6;

my @x = ;
#?pugs todo
is @x[*-2], 'd', 'Whatever indexing';
is @x.pick(*).elems, @x.elems, 'pick(*)';

{
    #?pugs skip 'Casting errors'
    is (@x.map: * ~ 'A'), ("aA", "bA", "cA", "dA", "eA"), "* ~ 'A' with map";

    my $x = * * 2;
    #?pugs skip 'Casting errors'
    is $x(4), 8, '* * 2 generates a code block';

    #?pugs skip '.succ'
    is (@x.map: *.succ), ["b", "c", "d", "e", "f"], '*.succ with map';

    my @list = 1, 5, 'a', 10, 6;
    #?pugs 2 todo
    is (@list.sort: ~*), [1, 10, 5, 6, "a"], '~* used to sort as list of strings';
}
rakudo-2013.12/t/spec/integration/advent2009-day20.t0000664000175000017500000000507212224265625021233 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/20/day-20-little-big-things/

use v6;
use Test;

plan 21;

sub foo (Int $i, @stuff, $blah = 5) { ... }   #OK not used
is &foo.name, 'foo', 'Introspecting subroutine name';

my $bar = &foo;
is $bar.name, 'foo', 'Introspecting subroutine for a sub assigned to a scalar';

is &foo.signature.perl, ':(Int $i, @stuff, $blah = { ... })', 'Introspecting and stringification of subroutine signature';

# Not sure if this is an appropriate test - as this code doesn't exist in the Advent Calendar
my @sig-info = \(name => '$i',     type => 'Int'),
               \(name => '@stuff', type => 'Positional'),
               \(name => '$blah',  type => 'Any');

for &foo.signature.params Z @sig-info -> $param, $param-info {
    is $param.name, $param-info, 'Name matches ' ~ $param-info;
    is $param.type.perl, $param-info, 'Type matches ' ~ $param-info;
}

is &foo.count, 3, 'Introspecting number of arguments';
is &foo.arity, 2, 'Introspecting arity, i.e. number of required arguments';

eval_lives_ok 'map -> $x, $y { ... }, 1..6', 'mapping two at a time';
eval_lives_ok 'map -> $x, $y, $z { ... }, 1..6', 'mapping three at a time';

class Person {
    has $.name;
    has $.karma;

    method Str { return "$.name ($.karma)" }  # for pretty stringy output
}

my @names = ;

my @people = map { Person.new(name => $_, karma => (rand * 20).Int) }, @names;
is @people.elems, @names.elems, 'List of people objects is the same length of names';

my @a = @people.sort: { $^a.karma <=> $^b.karma };
my @b = @people.sort: { $^a.karma };
is @a, @b, 'Can use two placeholders, or just one and get an equivalent free Schwartzian Transform';

@b = @people.sort: { .karma };
is @a, @b, 'Can eliminate the auto-declared placeholder, and sorting is still equivalent';

is @b, (@people.sort: { +.karma }), 'Sort explicitly numerically';
# TODO - need another test to explicitly test correct numerical sorting
ok ([<=] @b>>.karma), 'proper numeric sorting';

# numerical sort isn't always the same as stringy sorting, so
# this test randomly fails.
# isnt @b, (@people.sort: { ~.karma }), "Sort numerically is different to stringily";

{
    is @b, (@people.sort: *.karma), 'Using a Whatever to sort numerically (be default)';
    is (@people.min: { +.karma }), (@people.min: +*.karma), 'Explicit numeric comparison is equivalent to numeric comparison with a Whatever';
    is (@people.max: { ~.name }), (@people.max: ~*.name), 'Explicit string comparison is equivalent to a string comparison with a Whatever';
}

done;
rakudo-2013.12/t/spec/integration/advent2009-day21.t0000664000175000017500000000013612224265625021230 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/21/day-21-grammars-and-actions/

use v6;
use Test;
rakudo-2013.12/t/spec/integration/advent2009-day22.t0000664000175000017500000000175112224265625021235 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/22/day-22-operator-overloading/

use v6;
use Test;

plan 4;

multi sub postfix:(Int $n) {
    [*] 1..$n;
}

is 3!, 6, 'factorial operator';

class PieceOfString {
    has $.length;
}

## This example seems odd. Why is it passing 2 args to :length in the .new call?
multi sub infix:<+>(PieceOfString $lhs, PieceOfString $rhs) {
    PieceOfString.new(:length($lhs.length, $rhs.length));
}

my $a = PieceOfString.new(:length(4));
my $b = PieceOfString.new(:length(6));

my $c = $a + $b;
is $c.length, (4,6), "+ override";

multi sub infix:<==>(PieceOfString $lhs, PieceOfString $rhs --> Bool) {
    $lhs.length == $rhs.length;
}

my $d = PieceOfString.new(:length(6));
#?niecza skip 'No candidates for dispatch to &infix:<==>'
ok $b == $d, "override equality";

# XXX This pragma was NOT used in the advent calendar.
use MONKEY_TYPING;

augment class PieceOfString {
    method Str {
        '-' x $.length;
    }
}

is ~$d, '------', 'Str override';

done;
rakudo-2013.12/t/spec/integration/advent2009-day23.t0000664000175000017500000000562412224265625021241 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/23/day-23-lazy-fruits-from-the-gather-of-eden/

use v6;
use Test;

plan 4;

my @gather-result = gather { take $_ for 5..7 };

my @push-result;
push @push-result, $_ for 5..7;

is @gather-result, @push-result, 'Gather/task and push building the same list';

sub incremental-concat(@list) {
    my $string-accumulator = "";
    gather for @list {
    # RAKUDO: The ~() is a workaround for [perl #62178]
        take ~($string-accumulator ~= $_);
    }
};

is incremental-concat(), ["a", "ab", "abc"], 'String accumulator';

class Tree {
    has Tree $.left;
    has Tree $.right;
    has Str $.node;
}

sub transform(Tree $t) {
    $t.node();
}

sub traverse-tree-inorder(Tree $t) {
  traverse-tree-inorder($t.left) if $t.left;
  take transform($t);
  traverse-tree-inorder($t.right) if $t.right;
}

my $tree = Tree.new(
                node => 'a',
                left => Tree.new(
                    node => 'b',
                    left => Tree.new(
                        node => 'c'
                    ),
                    right => Tree.new(
                        node => 'd'
                    )
                ),
                right => Tree.new(
                    node => 'e'
                )
           );
my @all-nodes = gather traverse-tree-inorder($tree);

is @all-nodes, ["c", "b", "d", "a", "e"], 'In order tree traversal with gather/take';

#?rakudo skip "lists aren't properly lazy in Rakudo yet"
#?niecza skip 'hangs'
{
    my @natural-numbers = 0 .. Inf;
    my @even-numbers  = 0, 2 ... *;    # arithmetic seq
    my @odd-numbers   = 1, 3 ... *;
    my @powers-of-two = 1, 2, 4 ... *; # geometric seq

    my @squares-of-odd-numbers = map { $_ * $_ }, @odd-numbers;

    sub enumerate-positive-rationals() { # with duplicates, but still
      take 1;
      for 1..Inf -> $total {
        for 1..^$total Z reverse(1..^$total) -> $numerator, $denominator {
          take $numerator / $denominator;
        }
      }
    }

    sub enumerate-all-rationals() {
      map { $_, -$_ }, enumerate-positive-rationals();
    }

    # TODO - we need a test for enumerate-all-rationals

    sub fibonacci() {
      gather {
        take 0;
        my ($last, $this) = 0, 1;
        loop { # infinitely!
          take $this;
          ($last, $this) = $this, $last + $this;
        }
      }
    }

    is fibonacci[10], 55, 'Lazy implementation of fibonacci with gather/take';
}

sub merge(@a, @b) {
  !@a && !@b ?? () !!
  !@a        ?? @b !!
         !@b ?? @a !!
  (@a[0] < @b[0] ?? @a.shift !! @b.shift, merge(@a, @b))
}

sub hamming-sequence() { # 2**a * 3**b * 5**c, where { all(a,b,c) >= 0 }
  gather {
    take 1;
    take $_ for
        merge( (map { 2 * $_ }, hamming-sequence()),
               merge( (map { 3 * $_ }, hamming-sequence()),
                      (map { 5 * $_ }, hamming-sequence()) ));
  }
}

# TODO - we need some tests for merge and hamming problem above

done;
rakudo-2013.12/t/spec/integration/advent2009-day24.t0000664000175000017500000000014512224265625021233 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2009/12/24/day-24-the-perl-6-standard-grammar/

use v6;
use Test;
rakudo-2013.12/t/spec/integration/advent2010-day04.t0000664000175000017500000000354012224265625021223 0ustar  moritzmoritz# http://perl6advent.wordpress.com/2010/12/04/the-sequence-operator/

use v6;
use Test;
plan 11;

{
    my @even-numbers  := 0, 2 ... *;    # arithmetic seq
    is @even-numbers[^10].join(" "), "0 2 4 6 8 10 12 14 16 18", "First ten even numbers are correct";
    my @odd-numbers   := 1, 3 ... *;
    is @odd-numbers[^10].join(" "), "1 3 5 7 9 11 13 15 17 19", "First ten odd numbers are correct";
    my @powers-of-two := 1, 2, 4 ... *; # geometric seq
    is @powers-of-two[^10].join(" "), "1 2 4 8 16 32 64 128 256 512", "First ten powers of two are correct";
}

{
    my @Fibonacci := 0, 1, -> $a, $b { $a + $b } ... *;
    is @Fibonacci[^10].join(" "), "0 1 1 2 3 5 8 13 21 34", "First ten Fibonacci numbers are correct";
}

{
    is (1, 1.1 ... 2).join(" "), "1 1.1 1.2 1.3 1.4 1.5 1.6 1.7 1.8 1.9 2", "1, 1.1 ... 2 is correct";
    is (1, 1.1 ... 2.01)[^14].join(" "), "1 1.1 1.2 1.3 1.4 1.5 1.6 1.7 1.8 1.9 2 2.1 2.2 2.3", 
                                         "1, 1.1 ... 2.01 is correct";
}

{
    is (0, 1, -> $a, $b { $a + $b } ... -> $a { $a > 10000 }).join(" "), 
       "0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946",
       "Fibonacci bounded (...) is correct";
    is (0, 1, -> $a, $b { $a + $b } ...^ -> $a { $a > 10000 }).join(" "), 
       "0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765",
       "Fibonacci bounded (...^) is correct";
    is (0, 1, * + * ...^ * > 10000).join(" "), 
       "0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765",
       "Fibonacci bounded (...^) is correct";
}

{
    my @Fibonacci := 0, 1, * + * ... *;
    is (@Fibonacci ...^ * > 10000).join(" "),
       "0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765",
       "Fibonacci bounded after the fact is correct";
    is @Fibonacci[30], 832040, 'And @Fibonacci is still unbounded';
}

done();
rakudo-2013.12/t/spec/integration/class-name-and-attribute-conflict.t0000664000175000017500000000767012224265625025113 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

The parser won't do right thing when two(or more) class-es get
attributes whose name are the same.

hmm, It's conflicted with class name and attribute name.

***** These two examples below will fail to parse. *****

##### this example below will cause pugs hang.
class a {has $.a; method update { $.a; } }; class b { has $.a; submethod BUILD { a.new( a => $.a ).update; } };class c { has $.b; submethod BUILD { b.new( a => $.b ); } };c.new( b => 30 );

##### this example will say sub isn't found.
class a { has $.a; method update { $.a; } };class b { has $.a; submethod BUILD { a.new( a => $.a ).update; }; }; b.new( a => 20 );

Problems with this test:
* The classes "a", "b", and "c" are redefined several times.
  { class Foo {...} }; say Foo.new;
  # works, even though Foo was declared in a different lexical scope
  Proposal: Change the class names to "a1", "b1", "a2", "b2", etc.

* This also causes some infloops, as some classes' BUILD call itself
  (indirectly) (this is a consequence of the first problem).

* *Most importantly*: Because the classes are redefined -- especially because
  .update is redefined -- only the $var of subtest #3 gets updated, *not* the
  $var of subtest #1 or #2!

  { my $var; class Foo { method update { $var = 42 }; Foo.new.update; say $var }
  { my $var; class Foo { method update { $var = 42 } }
  # This will output "" instead of "42", as the $var of the second scope is
  # changed, not the $var of the first line.
  # &Foo::update changes the $var of its scope. This $var is not the $var of
  # the first line.

  I see to solutions to this problem:

  * Write "my class" instead of "class" -- but lexical classes are not yet
    implemented.
  * Change the class names -- there may only be one class "a", one class "b",
    etc. in the file. (Note again that {} scopes don't have an effect on global
    (OUR::) classes).

  [A similar example:
    { my $var; sub update { $var = 42 }; update(); say $var }
    { my $var; sub update { $var = 42 } }
    # This outputs "".

    { my $var; my sub update { $var = 42 }; update(); say $var }
    { my $var; my sub update { $var = 42 } }
    # This outputs "42".]

* The last subtest calls c.new(...).update, but there is no &c::update and c
  doesn't inherit from a class providing an "update" method, either.

=end pod

plan 3;


{
    my $var = 100;
    # XXX This definition doesn't have any effect, as it is overridden by the
    # definition at the end of this file. This $var is not captured.
    # All calls to &a::update will really call the &a::update as defined by
    # subtest #3, which will update the $var of subtest #3's scope (not this
    # $var).
    class a {
        has $.a;
        has $.c;
        method update { $var -= $.a; }
    };
    a.new( a => 10 ).update;
    is $var, 90, "Testing suite 1.";
}



{
    my $var = 100;
    # XXX This definition doesn't have any effect, as it is overridden by the
    # definition at the end of this file. This $var is not captured.
    # All calls to &a::update will really call the &a::update as defined by
    # subtest #3, which will update the $var of subtest #3's scope (not this
    # $var).
    class _a {
        has $._a;
        method update { $var -= $._a; }
    };
    class _b {
        has $._a;
        submethod BUILD { _a.new( _a => $!_a ).update; };
    };

    _b.new( _a => 20 );
    is $var, 80, "Testing suite 2.";
}


#?pugs skip 'No such method in class Ac: "&update"'
{
    my $var = 100;
    # XXX This definition *does* have an effect. This $var *is* captured.
    # All calls to &a::update will update this $var, not the $var of subtest #1
    # or #2.
    class Aa {
        has $.Aa;
        method update { $var -= $.Aa; }
    };
    class Ab {
        has $.Aa;
        submethod BUILD { Aa.new( Aa => $!Aa ); }
    };
    class Ac {
        has $.Ab;
        submethod BUILD { Ab.new( Aa => $!Ab ); }
    };

    Ac.new( Ab => 30 ).update;
    is $var, 70, "Testing suite 3.";
}


# vim: ft=perl6
rakudo-2013.12/t/spec/integration/code-blocks-as-sub-args.t0000664000175000017500000000126212224265625023026 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

=begin desc

Test a bug where sub args of type Sub do not get handled correctly.

=end desc

sub foo (Sub $code, Str $a, Str $b) { return $a.WHAT }   #OK not used

#?pugs todo
dies_ok  {foo(-> { die "test"   }, "a", "b")}, 'pointy block is not a sub';
lives_ok {foo( sub { die "test" }, 'a', 'b')}, 'anonymous sub as argument not executed';

sub foo2 (Sub $code, Str $a, Str $b?) { return $a.WHAT }   #OK not used

#?pugs todo
dies_ok  {foo2(-> { die "test"   }, "a", "b")}, 'pointy block is not a sub (with optional last arg)';
lives_ok {foo2( sub { die "test" }, 'a', 'b')}, 'anonymous sub as argument not executed (with optional last arg)';

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/error-reporting.t0000664000175000017500000000654312224265625021666 0ustar  moritzmoritzuse v6;
use Test;

plan 16;

BEGIN { @*INC.push('t/spec/packages') };

use Test::Util;

is_run "use v6;\n'a' =~ /foo/", {
    status  => { $_ != 0 },
    out     => '',
    err     => rx/<<2>>/
}, 'Parse error contains line number';

#?rakudo.jvm todo "nigh"
is_run "my \$x = 2 * 3;\ndie \$x", {
    status  => { $_ != 0 },
    out     => '',
    err     => all(rx/6/, rx/<<2>>/),
}, 'Runtime error contains line number';

#?rakudo.jvm todo "nigh"
is_run "use v6;\n\nsay 'Hello';\nsay 'a'.my_non_existent_method_6R5();",
    {
        status  => { $_ != 0 },
        out     => /Hello\r?\n/,
        err     => all(rx/my_non_existent_method_6R5/, rx/<<4>>/),
    }, 'Method not found error mentions method name and line number';

# RT #75446
is_run 'use v6;
sub bar {
    pfff();
}

bar()',
    {
        status => { $_ != 0 },
        out     => '',
        err     => all(rx/pfff/, rx/<<3>>/),
    }, 'got the right line number for nonexisting sub inside another sub';

is_run 'say 42; nosuchsub()',
    {
        status  => { $_ != 0 },
        out     => '',
        err     => rx/nosuchsub/,
    },
    'non-existing subroutine is caught before run time';

# RT #74348
{
    subset Even of Int where { $_ %% 2 };
    sub f(Even $x) { $x };
    try { eval 'f(3)' };
    my $e = "$!";
    diag "Error message: $e";
    ok $e ~~ /:i 'type check'/,
        'subset type check fail mentions type check';
    ok $e ~~ /:i constraint/,
        'subset type check fail mentions constraint';
}

# RT #76112
#?rakudo.jvm todo "nigh"
is_run 'use v6;
class A { has $.x is rw };
A.new.x(42);',
    {
        status => { $_ != 0 },
        out     => '',
        err     => rx/<<3>>/,
    }, 'got the right line number for accessors';

# RT #80982
is_run 'say 0080982',
    {
        status => 0,
        out => "80982\n",
        err => rx/ octal /,
    }, 'use of leading zero causes warning about octal';

# RT #76986
#?niecza todo
is_run 'my $ = 2; my $ = 3; say q[alive]',
    {
        status  => 0,
        err     => '',
        out     => "alive\n",
    }, 'multiple anonymous variables do not warn or err out';

# RT #112724
#?rakudo.jvm todo "nigh"
is_run 'sub mysub {
        + Any # trigger an uninitialized warning
    };
    mysub()',
    {
        status  => 0,
        err     => /<<2>>/ & /<>/,
        out     => '',
    }, 'warning reports correct line number and subroutine';

# RT #77736
#?niecza todo
is_run 'die "foo"; END { say "end run" }',
    {
        status => * != 0,
        err    => rx/foo/,
        out    => "end run\n",
    },
    'END phasers are run after die()';

# RT #113848
{
    try eval '          # line 1
        use v6;         # line 2
        (1 + 2) = 3;    # line 3
        ';

    #?niecza skip "Unable to resolve method backtrace in type Str"
    ok ?( $!.backtrace.any.line == 3),
        'correct line number reported for assignment to non-variable';
}

# RT #103034
#?niecza skip 'sub ucfirst($thing) is export(:DEFAULT) blows up'
#?DOES 3
{
    use lib 't/spec/packages';
    use Foo;
    try dies();
    ok $!, 'RT 103034 -- died';
    my $bt = $!.backtrace;
    #?rakudo.jvm todo "nigh"
    ok any($bt>>.file) ~~ /Foo\.pm/, 'found original file name in the backtrace';
    # note that fudging can change the file extension, so don't check
    # for .t here
    ok any($bt>>.file) ~~ /'error-reporting'\./, 'found script file name in the backtrace';

}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/lazy-bentley-generator.t0000664000175000017500000000102712224265625023121 0ustar  moritzmoritzuse Test;

plan 1;

sub bentley_clever($seed) {
    constant $mod = 1_000_000_000;

    my @state;

    my @seed = ($seed % $mod, 1, (* - *) % $mod ... *)[^55];
    @state = @seed[ 34, (* + 34 ) % 55 ... 0 ];

    subrand() for 55 .. 219;

    sub subrand() {
        push @state, (my $x = (@state.shift - @state[*-24]) % $mod);
        $x;
    }

    &subrand ... *;
}

my @sr := bentley_clever(292929);
is @sr[^6].join('|'),
   '467478574|512932792|539453717|20349702|615542081|378707948',
   'can do funny things with lazy series';
rakudo-2013.12/t/spec/integration/lexical-array-in-inner-block.t0000664000175000017500000000033212224265625024056 0ustar  moritzmoritzuse v6;


use Test;

plan 2;

sub f($n)
{
    my $a = [$n];

    {
        is($a[0], $n, "Testing for a lexical variable inside a block.")
    }
}

my $n;
for 2..3 -> $n {
    # TEST*2
    f($n);
}




# vim: ft=perl6
rakudo-2013.12/t/spec/integration/lexicals-and-attributes.t0000664000175000017500000000166112224265625023252 0ustar  moritzmoritzuse v6;
use Test;

plan 8;

# this was an issue with rakudo that some some assignment
# to attributes worked more like binding:
# http://rt.perl.org/rt3//Public/Bug/Display.html?id=58818

class Foo {
    has $.a is rw;
    has $.b is rw;
    method clone_Foo {
        my $newval = self.b;
        return self.new(a => self.a, b => $newval);
    }
};

my $first = Foo.new(a => 1, b => 2);
is $first.a, 1, 'Initialization worked (1)';
is $first.b, 2, 'Initialization worked (2)';

my $second = $first.clone_Foo;
is $second.a, 1, 'Initialization of clone worked (1)';
is $second.b, 2, 'Initialization of clone worked (2)';

$second.a = 4;
$second.b = 8;

is $second.a, 4, 'assignment to attributes in clone worked (1)';
is $second.b, 8, 'assignment to attributes in clone worked (2)';

is $first.a, 1, 'assignment to clone left original copy unchanged (1)';
is $first.b, 2, 'assignment to clone left original copy unchanged (2)';

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/man-or-boy.t0000664000175000017500000000153512224265625020502 0ustar  moritzmoritzuse 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
rakudo-2013.12/t/spec/integration/method-calls-and-instantiation.t0000664000175000017500000000237012224265625024516 0ustar  moritzmoritzuse v6;

use Test;

plan 2;

# The difference between test1 and test2 is that "my $var = Bar.new"
# is basically "my Any $var = Bar.new", so the Scalar container knows no
# constraint, and will not attempt to do any validation.
# "my Bar $var .= new" on the other hand, is really "my Bar $var = $var.new",
# so Bar acts both as the initial value of $var, and as the constraint that
# the variable($var) Scalar object holds on.

# The reason why the second test fails on Pugs <= 6.2.12, is because
# the pad does not really carry its constraint so when a closure is entered
# for the next time (method is called again) $var is refreshed into undef,
# instead of into its principal constraint class (Bar).
# The switch to the new P6AST fixes this issue.
# -- based on audreyt's explanation on #perl6.

class Bar {
	method value { "1" }
}

class Foo {
	method test1 {
		my $var = Bar.new;
		return $var.value;
	}
	method test2 {
		my Bar $var .= new;
		return $var.value;
	}
}

my Foo $baz .= new;
lives_ok { $baz.test1; $baz.test1 },
"Multiple method calls can be made in the same instance, to the same method. (1)";
my Foo $bar .= new;
lives_ok { $bar.test2; $bar.test2 },
"Multiple method calls can be made in the same instance, to the same method. (2)";

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/no-indirect-new.t0000664000175000017500000000106312224265625021520 0ustar  moritzmoritzuse v6;

use Test;

plan 2;

# Parsing test, so should use eval to ensure it can run even if something is
# broken.

#?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 }

{
    class A { has $.b }
   
    #?pugs todo
    eval_dies_ok "new A", 'parameterless prefixed new is allowed';

    eval_dies_ok( "new A( :b('bulbous bouffant') )", 'what looks like a constructor call is really a coersion to A, and should therefore be disallowed' );
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/packages.t0000664000175000017500000000104312224265625020272 0ustar  moritzmoritzuse v6;
use Test;

# test odd things we've seen with modules, packages and namespaces


# the module declaration is executed at compile time,
# so we need to plan early
BEGIN { plan 3 };

module A {
    if 1 {
        ok 1, '"if" inside a module works';
    } else {
        ok 0, '"if" inside a module works';
    }

    my $x = 0;
    for  {
        $x++;
    }
    is $x, 3, 'for loop inside a module works';

    sub b { 42 };
    is eval('b'), 42,
       'eval inside a module looks up subs in the right namespace';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/pair-in-array.t0000664000175000017500000000076112224265625021175 0ustar  moritzmoritzuse v6;

use Test;

plan 3;

# A list of pairs seems to be a list of pairs but a list of a
# single pair seems to be a a list of the pair's .key, .value

my @p1 = (1=>'a');
my @p2 = 1=>'a', 1=>'b';
my @p3 = 1=>'a', 42;

sub catWhat (*@a) { [~] map -> $v { WHAT($v).gist }, @a; }

is catWhat(@p1), '(Pair)', 'array of single Pair holds a Pair';
is catWhat(@p2), '(Pair)(Pair)', 'array of Pairs holds Pairs';
is catWhat(@p3), '(Pair)(Int)', 'array of Pair and others holds a Pair';

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/passing-pair-class-to-sub.t0000664000175000017500000000110212224265625023417 0ustar  moritzmoritzuse v6;
use Test;

# L
# There ought to be a better reference for this.
# And this test is also a candidate to be moved with other subroutine tests.


plan 2;

# this used to be a pugs regression
{
    my sub foo ($x) { $x.perl }

    my $pair = (a => 1);
    my $Pair = $pair.WHAT;

    lives_ok { foo($Pair) }, "passing ::Pair to a sub works";
}

# But this works:
{
    my sub foo ($x) { $x.perl }

    my $int = 42;
    my $Int = $int.WHAT;

    lives_ok { foo($Int) }, "passing ::Int to a sub works";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/real-strings.t0000664000175000017500000000544412224265625021137 0ustar  moritzmoritzuse v6;
use Test;
plan 21;

# Rakudo had a regression that
# string returned from regexes were Parrot strings, not Perl 6 strings.
# Basic stuff like interpolation and .uc, .lc still worked, but other things
# did not. We test it here by calling .trans on the string, which dies
# because parrot's .trans has a different calling syntax

{
    my $x = 'a';
    is $x.trans(['a'] => ['b']), 'b', 
       'basic sanity: .trans works with native Perl 6 strings';
}

{
    my $x = 'abc'.split(/b/).[0];
    lives_ok {$x.trans(['a'] => ['b']) }, 
       'Still works with strings returned from split() (lives)';
    #?pugs todo
    is $x.trans(['a'] => ['b']), 'b',
       'Still works with strings returned from split() (result)';
    $x = 'abc'.split('b').[0];
    is $x.trans(['a'] => ['b']), 'b', 'same for split(Str)';
}

dies_ok { for "a b c".split(/\s/) -> $foo { $foo = $foo; } }, 'variables returned from split and passed to pointy block are still ro';

# used to be RT #55962

#?niecza todo 'Suspect test'
{
    my @foo = 'AB'.split('');
    @foo[0]++;
    is ~@foo, 'B B', 'Str.split(Str) works with postfix:<++>';
}

#?pugs todo 'Str'
ok 1.Str ~~ / ^ 1 $ /, 'RT 66366; 1.Str is a "good" Str';

is "helo".flip().trans("aeiou" => "AEIOU"), 'OlEh', '.flip.trans (RT 66300)';
is "helo".flip.trans(("aeiou" => "AEIOU")), 'OlEh', '.flip.trans (RT 66300)';
is "helo".lc.trans(("aeiou" => "AEIOU")),   'hElO', '.flip.trans (RT 66300)';
is .join.trans, 'helo', 'join returns P6 strings (RT 76564, RT 71088)';
is "helo".substr(0,3).trans, 'hel', 'substr returns P6 strings (RT 76564, RT 71088)';


# http://rt.perl.org/rt3/Ticket/Display.html?id=66596
# .subst within a multi sub didn't work
#?pugs todo
{
    multi substtest (Str $d) {
        $d.subst(/o/, 'a')
    }
    is substtest("mop"), "map", '.subst works in a multi';
}

# not a "real string', but a "real hash" bug found in Rakudo:

{
    my $x = 0;
    for $*VM.kv -> $k, $v { $x++};
    is $x, +$*VM.keys, '$*VM.kv is self-consistent';
}

# RT #67852
{
    lives_ok { 'normal'.trans() }, 'can .trans() on normal string';
    #?niecza todo 'Buffer bitops NYI' 
    lives_ok { ('bit' ~& 'wise').trans() }, 'can .trans() on bitwise result';
}

# RT #75456 hilarity
#?pugs todo
{
    ok ('1 ' ~~ /.+/) && $/ eq '1 ', 'matching sanity';
    ok +$/ == 1, 'numification of match objects with trailing whitespaces';

}

{
    my $x = 'this is a test'.chomp;
    lives_ok {$x.trans(['t'] => ['T']) }, 
       'Still works with strings returned from chomp() (lives)';
    is $x.trans(['t'] => ['T']), 'This is a TesT',
       'Still works with strings returned from chomp() (result)';
}

{
    my $contents = slurp 't/spec/integration/real-strings.t';
    lives_ok {$contents.trans(['t'] => ['T']) }, 
       'Still works with strings returned from slurp() (lives)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/role-composition-vs-attribute.t0000664000175000017500000000366412253134031024444 0ustar  moritzmoritzuse v6;

use Test;

plan 10;

{
    role B { method x { 3; } }

    class T does B { }

    class S does B {
        has $.t is rw;
        method x { $.t.x }
        submethod BUILD(*@_) { $!t = T.new }
    }

    is S.new.x, 3, "Test class inherited from the same role caused infinite loop bug";
}

{
    role A {
        has Int $!a;
    }
    class Foo does A {
        method foo { $!a++ }
    }
    my $foo = Foo.new;
    is $foo.foo, 0, 'did we see the Int private attribute from the role';
    is $foo.foo, 1, 'did we update the Int private attribute from the role';
}

#?rakudo skip 'alas, no visibility of native private attributes yet'
{
    role C {
        has int $!c;
    }
    class Bar does A {
        method bar { $!c++ }
    }
    my $bar = Bar.new;
    is $bar.bar, 0, 'did we see the int private attribute from the role';
    is $bar.bar, 1, 'did we update the int private attribute from the role';
}

{
    role AA {
        has Int $!aa;
        method bar { $!aa++ }
    }
    role BB does AA {}
    class Baz does BB {
        method baz { $!aa++ }
    }
    my $baz = Baz.new;
    is $baz.bar, 0, 'did we see the Int private attribute from the embedded role';
    is $baz.baz, 1, 'did we update the Int private attribute from the embedded role';
}

#?rakudo skip 'alas, no visibility of private attributes in other role'
{
    role AAA {
        has Int $!aaa;
    }
    role BBB does AAA {
        method zap { $!aaa++ }
    }
    class Zap does BBB { }
    my $zap = Zap.new;
    is $zap.zap, 0, 'did we see the private attribute from the embedded role';
    is $zap.zap, 1, 'did we update the private attribute from the embedded role';
}

{
    role AAAA {
        has Int $!aaaa;
    }
    dies_ok { eval q:to/CODE/ }, 'unknown attribute dies at compile time';
    class Zop does AAAA {
        method zippo { $!zzzz++ }  # first time
        method zappo { $!zzzz++ }  # second time, without $/ internally
    }
    CODE
}

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/rule-in-class-Str.t0000664000175000017500000000142112224265625021740 0ustar  moritzmoritzuse v6;

use MONKEY_TYPING;

use Test;

plan 3;

=begin kwid

Difficulty using a rule in a method of Str.

=end kwid

class C is Str {
    method meth1 () {
        if ("bar" ~~ m:P5/[^a]/) {
            "worked";
        } else {
            "didnt";
        }
    }
}

is(C.new.meth1(),"worked",'m:P5/[^a]/ in method in C (is Str)');

augment class Str {
    method meth2 () {
        if ("bar" ~~ m:P5/[^a]/) {
            "worked";
        } else {
            "didnt";
        }
    }
}

is(Str.new.meth2(),"worked",'m:P5/[^a]/ in method in Str');

augment class Str {
    method meth3 () {
        if ("bar" ~~ m:P5/[a]/) {
            "worked";
        } else {
            "didnt";
        }
    }
}

is(Str.new.meth3(),"worked",'m:P5/[a]/ in method in Str');

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/say-crash.t0000664000175000017500000000130412224265625020406 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# Printing a big string caused a stack overflow in pugs.
#
# On my system, this happens with 2**20 length strings but
# not 2*19.
#
# We don't want to print this to stdout, so we use a temporary file.
# Luckily (and bizarrely) the exception is catchable, so cleanup should
# be possible.

my $filename = "tmpfile.txt";
my $fh = open $filename, :w;

ok $fh, "temp file created successfully";

lives_ok {
        $fh.say: "a" x (2**19);
    }, "2**19 char string prints"; # works, on my system

lives_ok {
        $fh.say: "a" x (2**20);
    }, "2**20 char string prints"; # dies, on my system

$fh.close;

ok unlink($filename), "temp file unlinked successfully";

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/substr-after-match-in-gather-in-for.t0000664000175000017500000000074012224265625025276 0ustar  moritzmoritzuse Test;

plan 1;

lives_ok( {
    for "par 1", "par 2" -> $p {
        gather {
            my $c = $p;                 # make an rw copy
            while $c ~~ /\s/ {
                $c .= substr($/.from);  # remove everything before the ws
                while $c ~~ /^\s/ {     # ...and all ws in beginning of str
                    $c .= substr(1);
                }
            }
        }
    }
}, 'lexicals are bound the way they should, instead of horribly wrong');

rakudo-2013.12/t/spec/integration/topic_in_double_loop.t0000664000175000017500000000036512224265625022711 0ustar  moritzmoritzuse v6;
use Test;

# Test may seem weird, but Rakudo JVM fails it catastrophically at the moment.

plan 5;

for (1, 5) {
    for (2, 4) -> $k {
        ok $_ !%% 2, '$_ has a sensible value here';
    }
}

ok True, "Got here!";

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/variables-in-do.t0000664000175000017500000000036712224265625021500 0ustar  moritzmoritzuse v6;
use Test;

# Test may seem weird, but Rakudo JVM fails it catastrophically at the moment.

plan 3;

my $i = 42;
do for  -> $j {
    is $i, 42, '$i has proper value in loop';
}

is $i, 42, '$i still has proper value';

# vim: ft=perl6
rakudo-2013.12/t/spec/integration/weird-errors.t0000664000175000017500000000244412224265625021146 0ustar  moritzmoritzuse v6;
use Test;
BEGIN { @*INC.push: 't/spec/packages' };
use Test::Util;

plan 8;

# this used to segfault in rakudo
#?niecza skip 'todo'
is_run(
       'try { die 42 }; my $x = $!.WHAT; say $x',
       { status => 0, out => -> $o {  $o.chars > 2 }},
       'Can stringify $!.WHAT without segfault',
);

#?niecza skip 'todo'
is_run(
       'try { die 42; CATCH { when * { say $!.WHAT } }; };',
       { status => 0, out => -> $o { $o.chars > 2 }},
       'Can say $!.WHAT in a CATCH block',
);

is_run(
       '[].WHAT.say',
       { status => 0, out => "(Array)\n"},
       'Can [].WHAT.say',
);

# RT #70922
is_run(
    'class A { method postcircumfix:<{ }>() {} }; my &r = {;}; if 0 { if 0 { my $a #OK not used' ~
     "\n" ~ '} }',
    { status => 0, out => '', err => ''},
    'presence of postcircumfix does not lead to redeclaration warnings',
);

eval_dies_ok 'time(1, 2, 3)', 'time() with arguments dies';

# RT #76996
#?niecza todo
lives_ok { 1.^methods>>.sort }, 'can use >>.method on result of introspection';

# RT #76946
#?niecza skip 'todo'
lives_ok { Any .= (); CATCH { when X::Method::NotFound {1} } }, 'Typed, non-internal exception';

# RT #90522
{
    my $i = 0;
    sub foo {
        return if ++$i == 50;
        eval 'foo';
    }
    lives_ok { foo }, 'can recurse many times into &eval';
}
rakudo-2013.12/t/spec/LICENSE0000664000175000017500000002130612237474612015017 0ustar  moritzmoritz		       The Artistic License 2.0

	    Copyright (c) 2000-2006, The Perl Foundation.

     Everyone is permitted to copy and distribute verbatim copies
      of this license document, but changing it is not allowed.

Preamble

This license establishes the terms under which a given free software
Package may be copied, modified, distributed, and/or redistributed.
The intent is that the Copyright Holder maintains some artistic
control over the development of that Package while still keeping the
Package available as open source and free software.

You are always permitted to make arrangements wholly outside of this
license directly with the Copyright Holder of a given Package.  If the
terms of this license do not permit the full use that you propose to
make of the Package, you should contact the Copyright Holder and seek
a different licensing arrangement. 

Definitions

    "Copyright Holder" means the individual(s) or organization(s)
    named in the copyright notice for the entire Package.

    "Contributor" means any party that has contributed code or other
    material to the Package, in accordance with the Copyright Holder's
    procedures.

    "You" and "your" means any person who would like to copy,
    distribute, or modify the Package.

    "Package" means the collection of files distributed by the
    Copyright Holder, and derivatives of that collection and/or of
    those files. A given Package may consist of either the Standard
    Version, or a Modified Version.

    "Distribute" means providing a copy of the Package or making it
    accessible to anyone else, or in the case of a company or
    organization, to others outside of your company or organization.

    "Distributor Fee" means any fee that you charge for Distributing
    this Package or providing support for this Package to another
    party.  It does not mean licensing fees.

    "Standard Version" refers to the Package if it has not been
    modified, or has been modified only in ways explicitly requested
    by the Copyright Holder.

    "Modified Version" means the Package, if it has been changed, and
    such changes were not explicitly requested by the Copyright
    Holder. 

    "Original License" means this Artistic License as Distributed with
    the Standard Version of the Package, in its current version or as
    it may be modified by The Perl Foundation in the future.

    "Source" form means the source code, documentation source, and
    configuration files for the Package.

    "Compiled" form means the compiled bytecode, object code, binary,
    or any other form resulting from mechanical transformation or
    translation of the Source form.


Permission for Use and Modification Without Distribution

(1)  You are permitted to use the Standard Version and create and use
Modified Versions for any purpose without restriction, provided that
you do not Distribute the Modified Version.


Permissions for Redistribution of the Standard Version

(2)  You may Distribute verbatim copies of the Source form of the
Standard Version of this Package in any medium without restriction,
either gratis or for a Distributor Fee, provided that you duplicate
all of the original copyright notices and associated disclaimers.  At
your discretion, such verbatim copies may or may not include a
Compiled form of the Package.

(3)  You may apply any bug fixes, portability changes, and other
modifications made available from the Copyright Holder.  The resulting
Package will still be considered the Standard Version, and as such
will be subject to the Original License.


Distribution of Modified Versions of the Package as Source 

(4)  You may Distribute your Modified Version as Source (either gratis
or for a Distributor Fee, and with or without a Compiled form of the
Modified Version) provided that you clearly document how it differs
from the Standard Version, including, but not limited to, documenting
any non-standard features, executables, or modules, and provided that
you do at least ONE of the following:

    (a)  make the Modified Version available to the Copyright Holder
    of the Standard Version, under the Original License, so that the
    Copyright Holder may include your modifications in the Standard
    Version.

    (b)  ensure that installation of your Modified Version does not
    prevent the user installing or running the Standard Version. In
    addition, the Modified Version must bear a name that is different
    from the name of the Standard Version.

    (c)  allow anyone who receives a copy of the Modified Version to
    make the Source form of the Modified Version available to others
    under
		
	(i)  the Original License or

	(ii)  a license that permits the licensee to freely copy,
	modify and redistribute the Modified Version using the same
	licensing terms that apply to the copy that the licensee
	received, and requires that the Source form of the Modified
	Version, and of any works derived from it, be made freely
	available in that license fees are prohibited but Distributor
	Fees are allowed.


Distribution of Compiled Forms of the Standard Version 
or Modified Versions without the Source

(5)  You may Distribute Compiled forms of the Standard Version without
the Source, provided that you include complete instructions on how to
get the Source of the Standard Version.  Such instructions must be
valid at the time of your distribution.  If these instructions, at any
time while you are carrying out such distribution, become invalid, you
must provide new instructions on demand or cease further distribution.
If you provide valid instructions or cease distribution within thirty
days after you become aware that the instructions are invalid, then
you do not forfeit any of your rights under this license.

(6)  You may Distribute a Modified Version in Compiled form without
the Source, provided that you comply with Section 4 with respect to
the Source of the Modified Version.


Aggregating or Linking the Package 

(7)  You may aggregate the Package (either the Standard Version or
Modified Version) with other packages and Distribute the resulting
aggregation provided that you do not charge a licensing fee for the
Package.  Distributor Fees are permitted, and licensing fees for other
components in the aggregation are permitted. The terms of this license
apply to the use and Distribution of the Standard or Modified Versions
as included in the aggregation.

(8) You are permitted to link Modified and Standard Versions with
other works, to embed the Package in a larger work of your own, or to
build stand-alone binary or bytecode versions of applications that
include the Package, and Distribute the result without restriction,
provided the result does not expose a direct interface to the Package.


Items That are Not Considered Part of a Modified Version 

(9) Works (including, but not limited to, modules and scripts) that
merely extend or make use of the Package, do not, by themselves, cause
the Package to be a Modified Version.  In addition, such works are not
considered parts of the Package itself, and are not subject to the
terms of this license.


General Provisions

(10)  Any use, modification, and distribution of the Standard or
Modified Versions is governed by this Artistic License. By using,
modifying or distributing the Package, you accept this license. Do not
use, modify, or distribute the Package, if you do not accept this
license.

(11)  If your Modified Version has been derived from a Modified
Version made by someone other than you, you are nevertheless required
to ensure that your Modified Version complies with the requirements of
this license.

(12)  This license does not grant you the right to use any trademark,
service mark, tradename, or logo of the Copyright Holder.

(13)  This license includes the non-exclusive, worldwide,
free-of-charge patent license to make, have made, use, offer to sell,
sell, import and otherwise transfer the Package with respect to any
patent claims licensable by the Copyright Holder that are necessarily
infringed by the Package. If you institute patent litigation
(including a cross-claim or counterclaim) against any party alleging
that the Package constitutes direct or contributory patent
infringement, then this Artistic License to you shall terminate on the
date that such litigation is filed.

(14)  Disclaimer of Warranty:
THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
rakudo-2013.12/t/spec/packages/A/A.pm0000664000175000017500000000020112224265625016453 0ustar  moritzmoritz# used in t/spec/S11-modules/nested.t 

BEGIN { @*INC.push('t/spec/packages') };

module A::A {
    use A::B;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/A/B.pm0000664000175000017500000000013612224265625016463 0ustar  moritzmoritz# used in t/spec/S11-modules/nested.t 

module A::B;
role B { };
class D does A::B::B { };



rakudo-2013.12/t/spec/packages/A.pm0000664000175000017500000000012412224265625016277 0ustar  moritzmoritzuse v6;

BEGIN { @*INC.push('t/spec/packages') };
use B;
class A {
    has B $.x;
}
rakudo-2013.12/t/spec/packages/ArrayInit.pm0000664000175000017500000000024112224265625020021 0ustar  moritzmoritzmodule ArrayInit;

# used by t/spec/S10-packages/basic.t

sub array_init() is export {
    my @array;
    push @array, 'just one element';
    return ~@array;
}
rakudo-2013.12/t/spec/packages/Bar.pm0000664000175000017500000000007612224265625016631 0ustar  moritzmoritzuse v6;

use Foo;

class Bar is ::Foo;

method bar { "bar" }

rakudo-2013.12/t/spec/packages/B/Grammar.pm0000664000175000017500000000005612224265625017672 0ustar  moritzmoritzgrammar B::Grammar {
    token TOP { 'B' };
}
rakudo-2013.12/t/spec/packages/B.pm0000664000175000017500000000016212224265625016302 0ustar  moritzmoritzuse v6;

BEGIN { @*INC.push('t/spec/packages') };

use B::Grammar;

class B { 
    method foo { 'method foo' }
}

rakudo-2013.12/t/spec/packages/ContainsUnicode.pm0000664000175000017500000000022612224265625021207 0ustar  moritzmoritzmodule ContainsUnicode {
    sub uc-and-join(*@things, :$separator = ', ') is export {
        @things».uc.join($separator)
    }
}

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/Exportops.pm0000664000175000017500000000130312224265625020122 0ustar  moritzmoritzmodule Exportops;

sub postfix:(Int $x)      is export(:DEFAULT) { [*] 1..$x }
sub infix:($a, $b) is export(:DEFAULT) { $a ~ ".." ~ $b }

# Unicode stuff
sub prefix:<¢>($a)           is export(:DEFAULT) { "$a cent" }
sub infix:<±>($a, $b)        is export(:DEFAULT) { $a - $b .. $a + $b }

# exported multi

class NotANumber is export {
    has $.number;
}

sub infix:(NotANumber $a, NotANumber $b) is export(:DEFAULT) {
    NotANumber.new(:number($a.number + $b.number));
}

multi sub infix:<+>(NotANumber $a, NotANumber $b) is export(:DEFAULT) {
    NotANumber.new(:number($a.number + $b.number));
}

# not exported operator

sub infix:($a, $b) { $a + $b }

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/Export_PackA.pm0000664000175000017500000000014612224265625020443 0ustar  moritzmoritzuse v6;

module t::spec::packages::Export_PackA {
  our sub exported_foo () is export {
    42;
  }
}
rakudo-2013.12/t/spec/packages/Export_PackB.pm0000664000175000017500000000023612224265625020444 0ustar  moritzmoritzuse v6;

module t::spec::packages::Export_PackB {
  use t::spec::packages::Export_PackA;

  sub does_export_work () {
    try { exported_foo() } == 42;
  }
}
rakudo-2013.12/t/spec/packages/Export_PackC.pm0000664000175000017500000000013612224265625020444 0ustar  moritzmoritzuse v6;

module t::spec::packages::Export_PackC {
  sub foo_packc () is export {
    1;
  }
}
rakudo-2013.12/t/spec/packages/Export_PackD.pm0000664000175000017500000000016712224265625020451 0ustar  moritzmoritzuse v6;

module t::spec::packages::Export_PackD {
  sub this_gets_exported_lexically () is export {
    'moose!'
  }
}
rakudo-2013.12/t/spec/packages/Fancy/Utilities.pm0000664000175000017500000000076112224265625021141 0ustar  moritzmoritzmodule Fancy::Utilities {
 our sub lolgreet($who) is export(:lolcat, :greet) {
  return "O HAI " ~ uc $who;
 }
 sub nicegreet($who) is export(:greet, :DEFAULT) {
  return "Good morning, $who!"; # Always morning?
 }
 sub shortgreet is export(:greet) {
  return "Hi!";
 }
 sub lolrequest($item) is export(:lolcat) {
  return "I CAN HAZ A {uc $item}?";
 }
 sub allgreet() is export {
     'hi all';
 }
 multi sub greet(Str $who) { return "Good morning, $who!" }
 multi sub greet() { return "Hi!" }
}
rakudo-2013.12/t/spec/packages/FooBar.pm0000664000175000017500000000010612224265625017267 0ustar  moritzmoritzuse v6;

use Bar;

class FooBar is ::Bar;

method foobar { "foobar" }
rakudo-2013.12/t/spec/packages/Foo.pm0000664000175000017500000000026012224265625016643 0ustar  moritzmoritzuse v6;


class Foo;

method foo { "foo" }

sub ucfirst($thing) is export(:DEFAULT) { 'overridden ucfirst' }   #OK not used
sub dies() is export { die 'Death from class Foo' }
rakudo-2013.12/t/spec/packages/HasMain.pm0000664000175000017500000000013512224265625017441 0ustar  moritzmoritzuse v6;
module HasMain {
    sub MAIN() { die 'HasMain::Main' }
}
sub MAIN() { die 'MAIN' }

rakudo-2013.12/t/spec/packages/Import.pm0000664000175000017500000000011312224265625017367 0ustar  moritzmoritzmodule t::spec::packages::Import;
# note the absence of a sub import() { }
rakudo-2013.12/t/spec/packages/LoadCounter.pm0000664000175000017500000000023512224265625020341 0ustar  moritzmoritzuse v6;

module t::packages::LoadCounter;

$Main::loaded++;

sub import {
    $Main::imported++;
}

sub unimport {
    $Main::imported--;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/LoadFromInsideAClass.pm0000664000175000017500000000013112224265625022043 0ustar  moritzmoritzclass LoadFromInsideAClass {
    BEGIN { @*INC.push: 't/spec/packages' };
    use Foo;
}
rakudo-2013.12/t/spec/packages/LoadFromInsideAModule.pm0000664000175000017500000000013312224265625022225 0ustar  moritzmoritzmodule LoadFromInsideAModule {
    BEGIN { @*INC.push: 't/spec/packages' };
    use Foo;
}
rakudo-2013.12/t/spec/packages/OverrideTest.pm0000664000175000017500000000013012224265625020533 0ustar  moritzmoritzmodule OverrideTest {
    sub test_tc($y) is export(:DEFAULT) {
        tc($y);
    }
}
rakudo-2013.12/t/spec/packages/PackageTest.pm0000664000175000017500000000130312224265625020312 0ustar  moritzmoritz# The semicolon form of "package" would be illegal in the
# middle of a Perl 6 file.
# At the top, it would mean the rest of the file was Perl 5 code.
# So we use "package" with a block:

package t::spec::packages::PackageTest {

sub ns  { "t::spec::packages::PackageTest" }

sub pkg { $?PACKAGE }

sub test_export is export { "party island" }

sub get_our_pkg {
    Our::Package::pkg();
}

our package Our::Package {

    sub pkg { $?PACKAGE }

}

sub cant_see_pkg {
    return My::Package::pkg();
}

{
    sub my_pkg {
        return My::Package::pkg();
    }

    my package My::Package {
        sub pkg { $?PACKAGE }
    }

}

sub dummy_sub_with_params($arg1, $arg2) is export { "[$arg1] [$arg2]" }

}
rakudo-2013.12/t/spec/packages/PM6.pm60000664000175000017500000000007012224265625016607 0ustar  moritzmoritzmodule PM6 {
    sub pm6_works() is export { 42 }
   
}
rakudo-2013.12/t/spec/packages/README0000664000175000017500000000050512224265625016444 0ustar  moritzmoritzt/spec/packages/README

This directory exists to hold files tested in S10-packages so that there isn't
a hyphen in the filename of the .pm file. This way, we can just
    use t::spec::packages::Whatever;
instead of needing to quote the package name all the time, or add the proper
directory to the Perl 6 equivalent of @INC.
rakudo-2013.12/t/spec/packages/RequireAndUse1.pm0000664000175000017500000000045712224265625020725 0ustar  moritzmoritzuse v6;

# require and use return the last statement evaluated in the .pm, in this case
# 42. See thread "What do use and require evaluate to?" on p6l started by Ingo
# Blechschmidt, L<"http://www.nntp.perl.org/group/perl.perl6.language/22258">.

module t::spec::packages::RequireAndUse1 {
  23;
}

42;
rakudo-2013.12/t/spec/packages/RequireAndUse2.pm0000664000175000017500000000041112224265625020714 0ustar  moritzmoritzuse v6;

# module Foo {...} returns the Foo module object,
# see thread "What do use and require evaluate to?" on p6l started by Ingo
# Blechschmidt, L<"http://www.nntp.perl.org/group/perl.perl6.language/22258">.

module t::spec::packages::RequireAndUse2 {
  23;
}
rakudo-2013.12/t/spec/packages/RequireAndUse3.pm0000664000175000017500000000046312224265625020724 0ustar  moritzmoritzuse v6;

# "module Foo; ..." is equivalent to "module Foo {...}", so it returns the Foo
# module object, see thread "What do use and require evaluate to?" on p6l
# started by Ingo Blechschmidt,
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22258">.

module t::spec::packages::RequireAndUse3;

23;
rakudo-2013.12/t/spec/packages/RoleA.pm0000664000175000017500000000012112224265625017116 0ustar  moritzmoritzBEGIN { @*INC.push: 't/spec/packages' }
use RoleB;

role RoleA;

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/RoleB.pm0000664000175000017500000000003512224265625017123 0ustar  moritzmoritzrole RoleB;

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/S11-modules/Foo.pm0000664000175000017500000000123012224265625020653 0ustar  moritzmoritz# L

module t::spec::packages::S11-modules::Foo;
sub foo is export(:DEFAULT)          { 'Foo::foo' }  #  :DEFAULT, :ALL
sub bar is export(:DEFAULT, :others) { 'Foo::bar' }  #  :DEFAULT, :ALL, :others
sub baz is export(:MANDATORY)        { 'Foo::baz' }  #  (always exported)
sub bop is export                    { 'Foo::bop' }  #  :DEFAULT, :ALL
sub qux is export(:others)           { 'Foo::qux' }  #  :ALL, :others
multi waz() is export                { 'Foo::waz' }  #  :ALL, :DEFAULT (implicit export)
multi gaz() is export(:others)       { 'Foo::gaz1' } #  :ALL, :others
multi gaz($x) is export(:others)     { 'Foo::gaz2' } #  :ALL, :others
rakudo-2013.12/t/spec/packages/Test/Util.pm0000664000175000017500000001702212237474612017762 0ustar  moritzmoritzmodule Test::Util;

use Test;

# Tests for this testing code may be in the pugs repo under t/03-test-util/

proto sub is_run(|) is export { * }

# No input, no test name
multi sub is_run( Str $code, %expected, *%o ) {
    return is_run( $code, '', %expected, '', |%o );
}

# Has input, but not a test name
multi sub is_run( Str $code, Str $input, %expected, *%o ) {
    return is_run( $code, $input, %expected, '', |%o );
}

# No input, named
multi sub is_run( Str $code, %expected, Str $name, *%o ) {
    return is_run( $code, '', %expected, $name, |%o );
}

multi sub is_run( Str $code, Str $input, %expected, Str $name, *%o ) {
    my %got = get_out( $code, $input, |%o );

    # The test may have executed, but if so, the results couldn't be collected.
    if %got {
        return skip 1, 'test died: ' ~ %got;
    }

    my $ok = ?1;
    my $tests_aggregated = 0;
    my @diag_q;

    # We check each of the attributes and pass the test only if all are good.
    for  -> $attr {
        # Attributes not specified are not tested.
        next if !(%expected{$attr}:exists);

        my $attr_good = %got{$attr} ~~ %expected{$attr};

        # The check for this attribute failed.
        # Note why for a diag() after the test failure is reported.
        if !$attr_good {
            @diag_q.push(     "     got $attr: {%got{$attr}.perl}"      );
            if %expected{$attr} ~~ Str|Num {
                @diag_q.push( "expected $attr: {%expected{$attr}.perl}" );
            }
        }

        $ok = $ok && $attr_good;
        $tests_aggregated++;
    }

    if $tests_aggregated == 0 {
        return skip 1, 'nothing tested';
    }

    ok ?$ok, $name;
    diag $_ for @diag_q;

    return;
}

sub get_out( Str $code, Str $input?, :@args, :@compiler-args) is export {
    my $fnbase = 'getout';
    $fnbase ~= '-' ~ $*PID if defined $*PID;
    $fnbase ~= '-' ~ 1_000_000.rand.Int;

    my $clobber = sub ($a, $b) {
        my $fh = open $a, :w
            or die "Can't create '$a': $!";
        $fh.print( $b );
        $fh.close or die "close failed: $!";
    };

    my @actual_args;
    my $sep = q['];
    $sep = q["] if $*OS ~~ /:i win/;
    for @args {
        if /<['"]>/ {
            die "Command line arguments may not contain single or double quotes";
        }
        @actual_args.push: $sep ~ $_ ~ $sep;
    }

    my %out;

    try {
        $clobber( "$fnbase.in", $input );
        $clobber( "$fnbase.code", $code ) if defined $code;

        my $perl6 = $*EXECUTABLE_NAME;
        my $cmd = $perl6 ~~ m:i/niecza/ ?? "mono $perl6 " !! "$perl6 ";
        $perl6 ~~ s{^perl6} = './perl6';
        $cmd = $perl6 ~ ' ';
        $cmd ~= @compiler-args.join(' ') ~ ' ' if @compiler-args;
        $cmd ~= $fnbase ~ '.code'  if $code.defined;
        $cmd ~= " @actual_args.join(' ') < $fnbase.in > $fnbase.out 2> $fnbase.err";
        # diag("Command line: $cmd");
        %out = +shell( $cmd ) +< 8;
        %out = slurp "$fnbase.out";
        %out = slurp "$fnbase.err";

        CATCH { %out = ~$! }
    }

    # Try to delete all the temp files written.  If any survive, die.
    my @files = map { "$fnbase.$_" }, ;
    for @files -> $f {
        try unlink $f;
        if $f.IO ~~ :e {
            die "Can't unlink '$f'";
        }
    }

    return %out;
}


sub throws_like($code, $ex_type, *%matcher) is export {
    my $msg;
    if $code ~~ Callable {
        $msg = 'code dies';
        $code()
    } else {
        $msg = "'$code' died";
        eval $code;
    }
    ok 0, $msg;
    skip 'Code did not die, can not check exception', 1 + %matcher.elems;
    CATCH {
        default {
            ok 1, $msg;
            my $type_ok = $_ ~~ $ex_type;
            ok $type_ok , "right exception type ({$ex_type.^name})";
            if $type_ok {
                for %matcher.kv -> $k, $v {
                    my $got = $_."$k"();
                    my $ok = $got ~~ $v,;
                    ok $ok, ".$k matches {$v.defined ?? $v !! $v.gist}";
                    unless $ok {
                        diag "Got:      $got\n"
                            ~"Expected: $v";
                    }
                }
            } else {
                diag "Got:      {$_.WHAT.gist}\n"
                    ~"Expected: {$ex_type.gist}";
                diag "Exception message: $_.message()";
                skip 'wrong exception type', %matcher.elems;
            }
        }
    }
}

=begin pod

=head1 NAME

Test::Util - Extra utility code for testing

=head1 SYNOPSIS

  use Test;
  use Test::Util;

  is_run( 'say $*IN.lines',                            # code to run
          'GIGO',                                      # input for code
          { out => "GIGO\n", err => '', status => 0 }, # results expected
          'input comes back out' );                    # test name

=head1 DESCRIPTION

This module is for test code that would be useful
across Perl 6 implementations.

=head1 FUNCTIONS

=head2 throws_like($code, Mu $expected_type, *%matchers)

If C<$code> is C, calls it, otherwise Cs it,
and expects it thrown an exception.

If an exception is thrown, it is compared to C<$expected_type>.

Then for each key in C<%matchers>, a method of that name is called
on the resulting exception, and its return value smart-matched against
the value.

Each step is counted as a separate test; if one of the first two fails,
the rest of the tests are skipped.

=head2 is_run( Str $code, Str $input?, %wanted, Str $name? )

It runs the code given, feeding it the input given, and collects results
in the form of its stdout, stderr, and exit status.  The %wanted hash
specifies which of these to check and what to check them against.
Every item in the hash must "match" for the is_run() test to pass.
For example:

   {
       out    => "Hello world!\n",   # outputs Hello world!
       err    => '',                 # no error output
       status => 0,                  # standard successful exit
   },

Any of those items not present in the %wanted hash will not be tested
(that is, the test passes regardless of the results of those items).
For example, if 'status' is not specified, the test passes regardless
of what the code's exit status was.

Each item can be a string, a Regexp, or a Callable.  Strings must match
exactly.

A Callable is passed the result, and the test passes
if the Callable returns a true value.
For example:

  is_run( 'rand.say', { out => sub { $^a > 0 && $^a < 1 }, err => '' },
          'output of rand is between zero and one' );

=head3 Errors

If the underlying code could not be executed properly (e.g., because
temp files could not be accessed), is_run() will skip().

If the %wanted hash passed in does not contain any of the items it checks,
is_run() will skip() (but it will still execute the code not being tested).

is_run() depends on get_out(), which might die.  In that case, it dies
also (this error is not trapped).

=head2 get_out( Str $code, Str $input?, :@args )

This is what is_run() uses to do its work.  It returns a hash with the
'status', 'err', and 'out' of the code run.  In addition, if the hash
it returns has an element named 'test_died', that means it failed to
either run the code or collect the results.  Any other elements of the
hash should be disregarded.

C<:@args> can contain command line arguments passed to the program.
They may not contain quote characters, or get_out will complain loudly.

=head3 Errors

This will die if it can't clean up the temp files it uses to do its work.
All other errors should be trapped and reported via the 'test_died' item.

=end pod

# vim: ft=perl6
rakudo-2013.12/t/spec/packages/UseTest.pm0000664000175000017500000000021212224265625017511 0ustar  moritzmoritzclass Stupid::Class {
    has $.attrib is rw;
    method setter($x) { $.attrib = $x; }
    method getter { $.attrib };
}

# vim: ft=perl6
rakudo-2013.12/t/spec/README0000664000175000017500000001050012224265625014662 0ustar  moritzmoritz	The Official Perl 6 Test Suite (someday...)

This is the Official Perl 6 test suite. It evolved out of the pugs
test suite, and is now maintained in a separate repository.

Its purpose is to validate implementations that wish to be known
as a conforming Perl 6 implementation. 

Please consider this test suite to be the result
of an ongoing negotiation: since many of these tests are inspired
by seeing how the various prototype implementations are screwed up
(or even more likely, how the design of Perl 6 is screwed up), this
test suite should be considered a work in progress until one or more
of the implementations gets close to passing the entire test suite,
at which point we will freeze version 6.0 of the test suite, and any
implementation that passes it can then call itself Perl 6.

As they develop, different implementations will certainly be in
different states of readiness with respect to the test suite, so
in order for the various implementations to track their progress
independently, we've established a mechanism for "fudging" the
tests in a kind of failsoft fashion.  To pass a test officially,
an implementation must be able to run a test file unmodified, but an
implementation may (temporarily) skip tests or mark them as "todo" via
the fudging mechanism, which is implemented via the fudge preprocessor.
Individual implementations are not allowed to modify the actual test
code, but may insert line comments before each actual test (or block
of tests) that changes how those tests are to be treated for this
platform.  The fudge preprocessor pays attention only to the comments
that belong to the current platform and ignores all the rest.  If your
platform is named "humpty" then your special comment lines look like:

    #?humpty: [NUM] VERB ARGS

(The colon is optional.)

The optional NUM says how many statements or blocks to apply the
verb to.  (If not supplied, a value of 1 is assumed).  A statement
is arbitrarily defined as one or more lines starting with a test call
and ending in semicolon (with an optional comment).

VERBs include:

    skip "reason"	# skip test entirely
    eval "reason"	# eval the test because it doesn't parse yet
    try "reason"	# try the test because it throws exception
    todo "reason"	# mark "todo" because "not ok" is expected
    emit code		# insert code (such as "skip_rest();") inline

All fudged tests return an exit code of 1 by default, so the test harness
will mark it as "dubious" even if all the tests supposedly pass.

There is also the following directive which modifies the test count of
the next construct:

    #?DOES count

The count may be an expression as long as any variables referenced in
the expression are in scope at the location fudge eventually inserts a
"skip()" call.

When applied to a subsequent sub definition, registers the sub name as
doing that many tests when called.  Note, however, that any skipping
is done at the point of the call, not within the subroutine, so the count
may not refer to any parameter of the sub.

When you run the fudge preprocessor, if it decides the test needs
fudging, it returns the new fudged filename; otherwise it returns
the original filename.  (Generally you don't run "fudge" directly,
but your test harness runs the "fudgeall" program for you; see below.)
If there is already a fudged program in the directory that is newer
than the unfudged version, fudge just returns the fudged version
without regenerating it.  If the fudged version is older, it removes
it and then decides anew whether to regenerate it based on the internal
fudge comments.

The "fudgeall" program may be called to process all the needed fudging
for a particular platform:

    fudgeall humpty */*.t */*/*.t

will use the "fudge" program to translate any fudged files to a new
file where the extension is not *.t but instead is *.humpty to indicate
the platform dependency.  It also returns the fudged list of filenames
to run, where unfudged tests are just passed through unchanged as *.t.
Each test comes through as either fudged or not, but never both.
The test harness then runs the selected test files as it normally
would (it shouldn't care whether they are named *.t or *.humpty).


In cases where the current working directory makes a difference, the tests
assume that the working directory is the root of the test suite, so that the
relative path to itself is t/spec/S\d\d-$section/$filename.
rakudo-2013.12/t/spec/rosettacode/greatest_element_of_a_list.t0000664000175000017500000000116312224265625024056 0ustar  moritzmoritz# http://rosettacode.org/wiki/Greatest_element_of_a_list#Perl_6

use v6;
use Test;

plan 1;

my $rosetta-code = {

#### RC-begin
say [max] 17, 13, 50, 56, 28, 63, 62, 66, 74, 54;

say [max] 'my', 'dog', 'has', 'fleas';

sub max2 (*@a) { reduce -> $x, $y { $y after $x ?? $y !! $x }, @a }
say max2 17, 13, 50, 56, 28, 63, 62, 66, 74, 54;
#### RC-end

}

my $oldOUT = $*OUT;
my $output;
$*OUT = class {
    method print(*@args) {
        $output ~= @args.join;
    }
}

$rosetta-code.();

my $expected = "74
my
74
";

$*OUT = $oldOUT;
is($output.subst("\r", '', :g), $expected.subst("\r", '', :g), "Greatest element of a list");
rakudo-2013.12/t/spec/rosettacode/README0000664000175000017500000000044312224265625017203 0ustar  moritzmoritzContains tests from rosettacode.org

The intent is to make it easy to initially pull down sample code from
Rosetta (which typically emits output to $*OUT), and have to manually
update only the expected output.

Future updates from rosettacode should be able to be pulled down
automatically.
rakudo-2013.12/t/spec/rosettacode/sierpinski_triangle.t0000664000175000017500000000215412224265625022556 0ustar  moritzmoritz# http://rosettacode.org/wiki/Sierpinski_triangle#Perl_6

use v6;
use Test;

plan 1;

my $rosetta-code = {

#### RC-begin
sub sierpinski ($n) {
    my @down  = '*';
    my $space = ' ';
    for ^$n {
        @down = @down.map({"$space$_$space"}), @down.map({"$_ $_"});
        $space ~= $space;
    }
    return @down;
}
 
.say for sierpinski 4;
#### RC-end

}

my $oldOUT = $*OUT;
my $output;
$*OUT = class {
    method print(*@args) {
        $output ~= @args.join;
    }
}

$rosetta-code.();

my $expected = "               *               
              * *              
             *   *             
            * * * *            
           *       *           
          * *     * *          
         *   *   *   *         
        * * * * * * * *        
       *               *       
      * *             * *      
     *   *           *   *     
    * * * *         * * * *    
   *       *       *       *   
  * *     * *     * *     * *  
 *   *   *   *   *   *   *   * 
* * * * * * * * * * * * * * * *
";

$*OUT = $oldOUT;
is($output.subst("\r", '', :g), $expected.subst("\r", '', :g), "Sierpinski Triangle");
rakudo-2013.12/t/spec/S01-perl-5-integration/array.t0000664000175000017500000000352312224265625021302 0ustar  moritzmoritzuse v6;

use Test;

plan 18;

unless (try { eval("1", :lang) }) {
    skip_rest;
    exit;
}

die unless
eval(q/
package My::Array;
use strict;

sub new {
    my ($class, $ref) = @_;
    bless \$ref, $class;
}

sub array {
    my $self = shift;
    return $$self;
}

sub my_elems {
    my $self = shift;
    return scalar(@{$$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) = @_;
    push @{$$self}, $val;
}

1;
/, :lang);

my $p5ar = eval('sub { My::Array->new($_[0]) }', :lang);
my @array = (5,6,7,8);
my $p5array = $p5ar(VAR @array);

my $retarray = $p5array.array;

is($p5array.my_elems, @array.elems, 'elems');
is($p5array.my_exists(1), @array[1]:exists, 'exists');
is($p5array.my_exists(10), @array[10]:exists, 'nonexists fail');
is($p5array.fetch(3)+0, @array[3], 'fetch');

my $match = 0;
lives_ok {
    $match = ?($retarray.[3] ~~ @array[3]);
}, 'can retro fetch';
ok $match, 'retro fetch';

is(eval(q{$retarray.elems}), @array.elems, 'retro elems');
is($retarray[1]:exists, @array[1]:exists, 'retro exists');
is($retarray[10]:exists, @array[10]:exists, 'retro nonexists' );

ok(($p5array.push(9)), 'can push');

#?pugs todo 'bug'
is(0+$p5array.fetch(4), 9, 'push result via obj');
#?pugs todo 'feature'
is(@array[4], 9, 'push result via array');

#?pugs todo 'bug'
flunk("push(9) non-terminates");
#$retarray.push(9);  # this will loop

#?pugs 2 todo 'bug'
is(0+$p5array.fetch(5), 9, 'retro push result');
is(@array[5], 9, 'retro push result');

ok($p5array.store(0,3), 'can store');

is(@array[0], 3, 'store result');
is(0+$p5array.fetch(0), 3, 'store result');

# TODO: pop, shift, unshift, splice, delete

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/basic.t0000664000175000017500000000510612224265625021244 0ustar  moritzmoritzuse v6;
use Test;
plan 20;

unless (try { eval("1", :lang) }) {
    skip_rest;
    exit;
}

#?rakudo skip ':lang'
{
    my $r = eval("0", :lang);
    is($r, 0, "number");
}

#?rakudo skip ':lang'
{
    my $r = eval("2", :lang);
    is($r, 2, "number");
}

#?rakudo skip ':lang'
{
    my $r = eval('"perl6 now"', :lang);
    is($r, 'perl6 now', "string");
}

#?rakudo emit #
my $p5_dumper = eval('sub {return(wantarray ? @_ : $_[0]); }', :lang);

my %h = ( a => 1 );

#?rakudo skip ':lang'
{
    my $test = '%h.kv received as hash';
    my ($k,$v) = $p5_dumper(%h.kv);   
    is($k, 'a', $test~' (key)');
    #?pugs todo
    is($v, '1', $test~' (value)');
}

#?pugs skip 'Cannot cast into Hash'
#?rakudo skip ':lang'
{
    my $test = '\%h received as hashref';
    my %o := $p5_dumper(\%h);
    is(%o, 1, $test);

    my $ref = $p5_dumper(\%h);
    is($ref, 1, $test);
}

#?pugs skip 'Cannot cast into Hash'
#?rakudo skip 'VAR'
{
    my $test = q{ (VAR %h)received as hashref };
    my %o := $p5_dumper(VAR %h);
    is(%o, 1, $test);
}

my @a = ;
#?rakudo skip ':lang'
{
    my $test = q{ (@a) received as array };
    my @o = $p5_dumper(@a);
    is(@o[0], "b", $test);
    #?pugs todo
    is(@o[2], "d", $test);
}

#?pugs skip 'todo'
#?rakudo skip ':lang'
{
    my $test = q{ (\@a) received as arrayref };
    my $o = $p5_dumper(\@a);
    is($o[0], "b", $test);
    is($o[2], "d", $test);
}

#?pugs skip 'todo'
#?rakudo skip 'VAR'
{
    my $test = q{ (VAR @a) received as arrayref };
    my $o = $p5_dumper(VAR @a);
    is($o[0], "b", $test);
    is($o[2], "d", $test);
}

my $s = 'str';

#?rakudo skip ':lang'
{
   my $test = q{ ($s) received as scalar };
   my $o = $p5_dumper($s);
   is($o, $s, $test);
}

#?rakudo skip ':lang'
{
   my $test = q{ (\$s) received as scalarref };
   my $o = $p5_dumper(\$s);
   is($$o, $s, $test);
}

#?pugs skip 'todo'
#?rakudo skip 'VAR'
{
   my $test = q{ (VAR $s) received as scalarref };
   my $o = $p5_dumper(VAR $s);
   is($$o, $s, $test);
}

#?pugs skip 'Invalid ctx: 2'
#?rakudo skip ':lang'
{
    my $test = q{ (&p6func) Passing a Perl 6 coderef to Perl 5 };

    sub  plus_one (Int $int) { $int+1 }
    my $sub = eval('sub { my $p6_coderef = shift; $p6_coderef->(3) }', :lang);
    my $result = $sub(&plus_one);
    is($result,4,$test);
}

sub add_in_perl5 ($x, $y) {
    use v5;
    $x + $y;
}

eval_lives_ok("{use v5;}", "RT #77596 - use v5 in a block lives");

is(add_in_perl5(42, 42), 84, 'Defining subroutines with "use v5" blocks');


# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/class.t0000664000175000017500000000050212224265625021263 0ustar  moritzmoritzuse v6;

use Test;

plan(2);

unless (try { eval("1", :lang) }) {
    skip_rest;
    exit;
}

{
    lives_ok {
        eval q|
            use CGI:from;
            my $q = CGI.new;
            is $q.isa(CGI), 1, "Correct isa";
        |
        or die $!;
    }, "CLASS:from.new";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/context.t0000664000175000017500000000323712224265625021652 0ustar  moritzmoritzuse v6;
use Test;
plan 10;
my &p5_void := eval(
    'sub {
        if (defined(wantarray)) {
            $::got_void = 0;
        } else {
            $::got_void = 1;
        }
}',:lang);

p5_void(:context);
is(eval(:lang,'$::got_void'),1,":contex sets void context");
p5_void(:context);
is(eval(:lang,'$::got_void'),0,":contex dosn't set void context");
p5_void(:context);
is(eval(:lang,'$::got_void'),0,":contex dosn't sets void context");

my &p5_scalar := eval(
    'sub {
        if (not(wantarray) && defined wantarray) {
            $::got_scalar = 1;
        } else {
            $::got_scalar = 0;
        }
}',:lang);
p5_scalar(:context);
is(eval(:lang,'$::got_scalar'),1,":contex sets scalar context");
p5_scalar(:context);
is(eval(:lang,'$::got_scalar'),0,":contex dosn't set scalar context");
p5_scalar(:context);
is(eval(:lang,'$::got_scalar'),0,":contex dosn't sets scalar context");

my &p5_list := eval(
    'sub {
        if (wantarray) {
            $::got_list = 1;
        } else {
            $::got_list = 0;
        }
}',:lang);
p5_list(:context);
is(eval(:lang,'$::got_list'),1,":contex sets list context");
p5_list(:context);
is(eval(:lang,'$::got_list'),0,":contex dosn't set list context");
p5_list(:context);
is(eval(:lang,'$::got_list'),0,":contex dosn't sets list context");

my &p5_list_of_values := eval('sub {return (1,2,3,4)}',:lang);
ok(p5_list_of_values(:context) === Nil,"a p5 sub called in void context returns a Nil");


# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/eval_lex.t0000664000175000017500000000023512224265625021760 0ustar  moritzmoritzuse v6;
use Test;
plan 1;

my $self = "some text";

is ~eval(q/"self is $self"/,:lang),"self is some text","lexical inside an eval";

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/exception_handling.t0000664000175000017500000000115212224265625024022 0ustar  moritzmoritzuse v6;

use Test;


BEGIN {
plan 3;
unless (try { eval("1", :lang) }) {
    skip_rest('no perl 5 support'); exit;
}
}

use Carp:from;

my $err;
lives_ok({ try { Carp.croak() }; $err = $! }, "Perl 5 exception (die) caught");
like($err, rx:P5/Carp/, "Exception is propagated to Perl 6 land");

eval(q[
package Foo;

sub new {
	bless {}, __PACKAGE__;
}

sub error {
	my $error = Foo->new;
	die $error;
}

sub test { "1" }
], :lang);

my $foo = eval("Foo->new",:lang);
try { $foo.error };
lives_ok( {
    my $err = $!;
    $err.test;
}, "Accessing Perl5 method doesn't die");

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/hash.t0000664000175000017500000000232512224265625021106 0ustar  moritzmoritzuse v6;

use Test;

plan(5);

unless eval 'eval("1", :lang)' {
    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);

my $p5ha = eval('sub { My::Hash->new($_[0]) }', :lang);
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
rakudo-2013.12/t/spec/S01-perl-5-integration/import.t0000664000175000017500000000046212224265625021475 0ustar  moritzmoritzuse v6;

use Test;
plan 1;

=begin pod

P5 module import test

=end pod

unless (try { eval("1", :lang) }) {
    skip_rest;
    exit;
}

eval_lives_ok(q[
use Text::Wrap:from 'wrap';
is(wrap('foo', 'bar', 'baz'), 'foobaz', "import p5 module");
],"parse :from syntax");

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/method.t0000664000175000017500000000407412224265625021446 0ustar  moritzmoritzuse v6;

use Test;

plan(13);

unless (try { eval("1", :lang) }) {
    skip_rest;
    exit;
}

eval(q/
#line 16 method.t
package FooBar;
our $VERSION = '6.0';
print '';

sub new {
    bless {}, __PACKAGE__;
}

sub foo {
    return 'foo';
}

sub echo {
    my ($self, $what) = @_;
#print "==> echo got $what\n";
    return $what;
}

sub callcode {
    my ($self, $code) = @_;
#print "==> callcode got $code\n";
    return eval { $code->($self) };
}

sub asub {
    return sub { return "asub" };
}

sub submany {
    return sub { ("many", "return") };
}

sub many {
    return ("many", "return") ;
}

sub modify_array {
    my ($class, $val) = @_;
    $val->[0] = 99;
}

# takes an object and invoke me on that
sub invoke {
    my ($class, $obj) = @_;
    $obj->me ('invoking');
}

/, :lang);

{
    my $r = eval("FooBar->VERSION", :lang);
    is($r, '6.0', "class method");
}

my $obj;

{
    $obj = eval("FooBar->new", :lang);
    isa_ok($obj, 'FooBar', "blessed");
    like($obj, rx:Perl5/FooBar/, "blessed");
}

{
    is($obj.foo, 'foo', 'invoke method');
}

{
    my $r = $obj.echo("bar");
    is($r, 'bar', 'invoke method with pugs arg');
}

{
    my $r = $obj.asub;

    #?pugs todo
    isa_ok($r, 'CODE', "returning a coderef");

    is($r.(), 'asub', 'invoking p5 coderef');
    my $rr = $obj.callcode($r);
    is($rr, 'asub', 'invoke with p5 coderef');
}

#?pugs todo 
{
    my @r = $obj.many;
    is(@r.elems, 2);
}

#?pugs todo 
{
    my $r = $obj.submany;
    my @r = $r.();
    is(@r.elems, 2);
}

#?pugs skip 'Invalid ctx: 2'
{
    my $callback = { "baz" };
    my $r = $obj.callcode($callback);
    is($r, 'baz', 'invoke method with callback');
}

#?pugs skip 'Invalid ctx: 2'
{
    class Foo6 {
        method me ($class: $arg) { 'Foo6'~$arg };    #OK not used
    };
    my $obj6 = Foo6.new;
    $obj = eval("FooBar->new", :lang);
    is($obj.invoke($obj6), 'Foo6invoking', 'invoke pugs method from p5');
}

#?pugs skip 'Invalid ctx: 2'
{
    my @rw = (1, 2, 3);
    $obj.modify_array(VAR @rw);
    is(@rw[0], 99, 'modify a scalar ref');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/modify_inside_p5_p6.t0000664000175000017500000000075412224265625024022 0ustar  moritzmoritzuse v6;
use Test;
plan(2);

my $x = 'test';
my $y = 'case';
{
  use v5;
  $x .= 'ing';

  #the following code hangs pugs.
 {
    # Smoke does not complete because of this
    # Uncomment the following two lines when this is fixed
    #?pugs emit #
    use v6;
    #?pugs emit #
    $y ~= 'book';
  };
};

is $x, 'testing', "scalar modified inside perl5 block";

#?pugs todo 'nested p5/p6 embedding'
is $y, 'casebook', "scalar modified inside perl6 block inside perl5 block";

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/modify_inside_p5.t0000664000175000017500000000024412224265625023407 0ustar  moritzmoritzuse v6;
use Test;
plan(1);

my $x = 'test';
my $y = 'case';
{
  use v5;
  $x .= 'ing';
};

is $x, 'testing', "scalar modified inside perl5 block";

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/README0000664000175000017500000000006312224265625020653 0ustar  moritzmoritzThis directory features tests for Perl5 embedding.
rakudo-2013.12/t/spec/S01-perl-5-integration/return.t0000664000175000017500000000072012224265625021477 0ustar  moritzmoritzuse v6;

use Test;

plan(2);

unless (try { eval("1", :lang) }) {
    skip_rest;
    exit;
}

eval q<<<

use Digest::MD5:from ;

sub get_dmd5 {
    my $ctx = Digest::MD5.new;
    return($ctx);
}

{
    is( md5_hex('test'), '098f6bcd4621d373cade4e832627b4f6', 'perl5 function exported' );
}

{
    my $ctx = get_dmd5();
    $ctx.add('test');
    is( $ctx.hexdigest, '098f6bcd4621d373cade4e832627b4f6', 'XS return' );
}

>>>;

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/roundtrip.t0000664000175000017500000000202212224265625022203 0ustar  moritzmoritzuse v6;

use Test;

plan(5);

unless eval 'eval("1", :lang)' {
    skip_rest;
    exit;
}

eval(q/
package Id;
sub new {
    my ($class, $ref) = @_;
    bless \$ref, $class;
}
sub identity {
    my $self = shift;
    return $$self;
}
/, :lang);

my $japh    = { "Just another $_ hacker" };
my $japh2   = -> $name { "Just another $name hacker" };
my $id      = eval('sub { Id->new($_[0]) }', :lang);

#?pugs 2 todo
is($id($japh).identity('Pugs'), 'Just another Pugs hacker', "Closure roundtrips");
is($id($japh2).identity('Pugs'), 'Just another Pugs hacker', "Closure roundtrips");

my $keys_p5 = eval('sub {keys %{$_[0]}}', :lang);
my $tohash_p5 = eval('sub { return {map {$_ => 1} @_ } }', :lang);
my %hash = (foo => 'bar', hate => 'software');
{
    my $foo = $tohash_p5.(keys %hash);
    cmp_ok($foo, &infix:, %hash);
    is_deeply([$foo.keys].sort, [%hash.keys].sort);
}

#?niecza skip 'VAR undeclared'
#?pugs todo
{
    is_deeply([%hash.keys].sort, [$keys_p5(VAR %hash)].sort);
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S01-perl-5-integration/strings.t0000664000175000017500000000144112224265625021652 0ustar  moritzmoritzuse Test;

plan 6;

is(eval("'Yet Another Perl Hacker'",:lang),"Yet Another Perl Hacker");
is(eval('"Yet Ano\0ther P\0erl Hacker"',:lang),"Yet Ano\0ther P\0erl Hacker","Null Bytes in the middle of a converted string");
is(eval('use utf8;"ąęóśćż"',:lang),"ąęóśćż","utf8 in literals");


my &test1 := eval('sub {$_[0] eq "Yet Another Perl Hacker"}',:lang);

my &test2 := eval('sub {$_[0] eq "Yet Ano\0ther P\0erl Hacker"}',:lang);
my &test3 := eval('sub {$_[0] eq "\x{105}\x{119}\x{f3}\x{15b}\x{107}\x{17c}"}',:lang);

ok(test1("Yet Another Perl Hacker"),"Passing simple strings to p5 land");
ok(test2("Yet Ano\0ther P\0erl Hacker"),"Passing strings with null bytes to p5 land");
ok(test3("ąęóśćż"),"Passing strings with unicode to p5 land");
rakudo-2013.12/t/spec/S01-perl-5-integration/subs.t0000664000175000017500000000031312224265625021132 0ustar  moritzmoritzuse v6;
use Test;
plan 2;
my &foo := eval('sub {432}',:lang);
is foo(),432,"calling subs works";

my $foo = eval('sub {432}',:lang);
is $foo(),432,"calling subs stored in variables works";
rakudo-2013.12/t/spec/S02-lexical-conventions/begin_end_pod.t0000664000175000017500000000035212224265625023275 0ustar  moritzmoritzuse v6;

# Test various forms of comments

use Test;

plan 1;

# L

ok 1, "Before the =END Block";

=begin END

flunk "After the end block";


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/bom.t0000664000175000017500000000013112224265625021271 0ustar  moritzmoritzuse v6;
use Test;

plan 1;

ok 1, 'can parse a file starting with a byte-order mark';
rakudo-2013.12/t/spec/S02-lexical-conventions/comments.t0000664000175000017500000001430212224265625022346 0ustar  moritzmoritzuse v6;

# Test various forms of comments

use Test;

# L
{

    ok #`[
        Multiline
        comments
        is fine
    ] 1, 'multiline embedded comment with #`[]';

    ok #`(
        Parens works also
    ) 1, 'multiline embedded comment with #`()';

    # RT #115762
    eval_lives_ok "#`( foo )", "comment as first and only statement";

    eval_lives_ok "2 * 3\n #`<<<\n comment>>>", "multiline comment with <<<";

    my $var = #`{ foo bar } 32;
    is $var, 32, 'embedded comment with #`{}';

    $var = 3 + #`「 this is a comment 」 56;
    is $var, 59, 'embedded comment with LEFT/RIGHT CORNER BRACKET';

    is 2 #`『 blah blah blah 』 * 3, 6, 'embedded comment with LEFT/RIGHT WHITE CORNER BRACKET';

    my @list = 'a'..'c';

    is @list[ #`（注释）2 ], 'c', 'embedded comment with FULLWIDTH LEFT/RIGHT PARENTHESIS';

    is @list[ 0 #`《注释》], 'a', 'embedded comment with LEFT/RIGHT DOUBLE ANGLE BRACKET';

    is @list[#`〈注释〉1], 'b', 'embedded comment with LEFT/RIGHT ANGLE BRACKET';

    # Note that 'LEFT/RIGHT SINGLE QUOTATION MARK' (i.e. ‘’) and
    # LEFT/RIGHT DOUBLE QUOTATION MARK (i.e. “”) are not valid delimiter
    # characters.

    #test some 13 more lucky unicode bracketing pairs
    is(1 #`᚛ pa ᚜ +1, 2, 'embedded comment with #`᚛᚜');
    is(1 #`⁅ re ⁆ +2, 3, 'embedded comment with #`⁅⁆');
    is(2 #`⁽ ci ⁾ +3, 5, 'embedded comment with #`⁽⁾');
    is(3 #`❨ vo ❩ +5, 8, 'embedded comment with #`❨ vo ❩');
    is(5 #`❮ mu ❯   +8, 13, 'embedded comment with #`❮❯');
    is(8 #`❰ xa ❱   +13, 21, 'embedded comment with #`❰❱');
    is(13 #`❲ ze ❳   +21, 34, 'embedded comment with #`❲❳');
    is(21 #`⟦ bi ⟧   +34, 55, 'embedded comment with #`⟦⟧');
    is(34 #`⦅ so ⦆ +55, 89, 'embedded comment with #`⦅⦆');
    is(55 #`⦓ pano ⦔   +89, 144, 'embedded comment with #⦓`⦔');
    is(144 #`⦕ papa ⦖   +233, 377, 'embedded comment with #`⦕⦖');
    is(377 #`『 pare 』   +610, 987, 'embedded comment with #`『』');
    is(610 #`﴾ paci ﴿   +987, 1597, 'embedded comment with #`﴾﴿');
}

# L
#?niecza skip 'Opening bracket is required for #` comment'
{

    eval_dies_ok "3 * #` (invalid comment) 2", "no space allowed between '#`' and '('";
    eval_dies_ok "3 * #`\t[invalid comment] 2", "no tab allowed between '#`' and '['";
    eval_dies_ok "3 * #`  \{invalid comment\} 2", "no spaces allowed between '#`' and '\{'";
    eval_dies_ok "3 * #`\n 2", "no spaces allowed between '#`' and '<'";

}

# L
{

    ok #`<<<
        Or this  works...
    >>> 1, '#`<<<...>>>';
}

#?rakudo todo 'nom regression'
{
    eval_lives_ok( q{{
        my $var = \#`((( comment ))) 12;
        is $var, 12, '#`(((...)))';
    }}, 'Unspaced bracketed comment throws no error' );
}

{
    is(5 * #`<< < >> 5, 25, '#`<< < >>');

    is(6 * #`<< > >> 6, 36, '#`<< > >>');
}

# L
{
    is 3, #`(
        (Nested parens) works also
    ) 3, 'nested parens #`(...(...)...)';

    is 3, #`{
        {Nested braces} works also {}
    } 3, 'nested braces #`{...{...}...}';
}

# I am not sure if this is speced somewhere:
# comments can be nested
#?niecza skip 'Possible runaway string'
{
    is 3, #`(
            comment
            #`{
              internal comment
            }
            more comment
        ) 3, 'comments can be nested with different brackets';
    is 3, #`(
            comment
            #`(
                internal comment
            )
            more
            ) 3, 'comments can be nested with same brackets';

    # TODO:
    # ok eval(" #`{ comment }") fails with an error as it tries to execute
    # comment() before seeing that I meant #`{ comment within this string.

#?pugs todo 'bug'
#?rakudo todo 'NYI'
    eval_lives_ok " #`<<\n comment\n # >>\n >> 3",
        'single line comment cannot correctly nested within multiline';
}

# L
{
    is -1 #`<<<
        Even  <<< also >>> works...
    >>>, -1, 'nested brackets in embedded comment';

    is 'cat', #`{{
        This comment contains unmatched } and { { { {   (ignored)
        Plus a nested {{ ... }} pair                    (counted)
    }} 'cat', 'embedded comments with nested/unmatched bracket chars';
}

# L
#?niecza skip 'Excess arguments to CORE eval'
{
    eval_dies_ok '$a = #`\  (comment) 32', "comments can't contain unspace";
}

# L
{
    my $a;
    lives_ok { eval('$a = q{ 32 }') }, 'sanity check';
    is $a, ' 32 ', 'sanity check';

    $a = Nil;
    eval_dies_ok '$a = q# 32 #;', 'misuse of # as quote delimiters';
    ok !$a.defined, "``#'' can't be used as quote delimiters";
}

# L
#?niecza todo
{
    # ticket http://rt.perl.org/rt3/Ticket/Display.html?id=70752
    eval_lives_ok "#=======\n#=======\nuse v6;", "pragma use after single line comments";
}

# L
eval_lives_ok( q{{

my $outerVal = eval(
    q{my $var = 1;

=begin comment

This is a comment without
a "=cut".

=end comment

        "bar";}
);
is $outerVal, "bar", '=begin comment without =cut parses to whitespace in code';

}}, '=begin comment without =cut eval throws no error' );


# L
eval_lives_ok( q{{

my $outerVal = eval(
    q{10 +

=comment TimToady is here!

    1;}
);
is $outerVal, 11, 'Single paragraph Pod parses to whitespace in code';

}}, 'Single paragraph Pod eval throws no error' );

#?niecza todo
eval_lives_ok( q{{

my $outerVal = eval(
    q{20 +

=comment TimToady and audreyt
are both here, yay!

    2;}
);
is $outerVal, 22, 'Single paragraph Pod, multiple lines parses to whitespace in code';

}}, 'Single paragraph Pod, multiple lines eval throws no error' );

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/end-pod.t0000664000175000017500000000045512224265625022053 0ustar  moritzmoritzuse v6;

# Test various forms of comments

use Test;

plan 1;

# L

# TODO: clarify this test; is not specified at smartlink target location
ok 1, "Before the =END Block";

=END

flunk "After the end block";


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/minimal-whitespace.t0000664000175000017500000000223512224265625024303 0ustar  moritzmoritzuse v6;

use Test;

plan 9;

# L

my @arr = <1 2 3 4 5>;
eval_dies_ok('@arr [0]', 'array with space before opening brackets does not work');

my %hash = {a => 1, b => 2};
eval_dies_ok('%hash ', 'hash with space before opening brackets does not work (1)');
eval_dies_ok('%hash {"a"}', 'hash with space before opening braces does not work (2)');

# XXX this one is wrong, it's parsed as code( (5) )
# STD.pm agrees on that.
#sub code (Int $a) {2 * $a}
#eval_dies_ok('code (5)', 'sub call with space before opening parens does not work');

class Thing {method whatever (Int $a) {3 * $a}}
eval_dies_ok('Thing .new', 'whitespace is not allowed before . after class name');
eval_dies_ok('Thing. new', 'whitespace is not allowed after . after class name');

my $o = Thing.new;
eval_dies_ok('$o .whatever(5)', 'whitespace is not allowed before . before method');
eval_dies_ok('$o. whatever(5)', 'whitespace is not allowed after . before method');

eval_lives_ok 'my @rt80330; [+] @rt80330', 'a [+] with whitespace works';
eval_dies_ok  'my @rt80330; [+]@rt80330', 'a [+] without whitespace dies';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/one-pass-parsing.t0000664000175000017500000000026112224265625023706 0ustar  moritzmoritzuse v6;
use Test;

plan 1;

# L

ok(eval('regex { <[ } > ]> }; 1'),
    "can parse non-backslashed curly and right bracket in cclass");

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/pod-in-multi-line-exprs.t0000664000175000017500000000103412224265625025121 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

Parse problem when pod inside a multi-line hash-def expression.

=end kwid

plan 3;

my $mysub = {

    1;

=begin pod

=end pod

};

ok "anon sub def parses when pod block is within it"; # TODO: complete this test

my $myhash = {

    'baz' => 3,

=begin pod

=end pod

};

ok "anon hash def parses when pod block is within it"; # TODO: complete this test

my $myary = [

    4,

=begin pod

=end pod

];

ok "anon array def parses when pod block is within it"; # TODO: complete this test

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/sub-block-parsing.t0000664000175000017500000000313312224265625024043 0ustar  moritzmoritzuse v6;

use Test;

# TODO: smartlink

# L<"http://use.perl.org/~autrijus/journal/25365">
# Closure composers like anonymous sub, class and module always trumps hash
# dereferences:
#
#   sub{...}
#   module{...}
#   class{...}

plan 9;

#?rakudo skip 'confused near "(sub { 42 "'
ok(sub { 42 }(), 'sub {...} works'); # TODO: clarify

#?rakudo skip 'confused near "(sub{ 42 }"'
ok(sub{ 42 }(),  'sub{...} works'); # TODO: clarify

eval_dies_ok q[
    sub x { die }
    x();
], 'block parsing works with newline';

eval_dies_ok q[
    sub x { die };
    x();
], 'block parsing works with semicolon';

# RT #85844
{
    eval_dies_ok 'sub foo;', 'RT #85844'
}

# RT #76896: 
# perl6 - sub/hash syntax
#?pugs skip 'Unexpected ";"'
{
    sub to_check_before {
        my %fs = ();
        %fs{ lc( 'A' ) } = &fa;
        sub fa() { return 'fa called.'; }
        ;
        %fs{ lc( 'B' ) } = &fb;
        sub fb() { return 'fb called.'; }

        my $fn = lc( @_[ 0 ] || 'A' );
        return %fs{ $fn }();
    }

    sub to_check_after {
        my %fs = ();
        %fs{ lc( 'A' ) } = &fa;
        sub fa() { return 'fa called.'; }

        %fs{ lc( 'B' ) } = &fb;
        sub fb() { return 'fb called.'; }

        my $fn = lc( @_[ 0 ] || 'A' );
        return %fs{ $fn }();
    }

    is to_check_before, "fa called.", 'fa called in old sub/hash syntax is ok';
    is to_check_before('B'), "fb called.", 'fb called in old sub/hash syntax is ok';
    is to_check_after, "fa called.", 'fa called in sub/hash syntax is ok';
    is to_check_after('B'), "fb called.", 'fb called in sub/hash syntax is ok';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/unicode.t0000664000175000017500000001006712224265625022153 0ustar  moritzmoritzuse v6;

use Test;

plan 38;

# L

# Unicode variables
# english ;-)
lives_ok {my $foo; sub foo {}; 1}, "ascii declaration"; #OK not used
is (do {my $bar = 2; sub id ($x) { $x }; id($bar)}), 2, "evaluation";

# umlauts
lives_ok {my $übervar; sub fü {}; 1}, "umlauts declaration"; #OK not used
is (do {my $schloß = 2; sub öok ($x) { $x }; öok($schloß)}), 2, "evaluation";

# monty python
lives_ok {my $møøse; sub bïte {}; 1}, "a møøse once bit my sister"; #OK not used
is (do {my $møøse = 2; sub såck ($x) { $x }; såck($møøse)}), 2,
    "møøse bites kan be preti nasti";

# french
lives_ok {my $une_variable_française; sub blâ {}; 1}, "french declaration"; #OK not used
is (do {my $frénch = 2; sub bléch ($x) { $x }; bléch($frénch)}), 2, "evaluation";

# Some Chinese Characters
lives_ok {my $一; 1}, "chinese declaration"; #OK not used
is (do {my $二 = 2; sub 恆等($x) {$x}; 恆等($二)}), 2, "evaluation";

# Tibetan Characters
lives_ok {my $ཀ; 1}, "tibetan declaration"; #OK not used
is (do {my $ཁ = 2; $ཁ}), 2, "evaluation";

# Japanese
lives_ok {my $い; 1}, "japanese declaration"; #OK not used
is (do {my $に = 2; $に}), 2, "evaluation";

# arabic
lives_ok {my $الصفحة ; 1}, "arabic declaration"; #OK not used
is (do {my $الصفحة = 2; $الصفحة}), 2, "evaluation";

# hebrew
lives_ok {my $פוו; sub לה {}; 1}, "hebrew declaration"; #OK not used
is (do {my $באר = 2; sub זהות ($x) { $x }; זהות($באר)}), 2, "evaluation";

# magyar
lives_ok {my $aáeéiíoóöőuúüű ; 1}, "magyar declaration"; #OK not used
is (do {my $áéóőöúűüí = 42; sub űáéóőöúüí ($óőöú) { $óőöú }; űáéóőöúüí($áéóőöúűüí)}),
       42, "evaluation";

# russian
lives_ok {my $один; sub раз {}; 1}, "russian declaration"; #OK not used
is
    (do {my $два = 2; sub идентичный ($x) { $x }; идентичный($два)}),
    2,
    "evaluation";

#?rakudo 2 skip 'VOWEL SIGNs in identifiers'
lives_ok { my $पहला = 1; }, "hindi declaration";
is((do { my $दूसरा = 2; sub टोटल ($x) { $x + 2 }; टोटल($दूसरा) }), 4, "evaluation");

# Unicode subs
{
    my sub äöü () { 42 }
    is (äöü), 42, "Unicode subs with no parameters";
}
{
    my sub äöü ($x) { 1000 + $x }
    is (äöü 17), 1017, "Unicode subs with one parameter (parsed as listop)";
}

# Unicode parameters
# RT #69959
{
    my sub abc (:$äöü) { 1000 + $äöü }

    is abc(äöü => 42), 1042, "Unicode named params (1)";
    is abc(:äöü(42)),  1042, "Unicode named params (2)";
}

# Unicode placeholder variables
#?mildew skip 'placeholders are NIY'
{
    is
        ~(< foostraße barstraße fakestraße >.map: { tc $^straßenname }),
        "Foostraße Barstraße Fakestraße",
        "Unicode placeholder variables";
}

# Unicode methods and attributes
#?mildew skip 'classes are NIY'
{
    class A {
        has $!möp = 'pugs';
        method äöü {
            $!möp.tc();
        }
    }
    is A.new().äöü(), "Pugs", "Unicode methods and attributes";
}

#?mildew skip 'slurpy named positionals are NIY'
{
    sub f(*%x) { %x<ä> };
    is f(ä => 3), 3, 'non-ASCII named arguments';
}

# L

#?rakudo: todo 'PS does not work to separate lines'
#?pugs todo
eval_lives_ok "\{ 1 \} \x2029 \{ 1 \}", "Unicode 2029 can terminate lines";

# L

eval_lives_ok "q\x298d test \x298e", "Unicode open-298d maps to close-298e";
eval_lives_ok "q\x301d test \x301e", "Unicode open-301d maps to close-301e";
eval_dies_ok "q\x301d test \x301f", "Unicode open-301d does not map to close-301f";
#?pugs 6 todo "eval_lives_ok"
eval_lives_ok "q\x2018 test \x2019", "Unicode open-2018 maps to to close-2019";
eval_lives_ok "q\x201a test \x2019", "Unicode open-201a maps to to close-2019";
eval_lives_ok "q\x2018 \x201a test \x2019", "Alternative open-brakets treat their other alternates as non-special";

# vim: ft=perl6 fileencoding=utf-8

rakudo-2013.12/t/spec/S02-lexical-conventions/unicode-whitespace.t0000664000175000017500000001140012224265625024275 0ustar  moritzmoritzuse v6;

use Test;

plan 52;

sub try_eval($str) { try eval $str }

# L

is(try_eval('
my	@x	=	;	sub	y	(@z)	{	@z[1]	};	y(@x)
'), "b", "CHARACTER TABULATION");

is(try_eval('
my
@x
 =
;
sub
y
(@z)
{
@z[1]
};
y(@x)
'), "b", "LINE FEED (LF)");

is(try_eval('
my@x=;suby(@z){@z[1]};y(@x)
'), "b", "LINE TABULATION");

is(try_eval('
my@x =;suby(@z){@z[1]};y(@x)
'), "b", "FORM FEED (FF)");

is(try_eval('
my
@x
 =
;
sub
y
(@z)
{
@z[1]
};
y(@x)
'), "b", "CARRIAGE RETURN (CR)");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "SPACE");

is(try_eval('
my…@x… =…;…sub…y…(@z)…{…@z[1]…};…y(@x)
'), "b", "NEXT LINE (NEL)");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "NO-BREAK SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "OGHAM SPACE MARK");

is(try_eval('
my᠎@x᠎=᠎;᠎sub᠎y᠎(@z)᠎{᠎@z[1]᠎};᠎y(@x)
'), "b", "MONGOLIAN VOWEL SEPARATOR");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "EN QUAD");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "EM QUAD");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "EN SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "EM SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "THREE-PER-EM SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "FOUR-PER-EM SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "SIX-PER-EM SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "FIGURE SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "PUNCTUATION SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "THIN SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "HAIR SPACE");

is(try_eval('
my
@x
=
;
sub
y
(@z)
{
@z[1]
};
y(@x)
'), "b", "LINE SEPARATOR");

is(try_eval('
my
@x
=
;
sub
y
(@z)
{
@z[1]
};
y(@x)
'), "b", "PARAGRAPH SEPARATOR");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "NARROW NO-BREAK SPACE");

is(try_eval('
my @x = ; sub y (@z) { @z[1] }; y(@x)
'), "b", "MEDIUM MATHEMATICAL SPACE");

is(try_eval('
my　@x　=　;　sub　y　(@z)　{　@z[1]　};　y(@x)
'), "b", "IDEOGRAPHIC SPACE");

#Long dot whitespace tests
#These currently get different results than the above

#This makes 'foo.lc' and 'foo .lc' mean different things
multi foo() { 'a' }
multi foo($x) { $x }

$_ = 'b';

# L
is(try_eval('foo\	.lc'), 'a', 'long dot with CHARACTER TABULATION');
is(try_eval('foo\
.lc'), 'a', 'long dot with LINE FEED (LF)');
is(try_eval('foo\.lc'), 'a', 'long dot with LINE TABULATION');
is(try_eval('foo\.lc'), 'a', 'long dot with FORM FEED (FF)');
is(try_eval('foo\
.lc'), 'a', 'long dot with CARRIAGE RETURN (CR)');
is(try_eval('foo\ .lc'), 'a', 'long dot with SPACE');
is(try_eval('foo\….lc'), 'a', 'long dot with NEXT LINE (NEL)');
is(try_eval('foo\ .lc'), 'a', 'long dot with NO-BREAK SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with OGHAM SPACE MARK');
is(try_eval('foo\᠎.lc'), 'a', 'long dot with MONGOLIAN VOWEL SEPARATOR');
is(try_eval('foo\ .lc'), 'a', 'long dot with EN QUAD');
is(try_eval('foo\ .lc'), 'a', 'long dot with EM QUAD');
is(try_eval('foo\ .lc'), 'a', 'long dot with EN SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with EM SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with THREE-PER-EM SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with FOUR-PER-EM SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with SIX-PER-EM SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with FIGURE SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with PUNCTUATION SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with THIN SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with HAIR SPACE');
is(try_eval('foo\
.lc'), 'a', 'long dot with LINE SEPARATOR');
is(try_eval('foo\
.lc'), 'a', 'long dot with PARAGRAPH SEPARATOR');
is(try_eval('foo\ .lc'), 'a', 'long dot with NARROW NO-BREAK SPACE');
is(try_eval('foo\ .lc'), 'a', 'long dot with MEDIUM MATHEMATICAL SPACE');
is(try_eval('foo\　.lc'), 'a', 'long dot with IDEOGRAPHIC SPACE');

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lexical-conventions/unspace.t0000664000175000017500000001712312224265625022163 0ustar  moritzmoritzuse v6;

use MONKEY_TYPING;

use Test;

plan 78;

# L


ok(4\       .sqrt == 2, 'unspace with numbers');
is(4\#`(quux).sqrt, 2, 'unspace with comments');
is("x"\     .chars, 1, 'unspace with strings');
is("x"\     .chars(), 1, 'unspace with strings + parens');

{
my $foo = 4;
is($foo.++, 4, '(short) unspace with postfix inc');
is($foo, 5, '(short) unspace with postfix inc really postfix');
is($foo\       .++, 5, 'unspace with postfix inc');
is($foo, 6, 'unspace with postfix inc really postfix');
is($foo\       .--, 6, 'unspace with postfix dec');
is($foo, 5, 'unspace with postfix dec really postfix');
}

is("xxxxxx"\.chars, 6, 'unspace without spaces');
is("xxxxxx"\
    .chars, 6, 'unspace with newline');

is((:foo\ ("bar")), ('foo' => "bar"), 'unspace with adverb');

is( ~([1,2,3]\ .[2,1,0]), "3 2 1", 'unspace on postfix subscript');

{
    my @array = 1,2,3;

    @array\    .>>++;
    @array\     .»++;
    is( ~@array, "3 4 5", 'unspace with postfix pre-dot hyperops');
}

#?rakudo skip '.++ does not work'
{
    my @array = 1,2,3;

    @array>>\    .++;
    @array\ .>>\ .++;
    @array»\     .++;
    @array\ .»\  .++;
    is( ~@array, "5 6 7", 'unspace with postfix pre- and/or post-dot hyperops');
}

#Test the "unspace" and unspace syntax


#This makes 'foo.lc' and 'foo .lc' mean different things
multi foo() { 'a' }
multi foo($x) { $x }

#This should do the same, but currently doesn't
sub bar($x? = 'a') { $x }

$_ = 'b';

is((foo.lc   ), 'a', 'sanity - foo.lc');
is((foo .lc  ), 'b', 'sanity - foo .lc');
is((bar.lc   ), 'a', 'sanity - bar.lc');
is((bar .lc  ), 'b', 'sanity - bar .lc');
is((foo\.lc  ), 'a', 'short unspace');
is((foo\ .lc ), 'a', 'unspace');
is((foo\ ('x')), 'x', "unspace before arguments");
#?rakudo skip 'parse fail'
is((foo \ .lc), 'b', 'not a unspace');
eval_dies_ok('fo\ o.lc', 'unspace not allowed in identifier');
is((foo\    .lc), 'a', 'longer dot');
is((foo\#`( comment ).lc), 'a', 'unspace with embedded comment');
eval_dies_ok('foo\#\ ( comment ).lc', 'unspace can\'t hide space between # and opening bracket');
is((foo\ # comment
    .lc), 'a', 'unspace with end-of-line comment');
is((:foo\ ), (:foo), 'unspace in colonpair');
#?rakudo skip 'unimplemented'
#?niecza skip 'Unable to resolve method postcircumfix:<( )> in class Str'
is((foo\ .\ ("x")), 'x', 'unspace is allowed both before and after method .');
is((foo\
=begin comment
blah blah blah
=end comment
    .lc), 'a', 'unspace with pod =begin/=end comment');
{
is((foo\
=for comment
blah
blah
blah

    .lc), 'a', 'unspace with pod =for comment');
}
is(eval('foo\
=comment blah blah blah
    .lc'), 'a', 'unspace with pod =comment');
#This is pretty strange: according to Perl-6.0.0-STD.pm,
#unspace is allowed after a pod = ... which means pod is
#syntactically recursive, i.e. you can put pod comments
#inside pod directives recursively!
#?rakudo skip 'pod and unspace'
is(eval('foo\
=\ begin comment
blah blah blah
=\ end comment
    .lc'), 'a', 'unspace with pod =begin/=end comment w/ pod unspace');
#?rakudo skip '=for pod not implemented (in STD.pm)'
{
is(eval('foo\
=\ for comment
blah
blah
blah

    .lc'), 'a', 'unspace with pod =for comment w/ pod unspace');
}
#?rakudo skip 'pod and unspace'
is(eval('foo\
=\ comment blah blah blah
    .lc'), 'a', 'unspace with pod =comment w/ pod unspace');
#?rakudo skip 'pod and unspace'
is(eval('foo\
=\
=begin nested_pod
blah blah blah
=end nested_pod
begin comment
blah blah blah
=\
=begin nested_pod
blah blah blah
=end nested_pod
end comment
    .lc'), 'a', 'unspace with pod =begin/=end comment w/ pod-in-pod');
#?rakudo skip '=for pod not implemented (in STD.pm)'
{
is(eval('foo\
=\
=for nested pod
blah
blah
blah

for comment
blah
blah
blah

    .lc'), 'a', 'unspace with pod =for commenti w/ pod-in-pod');
is(eval('foo\
=\
=nested pod blah blah blah
comment blah blah blah
    .lc'), 'a', 'unspace with pod =comment w/ pod-in-pod');
is(eval('foo\
=\			#1
=\			#2
=\			#3
=comment blah blah blah
for comment		#3
blah
blah
blah

begin comment		#2
blah blah blah
=\			#4
=comment blah blah blah
end comment		#4
begin comment		#1
blah blah blah
=\			#5
=\			#6
=for comment
blah
blah
blah

comment blah blah blah	#6
end comment		#5
    .lc'), 'a', 'hideous nested pod torture test');

}

# L
#XXX probably shouldn't be in this file...

eval_dies_ok('sub f { 3 } sub g { 3 }', 'semicolon or newline required between blocks');

# L
#
#?rakudo skip 'parse error'
{
    sub baz(Code $x, *@y) { $x.(@y) }

    is((baz { @^x }, 1, 2, 3), (1, 2, 3), 'comma immediately following arg block');
    is((baz { @^x } , 1, 2, 3), (1, 2, 3), 'comma not immediately following arg block');
    is((baz { @^x }\ , 1, 2, 3), (1, 2, 3), 'unspace then comma following arg block');
}

#?rakudo skip 'indirect method calls'
#?niecza skip "Invocant handling is NYI"
{
    augment class Code{
        method xyzzy(Code $x: *@y) { $x.(@y) }
    }

    is((xyzzy { @^x }: 1, 2, 3), (1, 2, 3), 'colon immediately following arg block');
    is((xyzzy { @^x } : 1, 2, 3), (1, 2, 3), 'colon not immediately following arg block');
    is((xyzzy { @^x }\ : 1, 2, 3), (1, 2, 3), 'unspace then colon following arg block');
}

# L
#This creates syntactic ambiguity between
# ($n) ++ ($m)
# ($n++) $m
# ($n) (++$m)
# ($n) + (+$m)

{
    my $n = 1;
    my $m = 2;
    sub infix:<++>($x, $y) { 42 }    #OK not used

    #'$n++$m' should be a syntax error
    eval_dies_ok('$n++$m', 'infix requires space when ambiguous with postfix');
    is($n, 1, 'check $n');
    is($m, 2, 'check $m');

    #'$n ++$m' should be infix:<++>
    #no, really: http://irclog.perlgeek.de/perl6/2007-05-09#id_l328
    $n = 1; $m = 2;
    is(eval('$n ++$m'), 42, '$n ++$m with infix:<++> is $n ++ $m');
    is($n, 1, 'check $n');
    is($m, 2, 'check $m');

    #'$n ++ $m' should be infix:<++>
    $n = 1; $m = 2;
    is(eval('$n ++ $m'), 42, 'postfix requires no space w/ infix ambiguity');
    is($n, 1, 'check $n');
    is($m, 2, 'check $m');

    #These should all be postfix syntax errors
    $n = 1; $m = 2;
    eval_dies_ok('$n.++ $m',   'postfix dot w/ infix ambiguity');
    eval_dies_ok('$n\ ++ $m',  'postfix unspace w/ infix ambiguity');
    eval_dies_ok('$n\ .++ $m', 'postfix unspace w/ infix ambiguity');
    is($n, 1, 'check $n');
    is($m, 2, 'check $m');

    #Unspace inside operator splits it
    $n = 1; $m = 2;
    #?rakudo skip 'parse error'
    is(($n+\ +$m), 3, 'unspace inside operator splits it');
    is($n, 1, 'check $n');
    is($m, 2, 'check $m');

    $n = 1;
    eval_dies_ok('$n ++', 'postfix requires no space');
    is($n, 1, 'check $n');

    $n = 1;
    is($n.++, 1, 'postfix dot');
    is($n, 2, 'check $n');

    $n = 1;
    is($n\ ++, 1, 'postfix unspace');
    is($n, 2, 'check $n');

    $n = 1;
    is($n\ .++, 1, 'postfix unspace');
    is($n, 2, 'check $n');

    # L
    #?niecza skip 'Unable to resolve method id in class Str'
    #?rakudo skip 'parse error'
    is((foo\#`〝 comment 〞.id), 'a', 'unspace with U+301D/U+301E comment');
    eval_dies_ok('foo\#`〝 comment 〟.id', 'unspace with U+301D/U+301F is invalid');

    # L
    # .123 is equal to 0.123
    is ( .123), 0.123, ' .123 is equal to 0.123';
    is (.123), 0.123, '.123 is equal to 0.123';
}

# Was a nasty niecza bug
is 5.Str\.Str, "5", 'unspaced postfix after method call not misparsed';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-lists/tree.t0000664000175000017500000000144512224265625016636 0ustar  moritzmoritzuse v6;
use Test;
plan 9;

is (1, 2, (3, 4)).tree.elems, 3, 'basic sanity (1)';
is (1, 2, (3, 4)).tree.join('|'), '1|2|3 4', 'basic sanity (2)';
ok List.tree === List, '.tree on a type object';
is (1, 2, (3, 4)).tree(1).join('|'), '1|2|3 4', '.tree(1)';
is (1, (2, (3, 4))).tree(1).[1].flat.elems, 3,
    '.tree(1) really only goes one level deep';

is (1, (2, (3, 4))).tree(2).[1].flat.elems, 2,
    '.tree(2) goes two levels deep';
is ~((1, 2), (3, 4)).tree(*.join('|')), '1|2 3|4',
    'WhateverCode form, depth 1';

#?rakudo skip 'Any.tree(*@list) NYI'
is (1, ((2, 3),  (4, 5))).tree(*.join('|'), *.join('+')).join('-'),
    '1-2|3+4|5', '.tree with multiple Whatever-closures';

{
    my $t = '';
    $t ~= "|$_" for ( Z ).tree;
    is $t, "|a X|b Y|c Z", '(parcel of parcels).tree';
}
rakudo-2013.12/t/spec/S02-literals/array-interpolation.t0000664000175000017500000000342312224265625022361 0ustar  moritzmoritzuse v6;

use Test;

# L
# See L:
#   In a private conversation with Larry this afternoon, he said that by
#   default "$foo" and ~$foo and $foo.as(Str) all give the same result
#   (assuming scalar context, etc.).  And that "@foo[]" and ~[at]foo and
#   @foo.as(Str) are the same as join(' ', @foo) where join is effectively:

plan 12;

{
  my @array = ;

  is ~@array, "a b c d",
    "arrays whose elements don't contain whitespace stringify correctly (1)";
  is "@array[]", "a b c d", "arrays whose elements don't contain whitespace stringify correctly (2)";
  is "@array.[]", "a b c d", '@array.[] interpolates';
  is "@array", "@array", '@array (without brackets) doesnt interpolate';
}

{
  my @array = ;
  push @array, [];

  is ~@array, "a b c d e f g h",
    "arrays with embedded array references stringify correctly (1)";
  is "@array[]", "a b c d e f g h", "arrays with embedded array references stringify correctly (2)";
}

{
  my @array = ("a", "b ", "c");

  is ~@array, "a b  c",
    "array whose elements do contain whitespace stringify correctly (1-1)";
  is "@array[]", "a b  c", "array whose elements do contain whitespace stringify correctly (1-2)";
}

{
  my @array = ("a\t", "b ", "c");

  is ~@array, "a\t b  c",
    "array whose elements do contain whitespace stringify correctly (2-1)";
  is "@array[]", "a\t b  c", "array whose elements do contain whitespace stringify correctly (2-2)";
}

{
  my @array = ("a\t", " b ", "c");

  is ~@array, "a\t  b  c",
    "array whose elements do contain whitespace stringify correctly (3-1)";
  is "@array[]", "a\t  b  c", "array whose elements do contain whitespace stringify correctly (3-2)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/autoref.t0000664000175000017500000002056512224265625020031 0ustar  moritzmoritzuse v6;
use Test;

# L

=begin description

 Tests testing that automatical referentiation (e.g. $arrayref = @array)
 works. To be more detailled, things tested are:
 * Implicit & explicit referentiation of arrays & hashes in assignment
 * Implicit & explicit referentiation of arrays & hashes in assignment to an
   array & hash element
 * Implicit & explicit referentiation of array&hashes&array literals&arrayref
   literals&hashref literals in pair creation with key => ... and :key(...)
   and ... => key.

=end description

plan 57;

# Implicit referentiation of arrays in assignment
{
    my @array = ;
    my $ref   = @array;

    is ~$ref, "a b c", '$arrayref = @array works (1)';
    is +$ref,       3, '$arrayref = @array works (2)';
}

{
    my @array = ;
    my $ref   = \@array;

    #?niecza todo
    is ~$ref, "a b c", '$arrayref = \@array works (1)';
    # Explicit referentiation of arrays in assignment
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +$ref,       1, '$arrayref = \@array works (2)';
}

# Implicit referentiation of hashes in assignment
{
    my %hash = (a => 1, b => 2, c => 3);
    my $ref  = %hash;

    #?pugs todo
    is ~$ref.values.sort, "1 2 3", '$hashref = %hash works (1)';
    is +$ref.values,            3, '$hashref = %hash works (2)';
}

# Explicit referentiation of hashes in assignment
{
    my %hash = (a => 1, b => 2, c => 3);
    my $ref  = \%hash;

    #?pugs todo
    is ~$ref[0].values.sort, "1 2 3", '$hashref = \%hash works (1)';
    #?pugs todo
    is +$ref[0].values,      3,       '$hashref = \%hash works (2)';
}

# Implicit referentiation of arrays in assignment to an array element
{
    my @array = ;
    my @other;
    @other[1] = @array;

    is ~@other,    " a b c", '@other[$idx] = @array works (1)';
    is +@other,           2, '@other[$idx] = @array works (2)';
    is +@other[1],        3, '@other[$idx] = @array works (3)';
}

# Explicit referentiation of arrays in assignment to an array element
{
    my @array = ;
    my @other;
    @other[1] = \@array;

    #?niecza todo
    is ~@other, " a b c", '@other[$idx] = \@array works (1)';
    is +@other,        2, '@other[$idx] = \@array works (2)';
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +@other[1],     1, '@other[$idx] = \@array works (3)';
}

# Implicit referentiation of hashes in assignment to an array element
{
    my %hash = (a => 1, b => 2, c => 3);
    my @other;
    @other[1] = %hash;

    is +@other,    2, '@other[$idx] = %hash works (1)';
    is +@other[1], 3, '@other[$idx] = %hash works (2)';
}

# Explicit referentiation of hashes in assignment to an array element
{
    my %hash = (a => 1, b => 2, c => 3);
    my @other;
    @other[1] = \%hash;

    is +@other,    2, '@other[$idx] = \%hash works (1)';
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +@other[1], 1, '@other[$idx] = \%hash works (2)';
}

# Implicit referentiation of arrays in assignment to a hash element
{
    my @array = ;
    my %other;
    %other = @array;

    is +%other,    1, '%other[$key] = @array works (1)';
    is +%other, 3, '%other[$key] = @array works (2)';
}

# Explicit referentiation of arrays in assignment to a hash element
{
    my @array = ;
    my %other;
    %other = \@array;

    is +%other,    1, '%other[$key] = \@array works (1)';
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +%other, 1, '%other[$key] = \@array works (2)';
}

# Implicit referentiation of hashes in assignment to a hash element
{
    my %hash = (a => 1, b => 2, c => 3);
    my %other;
    %other = %hash;

    is +%other,    1, '%other[$key] = %hash works (1)';
    is +%other, 3, '%other[$key] = %hash works (2)';
}

# Explicit referentiation of hashes in assignment to a hash element
{
    my %hash = (a => 1, b => 2, c => 3);
    my %other;
    %other = \%hash;

    is +%other,    1, '%other[$key] = \%hash works (1)';
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +%other, 1, '%other[$key] = \%hash works (2)';
}

# Implicit referentiation of arrays in pair creation with key => ...
{
    my @array = ;
    my $pair  = (key => @array);

    is ~$pair.value, "a b c", '(key => @array) works (1)';
    is +$pair.value,       3, '(key => @array) works (2)';
}

# Explicit referentiation of arrays in pair creation with key => ...
{
    my @array = ;
    my $pair  = (key => \@array);

    #?niecza todo
    is ~$pair.value, "a b c", '(key => \@array) works (1)';
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +$pair.value,       1, '(key => \@array) works (2)';
}

# Implicit referentiation of hashes in pair creation with key => ...
{
    my %hash = (a => 1, b => 2, c => 3);
    my $pair = (key => %hash);

    #?pugs todo
    is ~$pair.value.values.sort, "1 2 3", '(key => %hash) works (1)';
    is +$pair.value.values,            3, '(key => %hash) works (2)';
}

# Explicit referentiation of hashes in pair creation with key => ...
{
    my %hash = (a => 1, b => 2, c => 3);
    my $pair = (key => \%hash);

    #?pugs todo
    is ~$pair.value.[0].values.sort, "1 2 3", '(key => \%hash) works (1)';
    #?pugs todo
    is +$pair.value.[0].values,            3, '(key => \%hash) works (2)';
}

# Implicit referentiation of arrays in pair creation with :key(...)
{
    my @array = ;
    my $pair  = (:key(@array));

    is ~$pair.value, "a b c", '(:key(@array)) works (1)';
    is +$pair.value,       3, '(:key(@array)) works (2)';
}

# Explicit referentiation of arrays in pair creation with :key(...)
{
    my @array = ;
    my $pair  = (:key(\@array));

    #?niecza todo
    is ~$pair.value, "a b c", '(:key(\@array)) works (1)';
    #?niecza skip 'Cannot use value like Capture as a Number'
    #?pugs todo
    is +$pair.value,       1, '(:key(\@array)) works (2)';
}

# Implicit referentiation of hashes in pair creation with :key(...)
{
    my %hash = (a => 1, b => 2, c => 3);
    my $pair = (:key(%hash));

    #?pugs todo
    is ~$pair.value.values.sort, "1 2 3", '(:key(%hash)) works (1)';
    is +$pair.value.values,            3, '(:key(%hash)) works (2)';
}

# Explicit referentiation of hashes in pair creation with :key(...)
{
    my %hash = (a => 1, b => 2, c => 3);
    my $pair = (:key(\%hash));

    #?pugs todo
    is ~$pair.value.[0].values.sort, "1 2 3", '(:key(\%hash)) works (1)';
    #?pugs todo
    is +$pair.value.[0].values,            3, '(:key(\%hash)) works (2)';
}

# Implicit referentiation of array literals in pair creation with key => ...
{
    my $pair  = (key => );

    is ~$pair.value, "a b c", '(key => <...>) works (1)';
    is +$pair.value,       3, '(key => <...>) works (2)';
}

# Arrayref literals in pair creation with key => ...
{
    my $pair  = (key => []);

    is ~$pair.value, "a b c", '(key => [<...>]) works (1)';
    is +$pair.value,       3, '(key => [<...>]) works (2)';
}

# Hashref literals in pair creation with key => ...
{
    my $pair  = (key => { a => 1, b => 2 });

    is +$pair.value, 2, '(key => {...}) works';
}

# Implicit referentiation of array literals in pair creation with :key(...)
{
    my $pair  = (:key());

    is ~$pair.value, "a b c", '(:key(<...>)) works (1)';
    is +$pair.value,       3, '(:key(<...>)) works (2)';
}

# Arrayref literals in pair creation with :key(...)
{
    my $pair  = (:key([]));

    is ~$pair.value, "a b c", '(:key([<...>])) works (1)';
    is +$pair.value,       3, '(:key([<...>])) works (2)';
}

# Hashref literals in pair creation with :key(...)
{
    my $pair  = (:key({ a => 1, b => 2 }));

    is +$pair.value, 2, '(:key({...})) works';
}

# Implicit referentiation of array literals in pair creation with ... => "value"
{
    my $pair  = ( => "value");

    is ~$pair.key, "a b c", '(<...> => "value") works (1)';
    is +$pair.key,       3, '(<...> => "value") works (2)';
}

# Arrayref literals in pair creation with ... => "value"
{
    my $pair  = ([] => "value");

    is ~$pair.key, "a b c", '([<...>] => "value") works (1)';
    is +$pair.key,       3, '([<...>] => "value") works (2)';
}

# Hashref literals in pair creation with ... => "value"
{
    my $pair  = ({ a => 1, b => 2 } => "value");

    is +$pair.key, 2, '({...} => "value") works';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/char-by-name.t0000664000175000017500000000233712224265625020624 0ustar  moritzmoritzuse v6;

use Test;

plan 10;

# XXX [TODO] more tests in other Unicode charset.

# L

#?pugs 4 todo
is "\c[LEFT CORNER BRACKET]", "「", '\c[LEFT CORNER BRACKET]';
is "\c[RIGHT WHITE CORNER BRACKET]", "』", '\c[RIGHT WHITE CORNER BRACKET]';
is "\c[FULLWIDTH RIGHT PARENTHESIS]", "）", '\c[FULLWIDTH RIGHT PARENTHESIS]';
is "\c[LEFT DOUBLE ANGLE BRACKET]", "《", '\c[LEFT DOUBLE ANGLE BRACKET]';

#?pugs 3 todo 'Character literals with \c$number'
is("\c[LINE FEED (LF)]", "\c10", '\c[LINE FEED (LF)] works');
#?rakudo skip '\c[LINE FEED] not valid'
#?niecza skip 'Unrecognized character name LINE FEED'
is("\c[LINE FEED]", "\c10", '\c[LINE FEED] works');
#?rakudo skip '\c[LF] not valid'
is("\c[LF]", "\c10", '\c[LF] works');

# L
#?pugs 2 todo 'List of characters in \c[...]'
is "\c[LATIN CAPITAL LETTER A, LATIN CAPITAL LETTER B]", 'AB', 'two letters in \c[]';
is "\c[LATIN CAPITAL LETTER A, COMBINING GRAVE ACCENT]", "\x[0041,0300]", 'letter and combining char in \c[]';

#?pugs todo
ok "\c[LATIN SMALL LETTER A WITH DIAERESIS,COMBINING CEDILLA]" ~~ /\w/,
   'RT 64918 (some strings throw "Malformed UTF-8 string" errors';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/char-by-number.t0000664000175000017500000000465212224265625021176 0ustar  moritzmoritzuse v6;

use Test;

plan 42;

# L

is("\x20", ' ', '\x20 normal space');
is("\xa0", ' ', '\xa0 non-breaking space');

is("\x[20]", ' ', '\x[20] normal space');
is("\x[a0]", chr(0xa0), '\x[a0] non-breaking space');
is("\x[263a]", '☺', '\x[263a] wide hex character (SMILEY)');
is("\x[6211]", '我', '\x[597d] wide hex character (Chinese char)');
#?pugs 2 todo
eval_dies_ok('"\x[6211"', 'broken "\x[6211"');
eval_dies_ok('"\x [6211]"', 'broken "\x [6211]"');

is("\x[41,42,43]", 'ABC', '\x[list]');
is("\x[4f60,597d]", '你好', '\x[a,b]');
is("\x41,42,43", 'A,42,43', '\xlist not valid');

is("\o40", ' ', '\o40 normal space');
is("\o240", ' ', '\o240 non-breaking space');

is("\o[40]", ' ', '\o[40] normal space');
is("\o[240]", chr(160), '\o[240] non-breaking space');
is("\o[23072]", '☺', '\o[23072] wide hex character (SMILEY)');
is("\o[61021]", '我', '\o[61021] wide hex character (Chinese char)');
#?pugs 2 todo
eval_dies_ok('"\o[6211"', 'broken "\o[6211"');
eval_dies_ok('"\o [6211]"', 'broken "\o [6211]"');

is("\o[101,102,103]", 'ABC', '\o[list]');
is("\o[47540,54575]", '你好', '\o[a,b]');
is("\o101,102,103", 'A,102,103', '\olist not valid');

is("\c32", ' ', '\c32 normal space');
is("\c160", ' ', '\c160 non-breaking space');

is("\c[32]", ' ', '\c[32] normal space');
is("\c[160]", chr(160), '\c[240] non-breaking space');
is("\c[9786]", '☺', '\c[9786] wide hex character (SMILEY)');
is("\c[25105]", '我', '\c[25105] wide hex character (Chinese char)');
#?pugs 2 todo
eval_dies_ok('"\c[6211"', 'broken "\c[6211"');
eval_dies_ok('"\c [6211]"', 'broken "\c [6211]"');

is("\c[65,66,67]", 'ABC', '\c[list]');
is("\c[20320,22909]", '你好', '\c[a,b]');
is("\c65,66,67", 'A,66,67', '\clist not valid');

# L

{
    eval_dies_ok q{"\123"}, '"\123" form is no longer valid Perl 6';
    eval_dies_ok q{"\10"}, '"\10" form is no longer valid Perl 6';
}

#?pugs skip '\040'
{
    is "\040", "\x[0]40", '\0stuff is actually valid';
}

{
    is "\08", chr(0) ~ '8', 'next char of \0 is 8 (> 7)';
    is "\0fff", chr(0) ~ 'fff', 'next char of \0 is `f`';
}

#?rakudo todo 'Detecting malformed escape sequences NYI'
#?niecza todo 'Detecting malformed escape sequences NYI'
{
    eval_dies_ok q{"\00"}, 'next char of \0 is 0';
    eval_dies_ok q{"\01"}, 'next char of \0 is 1';
    eval_dies_ok q{"\05"}, 'next char of \0 is 5';
    eval_dies_ok q{"\07"}, 'next char of \0 is 7';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/fmt-interpolation.t0000664000175000017500000000252512224265625022033 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

=head1 String interpolation and fmt

These tests exercise a bug found at least in r16241 of Pugs

=end kwid

plan 11;

# L

my $x = 'A';
my $y;

is("\$x is $x", '$x is A', 'normal scalar variable interpolation');

is(
   "ord of \$x is $x.ord()",
   'ord of $x is 65',
   'normal scalar variable builtin call as a method'
);
lives_ok(sub { $y = "ord of \$x is $x.ord.fmt('%d')" },
   'fmt and scalar interpolation live');
is($y, 'ord of $x is 65', 'fmt and scalar interpolation behave well');

is("\$x is {$x}", '$x is A', 'normal scalar variable interpolation');
is(
   "ord of \$x is {$x.ord()}",
   'ord of $x is 65',
   'normal scalar variable builtin call as a method'
);
lives_ok(sub { $y = "hex-formatted ord of \$x is {$x.ord().fmt('%x')}" },
   'fmt and code interpolation live');
is(
   $y,
   'hex-formatted ord of $x is 41',
   'fmt and code interpolation behave well'
);

# These tests actually exercise what's a bug in eval() IMHO -- polettix
my $z;
my $expected = 'hex-formatted ord of $x is 41';
is(
   eval(
      q[
         $y = "hex-formatted ord of \$x is {$x.ord().fmt('%x')}";
         $z = 1;
         $y;
      ]
   ),
   $expected,
   'evals ok'
);
ok($z, 'eval was *really* ok');
is($y, $expected, 'fmt and code interpolation behave well');

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/hash-interpolation.t0000664000175000017500000000161612224265625022170 0ustar  moritzmoritzuse v6;

use Test;

plan 10;

{
  my %hash = (a => 1, b => 2);
  is "%hash",   1, '"%hash" works';
  is "<%hash>", '<1>', '"<%hash>" works';
}

{
  my $hash = { a => 1, b => 2 };
  is "$hash",   1, '"$hash" works';
  is "<$hash>", '<1>', '"<$hash>" works';
}

{
  # L
  my %hash = { b => 2 };
  #?niecza 2 todo 'zen hash slice'
  is "%hash{}", "b\t2", 'interpolation with curly braces';
  is "%hash<>", "b\t2", 'interpolation with angle brackets';
  is "%hash", '%hash', 'no interpolation';
}

{
    # "%hash{a}" actually calls a(). Test that.
    my %hash = (a => 1, b => 2);
    sub do_a {
        'b';
    }
    is "%hash{do_a}", "2",  '%hash{do_a} calls do_a()';

    is "%hash{'b'}",  "2",  'can quote hash indexes in interpolations 1';
    is "%hash{"b"}",  "2",  'can quote hash indexes in interpolations 2';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/heredocs.t0000664000175000017500000000527312224265625020157 0ustar  moritzmoritzuse Test;
plan 16;

my $foo = "FOO";
my $bar = "BAR";

sub no-r(Str $in) { $in.subst(/\r/, '', :g) }

# L
{ # qq:to
    my @q = ();

    @q = qq:to/FOO/;
blah
$bar
blah
$foo
FOO

    is(+@q, 1, "q:to// is singular");
    is(no-r(@q[0]), "blah\nBAR\nblah\nFOO\n", "here doc interpolated");
};

{ # qq:to
    my @q = ();

    @q = qq:to/FOO/;
        blah
        $bar
        blah
        $foo
        FOO

    is(no-r(@q[0]), "blah\nBAR\nblah\nFOO\n", "here doc interpolating with indentation");
};

# L
{ # q:to indented
    my @q = ();

    @q = q:to/FOO/;
        blah blah
        $foo
        FOO

    is(+@q, 1, "q:to// is singular, also when indented");
    is(no-r(@q[0]), "blah blah\n\$foo\n", "indentation stripped");
};

{ # q:heredoc backslash bug
        my @q = q:heredoc/FOO/
yoink\n
splort\\n
FOO
;
        is(+@q, 1, "q:heredoc// is singular");
        is(no-r(@q[0]), "yoink\\n\nsplort\\n\n", "backslashes");
}

my $multiline = "Hello\nWorld";

# some dedent tests
{
    my @q = qq:to/END/;
        first line
        $multiline
        another line
        END

    is no-r(@q[0]), "first line\nHello\nWorld\nanother line\n", "indent with multiline interpolation";
}

$multiline = "Hello\n    World";
{
    my @q = qq:to/END/;
        first line
        $multiline
        another line
        END

    is no-r(@q[0]), "first line\nHello\n    World\nanother line\n", "indent with multiline interpolation with spaces at the beginning";
}
{
    my @q = qq:to/END/;
        first line
        $multiline        something
        another line
        END

    is no-r(@q[0]), "first line\nHello\n    World        something\nanother line\n", "extra spaces after interpolation will be kept";
}

{
    my ($one, $two) = ;
    my @q = qq:to/END/;
        {$one}{$two}
        stuff
        END

    is no-r(@q[0]), "foobar\nstuff\n", "interpolations without constant strings in the middle";

    my @q2 = qq:to/END/;
        stuff
        {$one}{$two}
        END

    is no-r(@q2[0]), "stuff\nfoobar\n", "interpolations at the very end";

    my @q3 = qq:to/END/;
        line one

        line two

        $one
        END

    is no-r(@q3[0]), "line one\n\nline two\n\nfoo\n", "empty lines";
}

{
    my @q = qq:to/END/;
		stuff
		stuff
		END

    is no-r(@q[0]), "stuff\nstuff\n", "Tabs get correctly removed";

    my @q2 = qq:to/END/;
	    stuff
	    barfoo
	    END

    is no-r(@q2[0]), "stuff\nbarfoo\n", "mixed tabs and spaces get correctly removed";

    my @q3 = qq:to/END/;
        	line one
	        line two
		END

    is no-r(@q3[0]), "line one\nline two\n", "mixing tabs and spaces even more evil-ly";
}
rakudo-2013.12/t/spec/S02-literals/hex_chars.t0000664000175000017500000000063112224265625020320 0ustar  moritzmoritzuse v6;
use Test;

plan 4;

#L
{
    my @unicode =
	    'a',  "\x61",
	    'æ',  "\xE6",
	    '喃', "\x5583",
	    '𨮁', "\x28B81",
    ;

    for @unicode -> $literal, $codepoint {
	    is(
		    $codepoint,
		    $literal,
		    'Does a character codepoint (\x..) evaluate to the same thing as its literal?'
	    );
    }
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/listquote.t0000664000175000017500000000466612224265625020421 0ustar  moritzmoritzuse v6;

use Test;

plan 23;

# L

my $s = join 'a', ;
is($s, "xayaz", 'list context ');

#?rakudo skip 'meta operators'
#?niecza skip '|<<'
#?pugs todo '|<<'
{
my $s = join |<< ;
is($s, "xayaz", 'listop |<< ');
}

#?niecza skip "Preceding context expects a term, but found infix , instead"
ok( [1,2,3].join ~~ Failure , '.join parses and fails');

my @y = try { ({:a<1>, :b(2)}) };
#?rakudo todo 'unknown errors'
ok(@y eqv [1,2,Any], '{...} is hash subscript');

eval_dies_ok '({:a<1>, :b(2)} )', '{...} <...> parsefail';

ok( ?((1 | 3) < 3), '(...) < 3 no parsefail');

#?pugs todo 'parsing bug'
eval_dies_ok '(1 | 3)<3', '()<3 parsefail';

# WRONG: should be parsed as print() < 3
# eval 'print < 3';
# ok($!, 'print < 3 parsefail');


eval_dies_ok ':foo <1 2 3>', ':foo <1 2 3> parsefail';

dies_ok { :foo <3 }, '<3 is comparison, but dies at run time';

my $p = eval ':foo<1 2 3>';
is($p, ~('foo' => (1,2,3)), ':foo<1 2 3> is pair of list');

# Lists may contain newline characters

{
    my %e = ("foo", "bar", "blah", "blah");

    my %foo = (
            "foo", "bar",
            "blah", "blah",
    );
    is(+%foo,      +%e,      "Hashes with embedded newlines in the list (1)");
    is(%foo,  %e,  "Hashes with embedded newlines in the list (2)");
    is(%foo, %e, "Hashes with embedded newlines in the list (3)");
}

# L is disallowed">

eval_dies_ok '<>', 'bare <> is disallowed';
eval_dies_ok '', ' is disallowed';

# L
{
    my $c = ;
    isa_ok($c, Parcel, 'List in scalar context becomes a Capture');
    dies_ok {$c.push: 'd'}, '... which is immutable';
}

{
    # L
    my @a = ;
    is ~@a, 'foo 3 4.5 5.60 1.2e1',
       '<...> numeric literals stringify correctly';
    isa_ok @a[0], Str, ' is a Str';
    #?rakudo 3 todo 'magic type of <...> contents'
    isa_ok @a[1], Int, '< ... 3 ...> is an Int';
    isa_ok @a[2], Rat, '< ... 4.5 ...> is a Rat';
    isa_ok @a[4], Num, '< ... 1.2e1 ...> is a Num';
}

# probably doesn't really belong here, but I don't know where else to put it
# :(    --moritz

# RT #76452
{
    sub f($x) { $x[0] };
    is f(my @x = (1, 2, 3)), 1, 'function call with assignment to list';
}

done();

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/listquote-whitespace.t0000664000175000017500000000355112224265625022543 0ustar  moritzmoritzuse v6;

use Test;

# L

=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 whitespace
character and thus should B 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 = ;
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
rakudo-2013.12/t/spec/S02-literals/misc-interpolation.t0000664000175000017500000001310312224265625022172 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

=head1 String interpolation

These tests derived from comments in L

=end pod

plan 46;

my $world = "World";
my $number = 1;
my @list  = (1,2);
my %hash  = (1=>2);
sub func { return "func-y town" }
sub func_w_args($x,$y) { return "[$x][$y]" }

# Double quotes
is("Hello $world", 'Hello World', 'double quoted string interpolation works');
is("@list[]\ 3 4", '1 2 3 4', 'double quoted list interpolation works');
is("@list 3 4", '@list 3 4', 'array without empty square brackets does not interpolate');
#?niecza todo 'No value for parameter \$index in postcircumfix:<{ }>'
is("%hash{}", "1\t2", 'hash interpolation works');
is("%hash", '%hash', 'hash interpolation does not work if not followed by {}');
#?niecza skip 'Action method escape:sym<&> not yet implemented'
is("Wont you take me to &func()", 'Wont you take me to func-y town', 'closure interpolation');
is("2 + 2 = { 2+2 }", '2 + 2 = 4', 'double quoted closure interpolation works');

#?niecza skip 'Action method escape:sym<&> not yet implemented'
is("&func() is where I live", 'func-y town is where I live', "make sure function interpolation doesn't eat all trailing whitespace");
is("$number {$number}", '1 1', 'number inside and outside closure works');
is("$number {my $number=2}", '1 2', 'local version of number in closure works');
is("$number {my $number=2} $number", '1 2 1', 'original number still available after local version in closure: works' );

#?pugs skip '?'
{
    is "$(my $x = 2) $x", '2 2', 'Variable should interpolate and still be available in the outer scope.';
    is("$(my $y = 2)" ~ $y, '22', 'Variable should interpolate and still be available in the outer scope.');
}

# L
is("&func. () is where I live", '&func. () is where I live', '"&func. ()" should not interpolate');

# RT #116166
is("$world.", 'World.', '"$world." should not interpolate');
is("$world!", 'World!', '"$world!" should not interpolate');

#?niecza skip 'Action method escape:sym<&> not yet implemented'
is("&func_w_args("foo","bar"))", '[foo][bar])', '"&func_w_args(...)" should interpolate');

# L
is("$world.chars()", '5', 'method calls with parens should interpolate');
is("$world.chars", 'World.chars', 'method calls without parens should not interpolate');
is("$world.flip.chars()", '5', 'cascade of argumentless methods, last ending in paren');
is("$world.substr(0,1)", 'W', 'method calls with parens and args should interpolate');

# Single quotes
# XXX the next tests will always succeed even if '' interpolation is buggy
is('Hello $world', 'Hello $world', 'single quoted string interpolation does not work (which is correct)');
is('2 + 2 = { 2+2 }', '2 + 2 = { 2+2 }', 'single quoted closure interpolation does not work (which is correct)');
is('$world @list[] %hash{} &func()', '$world @list[] %hash{} &func()', 'single quoted string interpolation does not work (which is correct)');

# Corner-cases
is("Hello $world!", "Hello World!", "! is not a part of var names");
sub list_count (*@args) { +@args }
is(list_count("@list[]"), 1, 'quoted interpolation gets string context');
#?pugs todo
is(qq{a{chr 98}c}, 'a{chr 98}c', "curly brace delimiters interfere with closure interpolation");

# Quoting constructs
# The next test will always succeed, but if there's a bug it probably
# won't compile.
#?pugs 3 skip 'parsefail'
is(Q"abc\\d\\'\/", Q"abc\\d\\'\/", "raw quotation works");
is(q"abc\\d\"\'\/", Q|abc\d"\'\/|, "single quotation works"); #"
is(qq"abc\\d\"\'\/", Q|abc\d"'/|, "double quotation works"); #"
#?pugs skip 'parsefail'
is(qa"$world @list[] %hash{}", Q"$world 1 2 %hash{}", "only interpolate array");
is(qb"$world \\\"\n\t", "\$world \\\"\n\t", "only interpolate backslash");
is('$world \qq[@list[]] %hash{}', '$world 1 2 %hash{}', "interpolate quoting constructs in ''");

is(" \c[111] \c[107] ", ' o k ', "\\c[] respects whitespaces around it");

# L
is("x  \x[41,42,43]  x",     "x  ABC  x",  "\\x[] allows multiple chars (1)");
is("x  \x[41,42,00043]  x",  "x  ABC  x",  "\\x[] allows multiple chars (2)");   #OK not indicate octal
#?pugs todo
is("x  \x[ 41, 42, 43 ]  x", "x  ABC  x",  "\\x[] allows multiple chars with white space");
is("x  \c[65,66,67]  x",     "x  ABC  x",  "\\c[] allows multiple chars (1)");
is("x  \c[65,66,000067]  x", "x  ABC  x",  "\\c[] allows multiple chars (2)");   #OK not indicate octal
#?pugs todo
is("x  \c[ 65, 66, 67 ]  x", "x  ABC  x",  "\\c[] allows multiple chars with white space");

is("x  \x[41,42,43]]  x",    "x  ABC]  x", "\\x[] should not eat following ]s");
is("x  \c[65,66,67]]  x",    "x  ABC]  x", "\\c[] should not eat following ]s");

# L
#?pugs skip 'parsefail'
{
    class InterpolationTest {
        method f { 'int' }
    }
    my $x = InterpolationTest.new;

    # ORLY, STD.pm parses that as an indirect method call. It will warn,
    # but strictly speaking it's legal.
    is "|$x.'f'()|", '|int|',    #OK use of quotes
       'interpolation of indirect method calls (different quotes)';
    is "|$x."f"()|", '|int|',    #OK use of quotes
       'interpolation of indirect method calls (same quotes)';
    eval_dies_ok q["|$x."f "()"], '... but whitespaces are not allowed';
}

# RT # 104594
# rakudo had some trouble with lexicals from inside interpolated blocks
{
    sub t($p) { t $p-1 if $p-1 > 0; return "{$p}" };
    is t(3), 3, 'variables interpoalted into blocks and recursion interact nicely';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/numeric.t0000664000175000017500000000301712224265625020017 0ustar  moritzmoritzuse v6;
use Test;

plan 22;

isa_ok 1, Int, '1 produces a Int';
ok 1 ~~ Numeric, '1 is Numeric';
ok 1 ~~ Real, '1 is Real';

isa_ok 1.Num, Num, '1.Num produces a Int';
ok 1.Num ~~ Numeric, '1.Num is Numeric';
ok 1.Num ~~ Real, '1.Num is Real';

# L

is_approx 1/2, 0.5, '1/2 Rat literal';
isa_ok 1/2, Rat, '1/2 produces a Rat';
ok 1/2 ~~ Numeric, '1/2 is Numeric';
ok 1/2 ~~ Real, '1/2 is Real';
isa_ok 0x01/0x02, Rat, 'same with hexadecimal numbers';

ok 0x01/0x02 / (0x01/0x02) == 1, 'same with hexadecimal numbers';

# L

isa_ok 1+1i, Complex, '1+1i is a Complex literal';
ok 1+1i ~~ Numeric, '1+1i is Numeric';
nok 1+1i ~~ Real, '1+1i is not Real';

# RT #74640
is_approx 3.14159265358979323846264338327950288419716939937510e0,
          3.141592, 'very long Num literals';

# RT #73236
{
    eval_lives_ok '0.' ~ '0' x 19,
        'parsing 0.000... with 19 decimal places lives';

    eval_lives_ok '0.' ~ '0' x 20,
        'parsing 0.000... with 20 decimal places lives';

    eval_lives_ok '0.' ~ '0' x 63,
        'parsing 0.000... with 63 decimal places lives';

    eval_lives_ok '0.' ~ '0' x 66,
        'parsing 0.000... with 66 decimal places lives';

    eval_lives_ok '0.' ~ '0' x 1024,
        'parsing 0.000... with 1024 decimal places lives';
}

# RT #70600
#?niecza todo 'exactly rounded Str->Num without FatRat'
ok 0e999999999999999 == 0, '0e999999999999 equals zero';

done;

# vim: ft=perl6 sw=4 ts=4 expandtab
rakudo-2013.12/t/spec/S02-literals/pair-boolean.t0000664000175000017500000000174512224265625020733 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

The ? case definitely shouldn't be a syntax error.  The next question is
what the correct boolean value is for a Pair; always-true is now assumed
for consistency with the "one-key hash" semantics.

=end pod

#L

plan 6;

# See thread "Stringification, numification, and booleanification of pairs" on
# p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/23148">

{
    my $true_pair  = 1 => 1;
    my $false_pair = 1 => 0;

    lives_ok { ?$true_pair  }, 'Taking the boolean of a true pair should live';
    lives_ok { ?$false_pair }, 'Taking the boolean of a false pair should live';
    ok  (try { ?$true_pair  }), 'A pair with a true value is true';
    ok  (try { ?$false_pair }), 'A pair with a false value is also true';

    is $true_pair  ?? 1 !! 0, 1, 'Ternary on a true pair returns first option';
    is $false_pair ?? 1 !! 0, 1, 'Ternary on a false pair returns first option too';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/pairs.t0000664000175000017500000001242312224265625017474 0ustar  moritzmoritzuse v6;

use Test;

# L

# See thread "Demagicalizing pair" on p6l started by Luke Palmer,
# L<"http://article.gmane.org/gmane.comp.lang.perl.perl6.language/4778/"> and
# L<"http://colabti.de/irclogger/irclogger_log/perl6?date=2005-10-09,Sun&sel=528#l830">.
# Also see L<"http://www.nntp.perl.org/group/perl.perl6.language/23532">.

# To summarize:
#   foo(a => 42);  # named
#   foo(:a(42));   # named
#
#   foo((a => 42));  # pair passed positionally
#   foo((:a(42)));   # pair passed positionally
#
#   my $pair = (a => 42);
#   foo($pair);      # pair passed positionally
#   foo(|$pair);     # named
#
#   S02 lists ':a' as being equivlaent to a => 1, so
#   the type of the value of that pair is Int, not Bool

plan 79;

sub f1n (:$a) { $a.WHAT.gist }
sub f1p ( $a) { $a.WHAT.gist }
{
    is f1n(a => 42), Int.gist, "'a => 42' is a named";
    is f1n(:a(42)),  Int.gist, "':a(42)' is a named";

    is f1n(:a),      Bool.gist,  "':a' is a named";
    is f1n(:!a),     Bool.gist,  "':!a' is also named";

    is f1p("a"   => 42), Pair.gist, "'\"a\" => 42' is a pair";
    is f1p(("a") => 42), Pair.gist, "'(\"a\") => 42' is a pair";
    is f1p((a   => 42)), Pair.gist, "'(a => 42)' is a pair";
    is f1p(("a" => 42)), Pair.gist, "'(\"a\" => 42)' is a pair";
    is f1p((:a(42)),  ), Pair.gist, "'(:a(42))' is a pair";
    is f1p((:a),      ), Pair.gist,  "'(:a)' is a pair";
    is f1p((:!a),     ), Pair.gist,  "'(:a)' is also a pair";
    is f1n(:a[1, 2, 3]), Array.gist, ':a[...] constructs an Array value';
    is f1n(:a{b => 3}),  Hash.gist, ':a{...} constructs a Hash value';
}

{
    my $p = :a[1, 2, 3];
    is $p.key, 'a', 'correct key for :a[1, 2, 3]';
    is $p.value.join('|'), '1|2|3', 'correct value for :a[1, 2, 3]';
}

{
    my $p = :a{b => 'c'};
    is $p.key, 'a', 'correct key for :a{ b => "c" }';
    is $p.value.keys, 'b', 'correct value for :a{ b => "c" } (keys)';
    is $p.value.values, 'c', 'correct value for :a{ b => "c" } (values)';
}

sub f2 (:$a!) { WHAT($a) }
{
    my $f2 = &f2;

    isa_ok f2(a     => 42), Int, "'a => 42' is a named";
    isa_ok f2(:a(42)),      Int, "':a(42)' is a named";
    isa_ok f2(:a),          Bool,"':a' is a named";

    #?niecza skip "Action method escape:sym<&> not yet implemented"
    isa_ok(&f2.(:a),        Bool, "in '&f2.(:a)', ':a' is a named");
    isa_ok $f2(:a),         Bool, "in '\$f2(:a)', ':a' is a named";
    isa_ok $f2.(:a),        Bool, "in '\$f2.(:a)', ':a' is a named";

    #?pugs 7 skip 'Missing required parameters'
    dies_ok { f2("a"   => 42) }, "'\"a\" => 42' is a pair";
    dies_ok { f2(("a") => 42) }, "'(\"a\") => 42' is a pair";
    dies_ok { f2((a   => 42)) }, "'(a => 42)' is a pair";
    dies_ok { f2(("a" => 42)) }, "'(\"a\" => 42)' is a pair";
    dies_ok { f2((:a(42)))    }, "'(:a(42))' is a pair";
    dies_ok { f2((:a))        }, "'(:a)' is a pair";
    dies_ok { &f2.((:a))       }, 'in \'&f2.((:a))\', \'(:a)\' is a pair';

    #?pugs 4 skip 'Missing required parameters'
    dies_ok { $f2((:a))       }, "in '\$f2((:a))', '(:a)' is a pair";
    dies_ok { $f2.((:a))      }, "in '\$f2.((:a))', '(:a)' is a pair";
    dies_ok { $f2(((:a)))     }, "in '\$f2(((:a)))', '(:a)' is a pair";
    dies_ok { $f2.(((:a)))    }, "in '\$f2.(((:a)))', '(:a)' is a pair";
}

sub f3 ($a) { WHAT($a) }
{
    my $pair = (a => 42);

    isa_ok f3($pair),  Pair, 'a $pair is not treated magically...';
    ##?pugs todo '[,]'
    #?rakudo skip 'prefix:<|>'
    isa_ok f3(|$pair), Int,    '...but |$pair is';
}

sub f4 ($a)    { WHAT($a) }
sub get_pair () { (a => 42) }
{

    isa_ok f4(get_pair()),  Pair, 'get_pair() is not treated magically...';
    #?rakudo skip 'reduce meta op'
    isa_ok f4(|get_pair()), Int,    '...but |get_pair() is';
}

sub f5 ($a) { WHAT($a) }
{
    my @array_of_pairs = (a => 42);

    isa_ok f5(@array_of_pairs), Array,
        'an array of pairs is not treated magically...';
    #?rakudo todo 'prefix:<|>'
    #?niecza todo
    isa_ok f5(|@array_of_pairs), Array, '...and |@array isn\'t either';
}

sub f6 ($a) { WHAT($a) }
{

    my %hash_of_pairs = (a => "str");

    ok (f6(%hash_of_pairs)).does(Hash), 'a hash is not treated magically...';
    #?pugs todo '[,]'
    #?rakudo todo 'reduce meta op'
    #?niecza todo
    isa_ok f6([,] %hash_of_pairs), Str,  '...but [,] %hash is';
}

sub f7 (:$bar!) { WHAT($bar) }
#?pugs skip 'Missing required parameter'
{
    my $bar = 'bar';

    dies_ok { f7($bar => 42) },
        "variables cannot be keys of syntactical pairs (1)";
}

sub f8 (:$bar!) { WHAT($bar) }
#?pugs skip 'Missing required parameter'
{
    my @array = ;

    dies_ok { f8(@array => 42) },
        "variables cannot be keys of syntactical pairs (2)";
}

sub f9 (:$bar!) { WHAT($bar) }
#?pugs skip 'Missing required parameter'
{
    my $arrayref = ;

    dies_ok { f9($arrayref => 42) },
        "variables cannot be keys of syntactical pairs (3)";
}

#?pugs todo
{
    is (a => 3).elems, 1, 'Pair.elems';
}

# RT #74948
#?DOES 32
{
    for <
        self rand time now YOU_ARE_HERE package module class role
        grammar my our state let temp has augment anon supersede
        sub method submethod macro multi proto only regex token
        rule constant enum subset
    > { 
        is eval("($_ => 1).key"), $_, "Pair with '$_' as key" 
    }
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/pod.t0000664000175000017500000000272712224265625017146 0ustar  moritzmoritzuse v6;

use Test;

plan 5;

# See "=begin DATA" at the end of file.

# L
{
    ok %=pod{'DATA'}, '=begin DATA works and %=pod defined';

    my $line = get %=pod;
    is($line, "hello, world!", q/%=pod{'DATA'} can be read/);
}

# L
{
    # XXX isn't the iterator exhausted already, since it's been used
    # previously?
    my $line = get $=DATA;
    is($line, "hello, world!", q/$=DATA contains the right string/);
}

# L
{
    is @=DATA.elems, 1, '@=DATA contains a single elem';
    is @=DATA[0], "hello, world!\n", '@=DATA[0] contains the right value';
}

# The following commented-out tests are currnetly unspecified:
# others will be added later, or you can do it.

#ok eval('
#=begin DATA LABEL1
#LABEL1.1
#LABEL1.2
#LABEL1.3
#=end DATA

#=begin DATA LABEL2
#LABEL2.1
#LABEL2.2
#=end DATA
#'), "=begin DATA works", :todo;

#is(eval('%=DATA[0]'), 'LABEL1.1', '@=DATA[0] is correct', :todo);
#is(eval('%=DATA[2]'), 'LABEL1.3', '@=DATA[2] is correct', :todo);
#is(eval('~ %=DATA'), 'LABEL1.1LABEL1.2LABEL1.3', '~ %=DATA is correct', :todo);

#is(eval('~ $=LABEL2'), 'LABEL2.1LABEL2.2', '~ $=LABEL2 is correct', :todo);
#is(eval('$=LABEL2[1]'), 'LABEL2.2', '$=LABEL2[1] is correct', :todo);

=begin DATA
hello, world!
=end DATA

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/quoting.t0000664000175000017500000003665112224265625020055 0ustar  moritzmoritzuse v6;
use Test;
plan 155;

my $foo = "FOO";
my $bar = "BAR";

=begin description

Tests quoting constructs as defined in L

Note that non-ASCII tests are kept in quoting-unicode.t

=todo

* q:b and other interpolation levels (half-done)
* meaningful quotations (qx, rx, etc)
* interpolation of scalar, array, hash, function and closure syntaxes
* q : a d verb s // parsing

=end description

# L
{
    my $s = q{ foo bar };
    is $s, ' foo bar ', 'string using q{}';
}

{
    is q{ { foo } }, ' { foo } ',   'Can nest curlies in q{ .. }';
    is q{{ab}},      'ab',          'Unnested single curlies in q{{...}}';
    is q{{ fo} }},   ' fo} ',       'Unnested single curlies in q{{...}}';
    is q{{ {{ } }} }}, ' {{ } }} ', 'Can nest double curlies in q{{...}}';
}

{
    is q{\n},        '\n',          'q{..} do not interpolate \n';
    ok q{\n}.chars == 2,            'q{..} do not interpolate \n';
    is q{$x},        '$x',          'q{..} do not interpolate scalars';
    ok q{$x}.chars == 2,            'q{..} do not interpolate scalars';
}

#?pugs skip 'parsefail'
{
    is Q{\n},        '\n',          'Q{..} do not interpolate \n';
    ok Q{\n}.chars == 2,            'Q{..} do not interpolate \n';
    is Q{$x},        '$x',          'Q{..} do not interpolate scalars';
    ok Q{$x}.chars == 2,            'Q{..} do not interpolate scalars';
    is Q {\\},       '\\\\',        'Q {..} quoting';
}

#?pugs skip 'parsefail'
{
    ok Q{\\}.chars == 2,            'Q{..} do not interpolate backslashes';
}

# L
{
    my @q = ();
    @q = (q/$foo $bar/);
    is(+@q, 1, 'q// is singular');
    is(@q[0], '$foo $bar', 'single quotes are non interpolating');
};

{ # and its complement ;-)
    my @q = ();
    @q = '$foo $bar';
    is(+@q, 1, "'' is singular");
    is(@q[0], '$foo $bar', 'and did not interpolate either');
};

# L
# non interpolating single quotes with nested parens
{
    my @q = ();
    @q = (q (($foo $bar)));
    is(+@q, 1, 'q (()) is singular');
    is(@q[0], '$foo $bar', 'and nests parens appropriately');
};

# L
{ # non interpolating single quotes with nested parens
    my @q = ();
    @q = (q ( ($foo $bar)));
    is(+@q, 1, 'q () is singular');
    is(@q[0], ' ($foo $bar)', 'and nests parens appropriately');
};

# L
{ # q() is bad
    my @q;
    sub q { @_ }
    @q = q($foo,$bar);
    is(+@q, 2, 'q() is always sub call');
};

# L forms/:q>
#?pugs skip 'parsefail'
{ # adverb variation
    my @q = ();
    @q = (Q:q/$foo $bar/);
    is(+@q, 1, "Q:q// is singular");
    is(@q[0], '$foo $bar', "and again, non interpolating");
};

{ # nested brackets
    my @q = ();
    @q = (q[ [$foo $bar]]);
    is(+@q, 1, 'q[] is singular');
    is(@q[0], ' [$foo $bar]', 'and nests brackets appropriately');
};

{ # nested brackets
    my @q = ();
    @q = (q[[$foo $bar]]);
    is(+@q, 1, 'q[[]] is singular');
    is(@q[0], '$foo $bar', 'and nests brackets appropriately');
};

# L forms/qq:>
{ # interpolating quotes
    my @q = ();
        @q = qq/$foo $bar/;
    is(+@q, 1, 'qq// is singular');
    is(@q[0], 'FOO BAR', 'variables were interpolated');
};

{ # "" variation
    my @q = ();
        @q = "$foo $bar";
    is(+@q, 1, '"" is singular');
    is(@q[0], "FOO BAR", '"" interpolates');
};

# L forms/:qq>
#?pugs skip 'parsefail'
{ # adverb variation
    my @q = ();
    @q = Q:qq/$foo $bar/;
    is(+@q, 1, "Q:qq// is singular");
    is(@q[0], "FOO BAR", "blah blah interp");
};

# L

{ # \qq[] constructs interpolate in q[]
    my ( @q1, @q2, @q3, @q4 ) = ();
    @q1 = q[$foo \qq[$bar]];
    is(+@q1, 1, "q[...\\qq[...]...] is singular");
    is(@q1[0], '$foo BAR', "and interpolates correctly");

    @q2 = '$foo \qq[$bar]';
    is(+@q2, 1, "'...\\qq[...]...' is singular");
    is(@q2[0], '$foo BAR', "and interpolates correctly");

    @q3 = q[$foo \q:s{$bar}];
    is(+@q3, 1, 'q[...\\q:s{...}...] is singular');
    is(@q3[0], '$foo BAR', "and interpolates correctly");

    @q4 = q{$foo \q/$bar/};
    is(+@q4, 1, 'q{...\\q/.../...} is singular');
    is(@q4[0], '$foo $bar', "and interpolates correctly");
}

# quote with \0 as delimiters, forbidden by STD
# but see L
#?rakudo todo 'retriage'
#?pugs todo
{
    eval_dies_ok "(q\0foo bar\0)";
}

{ # traditional quote word
    my @q = ();
    @q = (qw/$foo $bar/);
    is(+@q, 2, "qw// is plural");
    is(@q[0], '$foo', "and non interpolating");
    is(@q[1], '$bar', "...");
};

# L
{ # angle brackets
    my @q = ();
    @q = <$foo $bar>;
    is(+@q, 2, "<> behaves the same way");
    is(@q[0], '$foo', 'for interpolation too');
    is(@q[1], '$bar', '...');
};

{ # angle brackets
    my @q = ();
    @q = < $foo $bar >;
    is(+@q, 2, "<> behaves the same way, with leading (and trailing) whitespace");
    is(@q[0], '$foo', 'for interpolation too');
    is(@q[1], '$bar', '...');
};


{ # adverb variation
    my @q = ();
    @q = (q:w/$foo $bar/);
    is(+@q, 2, "q:w// is like <>");
    is(@q[0], '$foo', "...");
    is(@q[1], '$bar', "...");
};

{ # whitespace sep aration does not break quote constructor
  # L
    my @q = ();
    @q = (q :w /$foo $bar/);
    is(+@q, 2, "q :w // is the same as q:w//");
    is(@q[0], '$foo', "...");
    is(@q[1], '$bar', "...");
};

{ # qq:w,Interpolating quote constructor with words adverb
  # L
    my (@q1, @q2) = ();
    @q1 = qq:w/$foo "gorch $bar"/;
    @q2 = qq:words/$foo "gorch $bar"/;

    is(+@q1, 3, 'qq:w// correct number of elements');
    is(+@q2, 3, 'qq:words correct number of elements');

    is(~@q1, 'FOO "gorch BAR"', "explicit quote word interpolates");
    is(~@q2, 'FOO "gorch BAR"', "long form output is the same as the short");
};

#?niecza todo
{ # qq:ww, interpolating L
  # L
    my (@q1, @q2, @q3, @q4) = ();
    @q1 = qq:ww/$foo "gorch $bar"/;
    @q2 = «$foo "gorch $bar"»; # french
    @q3 = <<$foo "gorch $bar">>; # texas
    @q4 = qq:quotewords/$foo "gorch $bar"/; # long

    is(+@q1, 2, 'qq:ww// correct number of elements');
    is(+@q2, 2, 'french double angle');
    is(+@q3, 2, 'texas double angle');
    is(+@q4, 2, 'long form');

    is(~@q1, 'FOO gorch BAR', "explicit quote word interpolates");
    is(~@q2, 'FOO gorch BAR', "output is the same as french");

    # L
    is(~@q3, 'FOO gorch BAR', ", texas quotes");
    is(~@q4, 'FOO gorch BAR', ", and long form");
};

{
    my $rt65654 = 'two words';
    is «a $rt65654 z».elems,   4, 'interpolate variable with spaces (French)';
    is <>.elems, 4, 'interpolate variable with spaces (Texas)';
}

#?rakudo todo '«...»'
#?niecza todo
{
    #L
    # Pugs was having trouble with this.  Fixed in r12785.
    my ($x, $y) = ;
    ok(«$x $y» === , "«$x $y» interpolation works correctly");
};


# L
{ # qw, interpolating, shell quoting
    my (@q1, @q2) = ();
    my $gorch = "foo bar";

    @q1 = «$foo $gorch $bar»;
    is(+@q1, 4, "4 elements in unquoted «» list");
    is(@q1[2], "bar", '$gorch was exploded');
    is(@q1[3], "BAR", '$bar was interpolated');

    @q2 = «$foo "$gorch" '$bar'»;
    #?niecza 3 todo
    is(+@q2, 3, "3 elementes in sub quoted «» list");
    is(@q2[1], $gorch, 'second element is both parts of $gorch, interpolated');
    is(@q2[2], '$bar', 'single quoted $bar was not interpolated');
};

#?pugs skip 'parsefail'
{ # Q L
    my @q = ();

    @q = (Q/foo\\bar$foo/);

    is(+@q, 1, "Q// is singular");
    is(@q[0], "foo\\\\bar\$foo", "special chars are meaningless"); # double quoting is to be more explicit
};

# L
{
  # <<:Pair>>
    my @q = <<:p(1)>>;
    #?niecza todo
    #?pugs todo
    is(@q[0].perl, (:p(1)).perl, "pair inside <<>>-quotes - simple");

    @q = <<:p(1) junk>>;
    #?niecza todo
    #?pugs todo
    is(@q[0].perl, (:p(1)).perl, "pair inside <<>>-quotes - with some junk");
    is(@q[1], 'junk', "pair inside <<>>-quotes - junk preserved");

    @q = <<:def>>;
    #?niecza todo
    #?pugs todo
    is(@q[0].perl, (:def).perl, ":pair in <<>>-quotes with no explicit value");

    @q = "(eval failed)";
    try { eval '@q = <<:p>>;' };
    #?niecza todo
    #?pugs todo
    is(@q[0].perl, (p => "moose").perl, ":pair");
};

{ # weird char escape sequences
    is("\c97", "a", '\c97 is "a"');
    is("\c102oo", "foo", '\c102 is "f", works next to other letters');

    is("\c123", chr(123), '"\cXXX" and chr XXX are equivalent');
    is("\c[12]3", chr(12) ~ "3", '\c[12]3 is the same as chr(12) concatenated with "3"');
    is("\c[12] 3", chr(12) ~ " 3", 'respects spaces when interpolating a space character');
    is("\c[13,10]", chr(13) ~ chr(10), 'allows multiple chars');

    is("\x41", "A", 'hex interpolation - \x41 is "A"');
    is("\o101", "A", 'octal interpolation - \o101 is also "A"' );
    
    #?rakudo 3 skip '\c@ etc'
    is("\c@", "\0", 'Unicode code point "@" converts correctly to "\0"');
    is("\cA", chr(1), 'Unicode "A" is #1!');
    is("\cZ", chr(26), 'Unicode "Z" is chr 26 (or \c26)');
}

{ # simple test for nested-bracket quoting, per S02
    my $hi = q<>;
    is($hi, "hi", 'q<> is "hi"');
}

is( q<< <> >>, ' <> ', 'nested <> quotes (RT #66888)' );

# L
# q:to
{
    my $t;
    $t = q:to /STREAM/;
Hello, World
STREAM

    is $t.subst(/\r/, '', :g), "Hello, World\n", "Testing for q:to operator.";

$t = q:to /结束/;
Hello, World
结束

    is $t.subst(/\r/, '', :g), "Hello, World\n", "Testing for q:to operator. (utf8)";
}

# Q
#?pugs skip 'Q'
{
    my $s1 = "hello"; #OK not used
    my $t1 = Q /$s1, world/;
    is $t1, '$s1, world', "Testing for Q operator.";

    my $s2 = "你好"; #OK not used
    my $t2 = Q /$s2, 世界/;
    is $t2, '$s2, 世界', "Testing for Q operator. (utf8)";
}

# q:b
#?pugs skip 'parsefail'
{
    my $t = q:b /\n\n\n/;
    is $t, "\n\n\n", "Testing for q:b operator.";
    is q:b'\n\n', "\n\n", "Testing q:b'\\n'";
    ok qb"\n\t".chars == 2, 'qb';
    is Qb{a\nb},  "a\nb", 'Qb';
    is Q:b{a\nb}, "a\nb", 'Q:b';
    is Qs:b{\n},  "\n",   'Qs:b';
}

# q:x
{
    my $result = $*OS ~~ /:i win32/ ?? "hello\r\n" !! "hello\n";
    is q:x/echo hello/, $result, "Testing for q:x operator.";
}
# utf8

{
    # 一 means "One" in Chinese.
    is q:x/echo 一/, "一\n", "Testing for q:x operator. (utf8)";
}

#?pugs todo
{
    my $world = 'world';
    ok qq:x/echo hello $world/ ~~ /^'hello world'\n$/, 'Testing qq:x operator';
}

#?rakudo todo 'q:x assigned to array'
#?niecza todo ':x'
#?pugs todo
{
    my @two_lines = q:x/echo hello ; echo world/;
    is @two_lines, ("hello\n", "world\n"), 'testing q:x assigned to array';
}

#?rakudo todo 'q:x assigned to array'
#?niecza todo ':x'
#?pugs todo
{
    my $hello = 'howdy';
    my @two_lines = qq:x/echo $hello ; echo world/;
    is @two_lines, ("$hello\n", "world\n"), 'testing qq:x assigned to array';
}


# L
# q:h
#?niecza todo
{
    # Pugs can't parse q:h currently.
    my %t = (a => "perl", b => "rocks");
    my $s;
    $s = q:h /%t<>/;
    is $s, ~%t, "Testing for q:h operator.";
}

# q:f
#?niecza skip '& escape'
{
    my sub f { "hello" };
    my $t = q:f /&f(), world/;
    is $t, f() ~ ", world", "Testing for q:f operator.";

    sub f_utf8 { "你好" };
    $t = q:f /&f_utf8(), 世界/;
    is $t, f_utf8() ~ ", 世界", "Testing for q:f operator. (utf8)";
}

# q:c
{
    my sub f { "hello" };
    my $t = q:c /{f}, world/;
    is $t, f() ~ ", world", "Testing for q:c operator.";
}

# q:a
{
    my @t = qw/a b c/;
    my $s = q:a /@t[]/;
    is $s, ~@t, "Testing for q:a operator.";
}

# q:s
{
    my $s = "someone is laughing";
    my $t = q:s /$s/;
    is $t, $s, "Testing for q:s operator.";

    $s = "有人在笑";
    $t = q:s /$s/;
    is $t, $s, "Testing for q:s operator. (utf8)";
}

# multiple quoting modes
{
    my $s = 'string';
    my @a = ;
    my %h = (foo => 'bar'); #OK not used
    is(q:s:a'$s@a[]%h', $s ~ @a ~ '%h', 'multiple modifiers interpolate only what is expected');
}

# shorthands:
#?niecza skip '& escape, zen slices'
#?pugs skip 'parsefail'
{
    my $alpha = 'foo';
    my $beta  = 'bar';
    my @delta = ;
    my %gamma = (abc => 123);
    sub zeta {42};

    is(qw[a b], , 'qw');
    #?rakudo todo 'quoting adverbs'
    is(qww[$alpha $beta], , 'qww');
    is(qq[$alpha $beta], 'foo bar', 'qq');
    #?rakudo todo 'quoting adverbs'
    is(Qs[$alpha @delta[] %gamma<>], 'foo @delta %gamma', 'Qs');
    #?rakudo todo 'quoting adverbs'
    is(Qa[$alpha @delta[] %gamma<>], '$alpha ' ~ @delta ~ ' %gamma', 'Qa');
    #?rakudo todo 'quoting adverbs'
    is(Qh[$alpha @delta[] %gamma<>], '$alpha @delta ' ~ %gamma, 'Qh');
    is(Qf[$alpha &zeta()], '$alpha 42', 'Qf');
    is(Qb[$alpha\t$beta], '$alpha	$beta', 'Qb');
    is(Qc[{1+1}], 2, 'Qc');
}

# L
{
    is('test\\', "test\\", "backslashes at end of single quoted string");
    is 'a\\b\''.chars, 4, 'backslash and single quote';
}

{
    isa_ok rx/foo/, Regex, 'rx/.../';
    isa_ok rx{foo}, Regex, 'rx{...}';
    isa_ok rx:i{foo}, Regex, 'rx:i{...}';
    isa_ok rx:ignorecase{foo}, Regex, 'rx:i{...}';
    isa_ok rx:s{foo}, Regex, 'rx:i{...}';
    isa_ok rx:sigspace{foo}, Regex, 'rx:i{...}';
    #?pugs todo
    eval_dies_ok 'rx:unknown{foo}', 'rx:unknown dies';
    #?pugs todo
    eval_dies_ok 'rx:g{foo}', 'g does not make sense on rx//';
}

{
    my $var = 'world';
    is  qx/echo world/.chomp, "world", 'qx';
    #?pugs skip 'multi ok'
    is qqx/echo $var/.chomp,  "world", 'qqx';
    # RT #78874
    is qx/echo world/.trans('wd' => 'WD').chomp, "WorlD", "qx doesn't return a Parrot string";
}

# RT #75320
{
    is "$foo >>", "FOO >>", 'quoting and >> (RT 75320, 1)';
    is "$foo>>",  "FOO>>",  'quoting and >> (RT 75320, 2)';
}

# RT #85506
{
    my $a = 42;
    is "$a []", '42 []', 'can handle [ after whitespace after var interpolation';
}

# RT #90124
#?pugs todo
eval_dies_ok q["@a<"], 'unclosed quote after array variable is an error';

# RT #114090
#?pugs skip 'parsefail'
is "foo $( my $x = 3 + 4; "bar" ) baz", 'foo bar baz', 'declaration in interpolation';

#115272
#?niecza todo "Weird quoting issue"
#?pugs   todo "Weird quoting issue"
is <<<\>'n'>>.join('|'), '<>|n', 'texas quotes edge case';

#?pugs todo
#?niecza todo
{
    $_ = 'abc';
    /a./;
    is $/, 'ab', '/.../ literals match in void context';
    # rx does the same: http://irclog.perlgeek.de/perl8/2013-02-20#i_6479200
    rx/b./;
    is $/, 'bc', 'rx/.../ literals match in void context';
}

# RT #75320
{
    my $x = 42;
    is "$x >> ", "42 >> ", '>> in interpolation is not shift operator';
}


done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/quoting-unicode.t0000664000175000017500000000614712240452120021460 0ustar  moritzmoritzuse v6;
use Test;
plan 73;

#L
# TODO:
#
# * review shell quoting semantics of «»
# * arrays in «»

#L Forms/halfwidth corner brackets>
#?rakudo skip 'Parse failure'
#?niecza skip 'Parse failure'
{
    my $s = 「this is a string\n」;
    is $s, Q[this is a string\n],
        'Shortform for Q[...] is 「...」 (HALFWIDTH LEFT/RIGHT CORNER BRACKET)';
}

{
    my $s = q「this is a string」;
    is $s, 'this is a string',
        'q-style string with LEFT/RIGHT CORNER BRACKET';
}

{
    my $s = q『blah blah blah』;
    is $s, 'blah blah blah',
        'q-style string with LEFT/RIGHT WHITE CORNER BRACKET';
}

{
    my $s = q⦍blah blah blah⦎;
    is $s, 'blah blah blah',
        'q-style string with LEFT SQUARE BRACKET WITH TICK IN TOP CORNER and
RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER(U+298D/U+298E)';
}

{
    my $s = q〝blah blah blah〞;
    is $s, 'blah blah blah',
        'q-style string with REVERSED DOUBLE PRIME QUOTATION MARK and
 DOUBLE PRIME QUOTATION MARK(U+301D/U+301E)';
}

#?pugs skip 'hangs'
#?DOES 63
{
    my %ps_pe = (
            '(' => ')', '[' => ']', '{' => '}', '༺' => '༻', '༼' => '༽',
            '᚛' => '᚜', '⁅' => '⁆', '⁽' => '⁾', '₍' => '₎', '〈' => '〉',
            '❨' => '❩', '❪' => '❫', '❬' => '❭', '❮' => '❯', '❰' => '❱',
            '❲' => '❳', '❴' => '❵', '⟅' => '⟆', '⟦' => '⟧', '⟨' => '⟩',
            '⟪' => '⟫', '⦃' => '⦄', '⦅' => '⦆', '⦇' => '⦈', '⦉' => '⦊',
            '⦋' => '⦌', '⦍' => '⦎', '⦏' => '⦐', '⦑' => '⦒', '⦓' => '⦔',
            '⦕' => '⦖', '⦗' => '⦘', '⧘' => '⧙', '⧚' => '⧛', '⧼' => '⧽',
            '〈' => '〉', '《' => '》', '「' => '」', '『' => '』',
            '【' => '】', '〔' => '〕', '〖' => '〗', '〘' => '〙',
            '〚' => '〛', '〝' => '〞', '﴾' => '﴿', '︗' => '︘', '︵' => '︶',
            '︷' => '︸', '︹' => '︺', '︻' => '︼', '︽' => '︾',
            '︿' => '﹀', '﹁' => '﹂', '﹃' => '﹄', '﹇' => '﹈',
            '﹙' => '﹚', '﹛' => '﹜', '﹝' => '﹞', '（' => '）',
            '［' => '］', '｛' => '｝', '｟' => '｠', '｢' => '｣',
            );
    for keys %ps_pe {
        next if $_ eq '('; # skip '(' => ')' because q() is a sub call
        my $string = 'q' ~ $_ ~ 'abc' ~ %ps_pe{$_};
        is eval($string), 'abc', $string ~ sprintf(' (U+%X/U+%X)',$_.ord,%ps_pe{$_}.ord);
    }
}

{
    my @list = 'a'..'c';

    my $var = @list[ q（2） ];
    is $var, 'c',
        'q-style string with FULLWIDTH LEFT/RIGHT PARENTHESIS';

    $var = @list[ q《0》];
    is $var, 'a',
        'q-style string with LEFT/RIGHT DOUBLE ANGLE BRACKET';

    $var = @list[q〈1〉];
    is $var, 'b', 'q-style string with LEFT/RIGHT ANGLE BRACKET';
}

# RT #66498
{
    eval_dies_ok "q\c[SNOWMAN].\c[COMET]",
        "Can't quote a string with a snowman and comet (U+2603 and U+2604)";
    eval_dies_ok "'RT 66498' ~~ m\c[SNOWMAN].\c[COMET]",
        "Can't quote a regex with a snowman and comet (U+2603 and U+2604)";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/radix.t0000664000175000017500000002161512224265625017470 0ustar  moritzmoritzuse v6;
use Test;

plan 134;

# L">
is( :10<0>,   0, 'got the correct int value from decimal 0' );
is( :10<1>,   1, 'got the correct int value from decimal 1' );
is( :10<2>, 0d2, 'got the correct int value from decimal 2' );
is( :10<3>, 0d3, 'got the correct int value from decimal 3' );

# the answer to everything
is(     42,   0d42, '42 and 0d42 are the same'      );
is( :10<42>,    42, ':10<42> and 42 are the same'   );
is( :10<42>,  0d42, ':10<42> and 0d42 are the same' );

# L
# setting the default radix

{
    is(:10('01110') ,  0d1110, ":10('01110') is default decimal");
    #?pugs 4 todo "unimpl"
    is(:10('0b1110'), 0b1110, ":10('0b1110') overrides default decimal");
    is(:10('0x20'),   0x20, ":10('0x20') overrides default decimal");
    is(:10('0o377'),  0o377, ":10('0o255') overrides default decimal");
    is(:10('0d37'),   0d37, ":10('0d37') overrides default decimal");

    # RT #107756
    #?pugs todo
    dies_ok { :10(42) }, ':10() really wants a string, not a number';
}


# L">
# L">

# 0 - 9 is the same int
is(:16<0>, 0, 'got the correct int value from hex 0');
is(:16<1>, 1, 'got the correct int value from hex 1');
is(:16<2>, 2, 'got the correct int value from hex 2');
is(:16<3>, 3, 'got the correct int value from hex 3');
is(:16<4>, 4, 'got the correct int value from hex 4');
is(:16<5>, 5, 'got the correct int value from hex 5');
is(:16<6>, 6, 'got the correct int value from hex 6');
is(:16<7>, 7, 'got the correct int value from hex 7');
is(:16<8>, 8, 'got the correct int value from hex 8');
is(:16<9>, 9, 'got the correct int value from hex 9');

# check uppercase vals
is(:16, 10, 'got the correct int value from hex A');
is(:16, 11, 'got the correct int value from hex B');
is(:16, 12, 'got the correct int value from hex C');
is(:16, 13, 'got the correct int value from hex D');
is(:16, 14, 'got the correct int value from hex E');
is(:16, 15, 'got the correct int value from hex F');

# check lowercase vals
is(:16, 10, 'got the correct int value from hex a');
is(:16, 11, 'got the correct int value from hex b');
is(:16, 12, 'got the correct int value from hex c');
is(:16, 13, 'got the correct int value from hex d');
is(:16, 14, 'got the correct int value from hex e');
is(:16, 15, 'got the correct int value from hex f');

# check 2 digit numbers
is(:16<10>, 16, 'got the correct int value from hex 10');
is(:16<20>, 32, 'got the correct int value from hex 20');
is(:16<30>, 48, 'got the correct int value from hex 30');
is(:16<40>, 64, 'got the correct int value from hex 40');
is(:16<50>, 80, 'got the correct int value from hex 50');

# check 3 digit numbers
is(:16<100>, 256, 'got the correct int value from hex 100');

# check some weird versions
is(:16, 255, 'got the correct int value from hex FF');
is(:16, 255, 'got the correct int value from (mixed case) hex fF');

# some random mad up hex strings (these values are checked against perl5)
is :16<2_F_A_C_E_D>,  0x2FACED, 'got the correct int value from hex 2_F_A_C_E_D';

# L
is(:16('0b1110'), 0xB1110, ":16('0b1110') uses b as hex digit"  );
is(:16('0d37'),   0x0D37,  ":16('0d37') uses d as hex digit"     );

# L
{
    is :16('0d10'),      0xd10, ':16("0d..") is hex, not decimal';
    is(:16('0fff'),      0xfff, ":16('0fff') defaults to hexadecimal");
#?pugs 2 todo 'feature'
    is(:16('0x20'),      0x20, ":16('0x20') stays hexadecimal");
    is(:16('0o377'),    0o377, ":16('0o255') converts from octal");
}

# L
# It seems odd that the numbers on the inside on the <> would be a mix of
# bases. Maybe I've misread the paragraph -- brian
#?pugs todo 'feature'
{
    is_approx(:16 * 16**8, :16,
        'Powers outside same as powers inside');
}

# L

is_approx(:16,  0xDEAD_BEEF + 0xFACE / 65536.0, 'Fractional base 16 works' );


# L">
# L">

# 0 - 7 is the same int
is(:8<0>, 0, 'got the correct int value from oct 0');
is(:8<1>, 1, 'got the correct int value from oct 1');
is(:8<2>, 2, 'got the correct int value from oct 2');
is(:8<3>, 3, 'got the correct int value from oct 3');
is(:8<4>, 4, 'got the correct int value from oct 4');
is(:8<5>, 5, 'got the correct int value from oct 5');
is(:8<6>, 6, 'got the correct int value from oct 6');
is(:8<7>, 7, 'got the correct int value from oct 7');

# check 2 digit numbers
is(:8<10>,  8, 'got the correct int value from oct 10');
is(:8<20>, 16, 'got the correct int value from oct 20');
is(:8<30>, 24, 'got the correct int value from oct 30');
is(:8<40>, 32, 'got the correct int value from oct 40');
is(:8<50>, 40, 'got the correct int value from oct 50');

# check 3 digit numbers
is(:8<100>, 64, 'got the correct int value from oct 100');

# check some weird versions
is(:8<77>,      63, 'got the correct int value from oct 77');
is(:8<377>,     255, 'got the correct int value from oct 377');
is(:8<400>,     256, 'got the correct int value from oct 400');
is(:8<177777>, 65535, 'got the correct int value from oct 177777');
is(:8<200000>, 65536, 'got the correct int value from oct 200000');

# L
# setting the default radix

#?pugs todo 'feature'
#?rakudo todo "Some question of what this form should actually do"
#?niecza todo ":radix() NYI"
{
    is(:8('0b1110'),  0o14, ':8(0b1110) converts from decimal');
    is(:8('0x20'),    0o32, ':8(0x20) converts from decimal');
    is(:8('0o377'),  0o255, ':8(0o255) stays decimal');
    is(:8('0d37'),    0o37, ':8(0d37) converts from decimal');
}


# L">

is(:2<0>,     0, 'got the correct int value from bin 0');
is(:2<1>,     1, 'got the correct int value from bin 1');
is(:2<10>,    2, 'got the correct int value from bin 10');
is(:2<1010>, 10, 'got the correct int value from bin 1010');

is(
    :2<11111111111111111111111111111111>,
    0xFFFFFFFF,
    'got the correct int value from bin 11111111111111111111111111111111');


# L
# setting the default radix

#?pugs todo 'feature'
{
    is(:2('0b1110'),  0d14, ':2<0b1110> stays binary');
    is(:2('0x20'),    0d32, ':2<0x20> converts from hexadecimal');
    is(:2('0o377'),  0d255, ':2<0o255> converts from octal');
    is(:2('0d37'),    0d37, ':2<0d37> converts from decimal');
}

# L
eval_dies_ok '0b1.1e10', 'Ambiguous, illegal syntax doesn\'t work';

# L
# probably don't need a test, but I'll write tests for any example :)
is( :2<1.1> *  2 ** 10,                  1536, 'binary number to power of 2'  );
is( :2<1.1> * :2<10> ** :2<10>,             6, 'multiplication and exponentiation' );

# L
# these should be the same values as the previous tests
{
    #?pugs todo "todo"
    is( :2<1.1*2**10>,                   1536, 'Power of two in <> works');
    #?rakudo todo "Really?!"
    #?niecza skip "WTF?"
    #?pugs skip "todo"
    is( 2«1.1*:2<10>**:2<10>»,    6, 'Powers of two in <<>> works');
}

# Tests for the :x[  ] notations
# L
#?niecza skip ":radix[] NYI"
{
    is( :60[12,34,56],     12 * 3600 + 34 * 60 + 56, 'List of numbers works' );
    is( :100[3,'.',14,16],     3.1416,         'Decimal point in list works' );

    is :100[10,10],      1010, "Adverbial form of base 100 integer works";
    is :100[10,'.',10], 10.10, "Adverbial form of base 100 fraction works";
}

# What follows are tests that were moved here from t/syntax/numbers/misc.t
# feel free to merge them inline into the other tests

# Ambiguity tests, see thread "Ambiguity of parsing numbers with
# underscores/methods" on p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22769">
# Answer from Luke:
#   I think we should go with the method call semantics in all of the ambiguous
#   forms, mostly because "no such method: Int::e5" is clearer than silently
#   succeeding and the error coming up somewhere else.
dies_ok { 2.e123 },    "2.e123 parses as method call";
dies_ok { 2.foo  },    "2.foo  parses as method call";

is  +'00123', 123, "Leading zeroes stringify correctly";

#?pugs 3 todo "todo"
eval_dies_ok ':2<2>',   ':2<2> is illegal';
eval_dies_ok ':10<3a>', ':10<3a> is illegal';
eval_dies_ok ':0<0>', ':0<...> is illegal';

for 2..36 {
    #?pugs skip "todo"
    is eval(":{$_}<11>"), $_ + 1, "Adverbial form of base $_ works";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/string-interpolation.t0000664000175000017500000000272612224265625022556 0ustar  moritzmoritzuse v6;
use Test;
plan 14;

# L

{
    # The code of the closure takes a reference to the number 1, discards it
    # and finally returns 42.
    is "{\01;42}", "42", '{\\01 parses correctly (1)';    #OK not indicate octal
    is "{;\01;42}", "42", '{\\01 parses correctly (2)';    #OK not indicate octal
    is "{;;;;;;\01;42}", "42", '{\\01 parses correctly (3)';    #OK not indicate octal
}

{
    is "{\1;42}", "42", '{\\1 parses correctly (1)';
    is "{;\1;42}", "42", '{\\1 parses correctly (2)';
    is "{;;;;;;\1;42}", "42", '{\\1 parses correctly (3)';
}


{
    # interpolating into double quotes results in a Str
    my $a = 3;
    ok "$a" ~~ Str, '"$a" results in a Str';
    ok "{3}" ~~ Str, '"{3}" results in a Str';

    # RT #76234
    is "{}", '', 'Interpolating an empty block is cool';
}

{
    my $rt65538_in = qq[line { (1,2,3).min }
line 2
line { (1,2,3).max } etc
line 4
];
    my $rt65538_out = qq[line 1
line 2
line 3 etc
line 4
];
    is $rt65538_in, $rt65538_out, 'interpolation does not trim newlines';
}

{
    #?pugs todo
    is 'something'.new, '', '"string literal".new just creates an empty string';
    #?pugs skip 'Cannot cast from VObject'
    is +''.new, 0, '... and that strinig works normally';
}

# RT #79568
{
    my $w = 'work';
    is "this should $w\", 'this should work', 'backslash after scalar';
}

# RT #115508
{
    is ord("\a"), 7, "alarm"
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/sub-calls.t0000664000175000017500000000442512224265625020246 0ustar  moritzmoritzuse v6;

use Test;

plan 20;

# TODO: *really* need a better smartlink
# L

#?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 }

# These tests are for parse-fails:
# (They check that the parser doesn't abort, but they might still parse
#  incorrectly.)
{
    sub foo(*@args, *%named) { 1 }    #OK not used

    ok eval(q/foo;      /), 'call with no args, no parens';
    ok eval(q/foo();    /), 'call with no args, has parens';
    ok eval(q/&foo.();   /), 'call with no args, has dot and parens';
    ok eval(q/&foo\ .(); /), 'call with no args, has long dot and parens';

    ok eval(q/foo 1;    /), 'call with one arg, no parens';
    ok eval(q/foo(1);   /), 'call with one arg, has parens';
    ok eval(q/&foo.(1);  /), 'call with one arg, has dot and parens';
    ok eval(q/&foo\ .(1);/), 'call with one arg, has long dot and parens';
    #?pugs todo 'unspecced'
    dies_ok { eval(q/foo'bar'; /) }, 'call with one arg, has no space and no parens';

    ok eval(q/foo 1, 2; /), 'call with two args, no parens';
    ok eval(q/foo(1, 2);/), 'call with two args, has parens';

    #?pugs todo
    dies_ok { eval(q/foo:bar;  /) }, 'call with adverb after no space';
    ok eval(q/foo :bar; /), 'call with adverb after space';

    ok eval(q/foo(:bar);  /), 'call with adverb in parens';
    ok eval(q/&foo.(:bar); /), 'call with adverb in dotted-parens';
    ok eval(q/&foo\.(:bar);/), 'call with adverb in long-dotted parens';
}


# These tests are for mis-parses:
{
    sub succ($x) { $x + 1 }

    is(eval(q/succ  (1+2) * 30;/),  91, "parens after space aren't call-parens");
    #?pugs todo
    dies_ok { eval q/succ .(1+2) * 30;/ } , 'parsed as method call on $_';
}
{
    sub first() { "first" }

    is(eval(q/first.uc/), 'FIRST', '`first.second` means `(first()).second()`');
}

{
    is(eval(q/"hello".substr: 1, 2/), "el", "listop method");

    # foo $bar.baz: quux
    # should be (and is currently) interpreted as:
    # foo($bar.baz(quux))
    # where the alternate interpretation can be achieved by:
    # foo ($bar.baz): quux
    # which is interpreted as
    # $bar.baz.foo(quux)
    # but we need tests, tests, tests! XXX
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/subscript.t0000664000175000017500000000076112224265625020376 0ustar  moritzmoritzuse v6;

use Test;

plan 2;

{ # from t/03-operator.t, as noted by afbach on #perl6, 2005-03-06
    my @oldval  = (5, 8, 12);
    my @newval1 = (17, 15, 14); # all greater
    my @newval2 = (15, 7,  20); # some less some greater
    lives_ok({ all(@newval2) < any(@oldval); all(@newval1) > all(@oldval) }, "parses correctly, second statement is true");

    my %hash = ("foo", "bar");
    #?pugs todo
    dies_ok { eval '%hash ; 1'}, '%hash \s+  doesnt parse';
};

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/types.t0000664000175000017500000000160412224265625017521 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 7;

eval_dies_ok 'class A { }; class A { }', "Can't redeclare a class";
eval_lives_ok 'class G { ... }; class G { }', 'can redeclare stub classes';
eval_dies_ok 'class B is C { }', "Can't inherit from a non-existing class";
eval_dies_ok 'class D does E { }', "Can't do a non-existing role";
eval_dies_ok 'my F $x;', 'Unknown types in type constraints are an error';

# integration tests - in Rakudo some class names from Parrot leaked through,
# so you couldn't name a class 'Task' - RT #61128

eval_lives_ok 'class Task { has $.a }; Task.new(a => 3 );',
              'can call a class "Task" - RT 61128';

# L

eval_dies_ok q[caffeine(eval('sub caffeine($a){~$a}'))],
        'Post declaration necessary';

# vim: ft=perl6

rakudo-2013.12/t/spec/S02-literals/underscores.t0000664000175000017500000000251012224265625020706 0ustar  moritzmoritzuse v6;

use Test;


# L

=begin pod

_ should be allowed in numbers

But according to L, only between two digits.

=end pod

plan 19;

is 1_0, 10, "Single embedded underscore works";

eval_dies_ok '1__0',  "Multiple embedded underscores fail";

eval_dies_ok '_10',   "Leading underscore fails";

eval_dies_ok '10_',   "Trailing underscore fails";

eval_dies_ok '10_.0', "Underscore before . fails";

eval_dies_ok '10._0', "Underscore after . fails";

eval_dies_ok '10_e1', "Underscore before e fails";

eval_dies_ok '10e_1', "Underscore after e fails";

eval_dies_ok '10_E1', "Underscore before E fails";

eval_dies_ok '10E_1', "Underscore after E fails";

ok 3.1_41 == 3.141, "Underscores work with floating point after decimal";

ok 10_0.8 == 100.8, "Underscores work with floating point before decimal";

is 0xdead_beef, 0xdeadbeef, "Underscores work with hex";

is 0b1101_1110_1010_1101_1011_1110_1110_1111, 0xdeadbeef, "Underscores work with binary";

is 2e0_1, 20, "Underscores work in the argument for e";

ok 2.1_23 == 2.123, "2.1_23 parses as number";

dies_ok { 2._foo },    "2._foo parses as method call";
dies_ok { 2._123 },    "2._123 parses as method call";
dies_ok { 2._e23 },    "2._23  parses as method call";

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-literals/version.t0000664000175000017500000000314012237474612020041 0ustar  moritzmoritzuse v6;
use Test;

is v1.2.3, '1.2.3', 'version literal stringification';
is v1.2.3+, '1.2.3+', 'version literal stringification';
is v1.*.3,  '1.*.3',  'version literal stringification';
ok  v1.2.3 eqv v1.2.3, 'eqv works on version literals (+)';
nok v5.2.3 eqv v1.2.3, 'eqv works on version literals (-)';
nok v1.2+  eqv v1.2,   '+ makes a difference in eqv';
ok  v1.2   === v1.2,   'version literals are value types';
nok v1.2   === v1.3,   '=== (-)';
ok  v1.2   ~~  v1.2,   'smart-matching (same)';
nok v1.2   ~~  v6.2,   'smart-matching (different)';
ok  v1.2.0 ~~  v1.2,   'smart-matching treats trailing 0 correctly (left)';
ok  v1.2   ~~  v1.2.0, 'smart-matching treats trailing 0 correctly (right)';
ok  v1.2   ~~  v1.0+,  'smart-matching and plus (+1)';
ok  v1.2   ~~  v1.2+,  'smart-matching and plus (+2)';
ok  v5     ~~  v1.2+,  '+ scopes to the whole version, not just the last chunk';
ok  v5.2.3 ~~  v5.2.*, '* wildcard (1+)';
ok  v5.2   ~~  v5.2.*, '* wildcard (2+)';
nok v5.2.3 ~~  v5.3.*, '* wildcard (-)';
nok v1.2   ~~  v1.3+,  'smart-matching and plus (-)';
ok  v1.2.3 ~~  v1,     'smart-matching only cares about the length of the LHS';
nok v1.2.3 ~~  v2,     '... but it can still fail';
is  v1.2   cmp  v1.2,   Same,     'cmp: Same';
is  v1.2   cmp  v3.2,   Less, 'cmp: Less';
is  v1.2   cmp  v0.2,   More, 'cmp: More';
is  v1.2   cmp  v1.10,  Less, "cmp isn't Stringy-based";
#?rakudo 3 todo "trailing zeroes fail"
ok  v1.2   eqv  v1.2.0, 'trailing zeroes are equivalent';
ok  v1.2.0 eqv  v1.2,   'trailing zeroes are equivalent';
ok  v1.2.0 eqv  v1.2.0.0.0.0.0,   'trailing zeroes are equivalent';

done;

rakudo-2013.12/t/spec/S02-magicals/78258.t0000664000175000017500000000010112224265625017002 0ustar  moritzmoritzuse v6;

BEGIN @*INC.push: 't/spec/S02-magicals/';
use UsedEnv;

rakudo-2013.12/t/spec/S02-magicals/args.t0000664000175000017500000000147612224265625017261 0ustar  moritzmoritzuse v6;
use Test;

plan 6;

isa_ok @*ARGS, Array, '@*ARGS is an Array';
is_deeply @*ARGS, [], 'by default @*ARGS is empty array';

lives_ok { @*ARGS = 1, 2 }, '@*ARGS is writable';

BEGIN { @*INC.push: 't/spec/packages' }

use Test::Util;

is_run 'print @*ARGS.join(q[, ])', :args[1, 2, "foo"],
    {
        out => '1, 2, foo',
        err => '',
        status => 0,
    }, 'providing command line arguments sets @*ARGS';

is_run 'for @*ARGS[ 1 ..^ +@*ARGS ] { .say };', :args[1, 'two', 'three'],
    {
        out => "two\nthree\n",
        err => '',
        status => 0,
    }, 'postcircumfix:<[ ]> works for @*ARGS';

is_run 'my @a = @*ARGS; for @a[ 1 ..^ +@*ARGS ] { .say };', :args[1, 'two', 'three'],
    {
        out => "two\nthree\n",
        err => '',
        status => 0,
    }, 'can copy @*ARGS to array.';

done;
rakudo-2013.12/t/spec/S02-magicals/block.t0000664000175000017500000000064212224265625017411 0ustar  moritzmoritzuse v6;

use Test;

=begin description

This tests the &?BLOCK magical from Synopsis 6

=end description

# L object>

plan 1;


# L
# L object/tail-recursion on an anonymous block:>
my $anonfactorial = -> Int $n { $n < 2 ?? 1 !! $n * &?BLOCK($n-1) };

my $result = $anonfactorial(3);
is($result, 6, 'the $?BLOCK magical worked');

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/config.t0000664000175000017500000000147412241704255017564 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

Config Tests

If this test fails because your osname is not listed here, please add it.
But don't add other osnames just because you know of them. That way we can
get a list of osnames that have actually passed tests.

=end kwid

plan 5;

# $?OS is the OS we were compiled in.
#?rakudo skip 'unimpl $?OS'
ok $?OS, "We were compiled in '$?OS'";

# $*OS is the OS we are running
ok $*OS, "We are running under '$*OS'";

my $osnames = lc any ;

#?rakudo skip 'unimpl $?OS'
ok $?OS.lc eq $osnames, "we know of the OS we were compiled in";

ok $*OS.lc eq $osnames, "we know of the OS we are running under";

# like $*OS, this is tested in perlver.t but that test is not included
ok $*OSVER, '$*OSVER is present';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/dollar_bang.t0000664000175000017500000000423112224265625020561 0ustar  moritzmoritzuse v6;

use Test;

plan 16;

=begin desc

This test tests the C<$!> builtin.

=end desc

# L

try { die "foo" };
ok defined($!), 'error in try makes $! defined';
try { 1 };
#?niecza todo
nok $!.defined, 'successful try { } resets $!';

try { 1.nonexisting_method; };
ok $!.defined, 'Calling a nonexisting method defines $!';

my $called;
sub foo(Str $s) { return $called++ };    #OK not used
my @a;
try { eval 'foo(@a,@a)' };
ok $!.defined, 'Calling a subroutine with a nonmatching signature sets $!';
ok !$called, 'The subroutine also was not called';

try { (1 div 0).Str };
ok $!.defined, 'Dividing one by zero sets $!';

sub incr ( $a is rw ) { $a++ };
try { incr(19) };
ok $!.defined, 'Modifying a constant sets $!';

try {
    try {
        die 'qwerty';
    }
    ok ~($!) ~~ /qwerty/, 'die sets $! properly';
    die; # use the default argument
}
#?rakudo todo 'stringification of $!'
#?niecza todo
ok ~($!) ~~ /qwerty/, 'die without argument uses $! properly';

# RT #70011
#?niecza skip 'undefine and Exception NYI'
{
    undefine $!;
    try { die('goodbye'); }
    ok defined( $!.perl ), '$! has working Perl 6 object methods after try';
    ok ($!.WHAT ~~ Exception), '$! is Exception object after try';
    # - S04-statements/try.t tests $! being set after try.
    # - S29-context/die.t tests $! being set after die.
    # - also tested more generically above.
    # So no need to test the value of #! again here.
    #is $!, 'goodbye', '$! has correct value after try';
    ok ($!), '$! as boolean works (true)';

    try { eval q[ die('farewell'); ] };
    ok defined($!.perl), '$! has working Perl 6 object methods after eval';
    ok ($!.WHAT ~~ Exception), '$! is Exception object after eval';
    # Although S29-context/die.t tests $! being set after die, it's not
    # from within an eval, so we test the eval/die combination here.
    # As that file (and also S04-statements/try.t) do equality comparisons
    # rather than pattern matches, we check equality here, too.
    is $!, 'farewell', '$! has correct value after eval';

    try { 1; }
    ok (! $!), '$! as boolean works (false)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/dollar-underscore.t0000664000175000017500000000323312224265625021742 0ustar  moritzmoritzuse v6;

# Tests for a bug uncovered when Jesse Vincent was testing
# functionality for Patrick Michaud
# TODO: add smartlinks, more tests

use Test;

plan 9;


my @list = ('a');


# Do pointy subs send along a declared param?

for @list -> $letter { is( $letter , 'a', 'can bind to variable in pointy') }

#?rakudo skip 'for() with nullary block'
#?niecza skip 'infinite loop' 
{
    # Do pointy subs send along an implicit param? No!
    for @list -> {
        isnt($_, 'a', '$_ does not get set implicitly if a pointy is given')
    }
}

# Hm. PIL2JS currently dies here (&statement_control: passes one argument
# to the block, but the block doesn't expect any arguments). Is PIL2JS correct?

# Do pointy subs send along an implicit param even when a param is declared? No!
for @list -> $letter {
    isnt( $_ ,'a', '$_ does not get set implicitly if a pointy is given')
}

{
    my $a := $_; $_ = 30;
    for 1 .. 3 { $a++ };
    is $a, 33, 'outer $_ increments' ;
}

{
    my @mutable_array = 1..3;
    lives_ok { for @mutable_array { $_++ } }, 'default topic is rw by default';
}

#RT #113904
{
    $_ = 1;
    my $tracker = '';

    for 11,12 -> $a {
        if $_ == 1 { $tracker ~= "1 : $_|"; $_ = 2; }
        else {       $tracker ~= "* : $_" }
    }

    is $tracker, '1 : 1|* : 2',
        'Two iterations of a loop share the same $_ if it is not a formal parameter';
}

{
     # Inner subs get a new $_, not the OUTER::<$_>
     $_ = 1;
     sub foo {
         #?niecza todo
         ok !defined($_), '$_ starts undefined';
         $_ = 2;
         is $_, 2,  'now $_ is 2';
     }
     foo();
     #?niecza todo
     is $_, 1, 'outer $_ is unchanged'
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/env.t0000664000175000017500000000554512241704255017112 0ustar  moritzmoritzuse v6;

# Tests for magic variables

use Test;
BEGIN @*INC.push: 't/spec/packages/';
use Test::Util;
# L
plan 17;

=begin desc

= DESCRIPTION

Tests for %*ENV

Tests that C<%*ENV> can be read and written to and that
child processes see the modified C<%*ENV>.

=end desc

# It must not be empty at startup.
ok +%*ENV.keys, '%*ENV has keys';

# %*ENV should be able to get copied into another variable.
my %vars = %*ENV;
is +%vars.keys, +%*ENV.keys, '%*ENV was successfully copied into another variable';

# XXX: Should modifying %vars affect the environment? I don't think so, but, of
# course, feel free to change the following test if I'm wrong.
%vars = "42";
ok %*ENV ne "42",
  'modifying a copy of %*ENV didn\'t affect the environment';

# Similarily, I don't think creating a new entry in %vars should affect the
# environment:
diag '%*ENV=' ~ (%*ENV // "");
ok !defined(%*ENV), "there's no env variable 'PUGS_ROCKS'";
%vars = "42";
diag '%*ENV=' ~ (%*ENV // "");
ok !defined(%*ENV), "there's still no env variable 'PUGS_ROCKS'";

my ($redir,$squo) = (">", "'");

# RT #77906 - can we modify the ENV?
my $expected = 'Hello from subprocess';
%*ENV = $expected;
# Note that the "?" preceding the "(" is necessary, because we need a Bool,
# not a junction of Bools.
is %*ENV, $expected,'%*ENV is rw';

%*ENV:delete;
#?niecza todo ":delete"
ok(%*ENV:!exists, 'We can remove keys from %*ENV');

#?niecza todo ":!exists"
ok %*ENV:!exists, "exists() returns false on a not defined env var";

# %ENV must not be imported by default
#?pugs todo 'bug'
eval_dies_ok("%ENV", '%ENV not visible by default');

# following doesn't parse yet
#?rakudo skip 'import keyword'
#?niecza skip 'Action method statement_control:import not yet implemented'
{
    # It must be importable
    import PROCESS <%ENV>;
    ok +%ENV.keys, 'imported %ENV has keys';
}

# Importation must be lexical
#?pugs todo 'bug'
{
    try { eval "%ENV" };
    ok $!.defined, '%ENV not visible by after lexical import scope';
    1;
}

# RT #78256
{
    nok %*ENV.defined, 'non-existing vars are undefined';
    nok %*ENV:exists, 'non-existing vars do not exist';

}

#?niecza skip "Cannot call is_run; none of these signatures match"
{
    %*ENV = 'def';
    is_run 'print %*ENV',
    {
        status  => 0,
        out     => 'def',
        err     => '',
    },
    'ENV members persist to child processes';
}

# RT #77458
#?pugs 2 todo 'Cant modify constant item: VUndef'
{
    %*ENV = 'def';
    ok %*ENV.gist ~~ /abc/, '%*ENV.gist generates something with abc in it';
    ok %*ENV.perl ~~ /abc/, '%*ENV.perl generates something with abc in it';
}

# RT #117951
{
    ok $%*ENV, "itemizer works on %*ENV.";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/file_line.t0000664000175000017500000000047612224265625020252 0ustar  moritzmoritzuse v6;


use Test;

plan 2;

# L
is($?LINE, 9, '$?LINE works');

# L
# try to be robust for implementations that use Win32 file paths, or
# absolute paths, or whatever
ok($?FILE ~~ rx/'S02-magicals'<[\/\\]>'file_line.t'/, '$?FILE works');


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/perlver.t0000664000175000017500000000054412224265625017777 0ustar  moritzmoritzuse v6;
use Test;

plan 6;

# L

ok $?PERLVER, '$?PERLVER is present';
ok $*PERLVER, '$*PERLVER is present';

ok $?OS, '$?OS is present';
ok $*OS, '$*OS is present';

ok $?OSVER, '$?OSVER is present';
ok $*OSVER, '$*OSVER is present';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/pid.t0000664000175000017500000000112212224265625017065 0ustar  moritzmoritzuse v6;
use Test;
BEGIN { @*INC.push: 't/spec/packages' }
use Test::Util;

=begin description

Test that C< $*PID > in this process is different from
C< $*PID > in the child process.
L/>

=end description

plan 1;

#?rakudo.jvm todo "this test may need to be skipped when using the eval server"
is_run 'say $*PID',
    {
        out => -> $p { $p > 0 && $p != $*PID },
        err => '',
        status => 0,
    }, 'my $*PID is different from a child $*PID';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/progname.t0000664000175000017500000000155312241704255020125 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

ok(PROCESS::<$PROGRAM_NAME> ~~ / t['/'|'\\']spec['/'|'\\']S02'-'magicals['/'|'\\']progname'.'\w+$/, "progname var matches test file path");
ok($*PROGRAM_NAME ~~ / t['/'|'\\']spec['/'|'\\']S02'-'magicals['/'|'\\']progname'.'\w+$/, "progname var accessible as context var");

# NOTE:
# above is a junction hack for Unix and Win32 file
# paths until the FileSpec hack is working - Stevan
# changed junction hack in test 2 to regex for Rakudo fudged filename - mberends

#?niecza todo
lives_ok { $*PROGRAM_NAME = "coldfusion" }, '$*PROGRAM_NAME is assignable';

# RT #116164
{
    use lib 't/spec/packages';
    use Test::Util;
    is_run 'print $*PROGRAM_NAME', {
        out => -> $x { $x !~~ /IGNOREME/ },
    },
    :compiler-args['-IGNOREME'],
    :args['IGNOREME'],
    '$*PROGRAM_NAME is not confused by compiler options';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/subname.t0000664000175000017500000000123712224265625017752 0ustar  moritzmoritzuse v6;

use Test;

plan 4;


# L object/current routine name>
# L
sub foo { return &?ROUTINE.name }
is(foo(), '&Main::foo', 'got the right routine name in the default package');

{
    # This testcase might be really redundant
    package Bar {
	sub bar { return &?ROUTINE.name }
	is(bar(), '&Bar::bar', 'got the right routine name outside the default package');
    }
}

my $bar = sub { return &?ROUTINE.name };
is($bar(), '', 'got the right routine name (anon-block)');

my $baz = try { &?ROUTINE.name };
#?pugs todo
ok(not(defined $baz), '&?ROUTINE.name not defined outside of a routine');

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/sub.t0000664000175000017500000000213612224265625017110 0ustar  moritzmoritzuse v6;

use Test;

=begin comment

This tests the &?ROUTINE magical value

=end comment

plan 6;

# L object>
# L
sub factorial { @_[0] < 2 ?? 1 !! @_[0] * &?ROUTINE(@_[0] - 1) }

my $result1 = factorial(3);
is($result1, 6, 'the &?ROUTINE magical works correctly');

my $factorial = sub { @_[0] < 2 ?? 1 !! @_[0] * &?ROUTINE(@_[0] - 1) };
my $result2 = $factorial(3);
is($result2, 6, 'the &?ROUTINE magical works correctly in anon-subs');

sub postfix: (Int $n) { $n < 2 ?? 1 !! $n * &?ROUTINE($n - 1) }
my $result3 = 3!!!;
is($result3, 6, 'the &?ROUTINE magical works correctly in overloaded operators' );

#?pugs skip 'ROUTINE'
{
    my $variable;
    my regex foo { a { $variable = &?ROUTINE; } }
    my token bar { b { $variable = &?ROUTINE; } }
    my rule baz  { c { $variable = &?ROUTINE; } }
    "a" ~~ &foo;
    is $variable, &foo, '&?ROUTINE is correct inside a regex';
    "b" ~~ &bar;
    is $variable, &bar, '&?ROUTINE is correct inside a token';
    "c" ~~ &baz;
    is $variable, &baz, '&?ROUTINE is correct inside a rule';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-magicals/UsedEnv.pm60000664000175000017500000000016412224265625020126 0ustar  moritzmoritzmodule UsedEnv {
    use Test;
    plan 1;
    ok %*ENV:exists, "env exists in use (RT #78258)";
    done;
}

rakudo-2013.12/t/spec/S02-magicals/vm.t0000664000175000017500000000015612224265625016741 0ustar  moritzmoritzuse Test;

plan 3;

ok $*VM, '$*VM exists';
ok $*VM.perl, '$*VM.perl works';
ok $*VM.gist, '$*VM.gist works';
rakudo-2013.12/t/spec/S02-names/bare-sigil.t0000664000175000017500000000200112224265625017647 0ustar  moritzmoritzuse v6;
use Test;

plan 10;

# L

lives_ok { my $ }, 'basic bare sigil $';
lives_ok { my @ }, 'basic bare sigil @';
#?niecza skip 'bare sigil % generates postcircumfix:<()> exception'
lives_ok { my % }, 'basic bare sigil %';

is (my $ = "foo"), "foo", 'initialized bare sigil scalar $';
ok (my @ = 1, 2, 3), 'initialized bare sigil array @';
ok (my % = baz => "luhrman"), 'initialized bare sigil hash %';

# RT #116521
# 'state' with anonymous scalars works more like 'my' in Rakudo
#?niecza skip "++(state \$) yields (3, 3, 3) instead of (1, 2, 3)"
{
    sub f { ++state $ ; }
    is (f, f, f), (1, 2, 3), "anonymous 'state' bare sigil scalar retains state";
    sub g { ++state $ = 3; }
    is (g, g, g), (4, 5, 6), "anonymous 'state' bare sigil scalar is initialized once";
}

{
    sub d { state $i = 0; (state @).push( $i++ ) }
    d;
    is +d(), 2, "anonymous 'state' bare sigil array retains state";
    is d()[2], 2, "anonymous 'state' bare sigil array can grow";
}rakudo-2013.12/t/spec/S02-names/caller.t0000664000175000017500000000620512241704255017101 0ustar  moritzmoritzuse v6;

use Test;

plan 15;

{
  my $a is dynamic = 9;
  my $sub = sub { $CALLER::a };

  {
    my $a is dynamic = 3;
    is $sub(), 3, 'basic $CALLER:: works';
  }
} #1

{
  my $a is dynamic = 9;
  my $sub2 = sub { $CALLER::a };
  my $sub1 = sub {
    my $a is dynamic = 10;
    $sub2();
  };

  {
    my $a is dynamic = 11;
    is $sub1(), 10, '$CALLER:: with nested subs works';
  }
} #1

{
  my $get_caller = sub { return sub { $CALLER::CALLER::a } };
  my $sub1 = sub {
    my $a is dynamic = 3;
    $get_caller();
  };
  my $sub2 = sub {
    my $a is dynamic = 5;
    $get_caller();
  };

  my $result_of_sub1 = $sub1();
  my $result_of_sub2 = $sub2();

  # We can't use the more elegant dies_ok here as it would influence $CALLER::
  # calculation.
  ok !(try { $result_of_sub1() }), '$CALLER::CALLER:: is recalculated on each access (1)';
  ok !(try { $result_of_sub2() }), '$CALLER::CALLER:: is recalculated on each access (2)';
} #2

# L
{
  # $_ is always implicitly declared "is dynamic".
  my sub foo () { $CALLER::_ }
  my sub bar () {
    $_ = 42;
    foo();
  }

  $_ = 23;
  is bar(), 42, '$_ is implicitly declared "is dynamic" (1)';
} #1

{
  # $_ is always implicitly declared "is dynamic".
  # (And, BTW, $_ is lexical.)
  my sub foo () { $_ = 17; $CALLER::_ }
  my sub bar () {
    $_ = 42;
    foo();
  }

  $_ = 23;
  is bar(), 42, '$_ is implicitly declared "is dynamic" (2)';
} #1

#?pugs skip 'Cannot cast from VStr "success" to VCode (VCode)'
{
  # ...but other vars are not
  my sub foo { my $abc = 17; $CALLER::abc }	#OK not used
  my sub bar {
    my $abc = 42;	#OK not used
    foo();
    'success'
  }

  my $abs = 23;
  #?niecza todo 'strictness'
  nok (try bar()) eq 'success',
    'vars not declared "is dynamic" are not accessible via $CALLER::';
} #1

# Vars declared with "is dynamic" default to being rw in the creating scope and
# readonly when accessed with $CALLER::.
{
  my $foo is dynamic = 42;
  $foo++;
  is $foo, 43, '"is dynamic" vars are rw in the creating scope (1)';
} #1

{
  my $foo is dynamic = 42;
  { $foo++ }
  is $foo, 43, '"is dynamic" vars are rw in the creating scope (2)';
} #1

#?pugs skip "Can't modify constant item: VInt 42"
{
  my sub modify { $CALLER::foo++; 'success' }
  my $foo is dynamic ::= 42;
  nok (try modify()) eq 'success', '"::=" vars are ro when accessed with $CALLER::';
} #1

{
  my sub modify { $CALLER::_++ }
  $_ = 42;
  modify();
  is $_, 43,             '$_ is implicitly rw (2)';
} #1

{
  my sub modify { $CALLER::foo++ }
  my $foo is dynamic = 42;
  modify();
  is $foo, 43,
      '"is dynamic" vars declared "is rw" are rw when accessed with $CALLER:: (2)';
} #1

{
  my sub get_foo { try { $DYNAMIC::foo } }
  my $foo is dynamic = 42;

  #?pugs todo
  is get_foo(), 42, '$DYNAMIC:: searches call stack';
} #1

# Rebinding caller's variables -- legal?
{
  my $other_var = 23;
  my sub rebind_foo { $CALLER::foo := $other_var }
  my $foo is dynamic = 42;

  rebind_foo();
  is $foo, 23,               'rebinding $CALLER:: variables works (2)';
  $other_var++;
  is $foo, 24,               'rebinding $CALLER:: variables works (3)';
} #2

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/identifier.t0000664000175000017500000000577112224265625017774 0ustar  moritzmoritzuse v6;
use Test;

plan 22;

# L

{
    sub don't($x) { !$x }

    ok don't(0),    "don't() is a valid sub name (1)";
    ok !don't(1),   "don't() is a valid sub name (2)";

    my $a'b'c = 'foo';
    is $a'b'c, 'foo', "\$a'b'c is a valid variable name";

    eval_dies_ok  q[sub foo-($x) { ... }],
                 'foo- (trailing hyphen) is not an identifier';
    eval_dies_ok  q[sub foo'($x) { ... }],
                 "foo' (trailing apostrophe) is not an identifier";
    eval_dies_ok  q[sub foob'4($x) { ... }],
                 "foob'4 is not a valid identifier (not alphabetic after apostrophe)";
    eval_dies_ok  q[sub foob-4($x) { ... }],
                 "foob-4 is not a valid identifier (not alphabetic after hyphen)";
    eval_lives_ok q[sub foo4'b($x) { ... }],
                 "foo4'b is a valid identifier";
}

{
    # This confirms that '-' in a sub name is legal.
    my sub foo-bar { 'foo-bar' }
    is foo-bar(), 'foo-bar', 'can call foo-bar()';
}

# RT #64656
#?pugs skip 'extra space found after &is() ...'
{
    my sub do-check { 'do-check' }
    is do-check(), 'do-check', 'can call do-check()';
}

{
    # check with a different keyword
    sub if'a($x) {$x}
    is if'a(5), 5, "if'a is a valid sub name";
}

#?pugs skip 'parsefail'
{
    my sub sub-check { 'sub-check' }
    is sub-check(), 'sub-check', 'can call sub-check';
}

{
    my sub method-check { 'method-check' }
    is method-check(), 'method-check', 'can call method-check';
}

#?pugs skip "no such subroutine: '&check'"
{
    my sub last-check { 'last-check' }
    is last-check(), 'last-check', 'can call last-check';
}

#?pugs skip "no such subroutine: '&check'"
{
    my sub next-check { 'next-check' }
    is next-check(), 'next-check', 'can call next-check';
}

#?pugs skip "no such subroutine: '&check'"
{
    my sub redo-check { 'redo-check' }
    is redo-check(), 'redo-check', 'can call redo-check';
}

# RT #65804
#?pugs skip 'parsefail'
{
    sub sub($foo) { $foo }
    is sub('RT #65804'), 'RT #65804', 'sub named "sub" works';
}

# RT #68358
#?pugs todo
{
    my ($x);
    sub my($a) { $a + 17 }
    $x = 5;
    is my($x), 22, 'call to sub named "my" works';
}

# RT #72898
{
    sub loop($a) { $a + 1 }
    is loop(5), 6, 'sub named "loop" works';
}

# RT #77218
# Rakudo had troubles with identifiers whos prefix is an alphanumeric infix
# operator; for example 'sub order' would fail because 'order' begins with
# 'or'
#?pugs skip 'parsefail'
{
    my $res;
    sub order-beer($what) { $res = "a $what please!" };
    order-beer('Pils');
    is $res, 'a Pils please!',
        'can call subroutines whos name begin with an alphabetic infix (or)';

    my $tempo;
    sub andante() { $tempo = 'walking pace' }
    andante;

    is $tempo, 'walking pace',
        'can call subroutines whos name begin with an alphabetic infix (and)';

    # RT #75710
    eval_lives_ok q{our sub xyz($abc) { $abc }; xyz(1);},
        'can call subroutine which starts with infix x';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/indirect.t0000664000175000017500000000134512224265625017444 0ustar  moritzmoritzuse v6;
use Test;

plan 6;

{
    my constant name = 'TestName';
    class ::(name) {
        method f() { 42 }
    }
    is TestName.f, 42, 
       'can declare and use a class with indirect (but constant) name';
    is ::(name).^name, 'TestName',
        'and it reports the right name';
}

{
    my constant name = 'a';
    sub ::(name) ($x) { $x + 38 }
    is a(4), 42, 'indirect sub name works';
    is &a.name, 'a', 'and the sub knows its name';
}

{
    class A {
        method ::('indirect') {
            42
        }
        method ::('with space') {
            23
        }
    }
    is A.indirect,       42, 'can declare method with indirect name';
    is A."with space"(), 23, 'can declare indirect method name with space';
}
rakudo-2013.12/t/spec/S02-names/is_default.t0000664000175000017500000002232012224265625017756 0ustar  moritzmoritzuse v6;
use Test;

plan 114;

# L, 42, "uninitialized untyped hash element should have its default";
    is %a.VAR.default, 42, 'is the default set correctly for %a';
    lives_ok { %a++ }, "should be able to update untyped hash element";
    is %a, 43, "update of untyped hash element to 43 was successful";
    lives_ok { %a = Nil }, "assign Nil to untyped hash element";
    is %a, 42, "untyped hash element returned to its default with Nil";
    lives_ok { %a = 314 }, "should be able to update untyped hash element";
    is %a, 314, "update of untyped hash element to 314 was successful";
    lives_ok { undefine %a }, "undefine untyped hash element";
    is %a, 42, "untyped hash element returned to its default with undefine";

    my %b is default(42) = o => 768;
    is %b, 768, "untyped hash element should be initialized";
    is %b.VAR.default, 42, 'is the default set correctly for %b';

    my %c is default(Nil);
    ok %c.VAR.default === Nil, 'is the default set correctly for %c';
    lives_ok { %c++ }, 'should be able to increment untyped variable';
    is %c, 1, "untyped variable should be incremented";
    lives_ok { %c = Nil }, "able to assign Nil to untyped variable";
    ok %c === Nil, 'is the default value correctly reset for %c';

    my %d is default(Nil) = o => 353;
    is %d, 353, "untyped variable should be initialized";
    ok %d.VAR.default === Nil, 'is the default set correctly for %d';
} #19

#?pugs   skip "Int is default NYI"
#?niecza skip "Int is default NYI"
# typed
{
    my Int %a is default(42);
    is %a, 42, "uninitialized typed hash element should have its default";
    is %a.VAR.default, 42, 'is the default set correctly for Int %a';
    lives_ok { %a++ }, "should be able to update typed hash element";
    is %a, 43, "update of hash array element to 43 was successful";
    lives_ok { %a = Nil }, "assign Nil to hash array element";
    is %a, 42, "typed hash element returned to its default with Nil";
    lives_ok { %a = 314 }, "should be able to update typed hash element";
    is %a, 314, "update of typed hash element to 314 was successful";
    lives_ok { undefine %a }, "undefine typed hash element";
    is %a, 42, "typed hash element returned to its default with undefine";

    my Int %b is default(42) = o => 768;
    is %b, 768, "typed hash element should be initialized";
    is %b.VAR.default, 42, 'is the default set correctly for Int %b';

    my Int %c is default(Nil);
    ok %c.VAR.default === Nil, 'is the default set correctly for Int %c';
    lives_ok { %c++ }, 'should be able to increment typed variable';
    is %c, 1, "typed variable should be incremented";
    lives_ok { %c = Nil }, "able to assign Nil to typed variable";
    ok %c === Nil, 'is the default value correctly reset for Int %c';

    my Int %d is default(Nil) = o => 353;
    is %d, 353, "typed variable should be initialized";
    ok %d.VAR.default === Nil, 'is the default set correctly for Int %d';
} #19

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/is_dynamic.t0000664000175000017500000000461012224265625017760 0ustar  moritzmoritzuse v6;
use Test;

plan 22;

#?pugs   skip "is dynamic NYI"
#?niecza skip "is dynamic NYI"
# not specifically typed
{
    my $a is dynamic;
    ok $a.VAR.dynamic, 'dynamic set correctly for uninitialized $a';
    $a = 42;
    ok $a.VAR.dynamic, 'dynamic set correctly for initialized $a';
    $a = Nil;
    ok $a.VAR.dynamic, 'dynamic set correctly for reset $a';
} #3

#?pugs   skip "Int is dynamic NYI"
#?niecza skip "Int is dynamic NYI"
# typed
{
    my Int $a is dynamic;
    ok $a.VAR.dynamic, 'dynamic set correctly for uninitialized Int $a';
    $a = 42;
    ok $a.VAR.dynamic, 'dynamic set correctly for initialized Int $a';
    $a = Nil;
    ok $a.VAR.dynamic, 'dynamic set correctly for reset Int $a';
} #3

#?pugs   skip "is dynamic NYI"
#?niecza skip "is dynamic NYI"
# not specifically typed
{
    my @a is dynamic;
    ok @a.VAR.dynamic,    'dynamic set correctly for @a';
    ok @a[0].VAR.dynamic, 'dynamic set correctly for non-existing @a[0]';
    @a[0] = 42;
    ok @a[0].VAR.dynamic, 'dynamic set correctly for existing @a[0]';
    @a[0] = Nil;
    ok @a[0].VAR.dynamic, 'dynamic set correctly for reset @a[0]';
} #4

#?pugs   skip "Int is dynamic NYI"
#?niecza skip "Int is dynamic NYI"
# typed
{
    my Int @a is dynamic(42);
    ok @a.VAR.dynamic,    'dynamic set correctly for Int @a';
    ok @a[0].VAR.dynamic, 'dynamic set correctly for non-existing Int @a[0]';
    @a[0] = 42;
    ok @a[0].VAR.dynamic, 'dynamic set correctly for existing Int @a[0]';
    @a[0] = Nil;
    ok @a[0].VAR.dynamic, 'dynamic set correctly for reset Int @a[0]';
} #4

#?pugs   skip "is dynamic NYI"
#?niecza skip "is dynamic NYI"
# not specifically typed
{
    my %a is dynamic;
    ok %a.VAR.dynamic,    'dynamic set correctly for %a';
    ok %a.VAR.dynamic, 'dynamic set correctly for non-existing %a';
    %a = 42;
    ok %a.VAR.dynamic, 'dynamic set correctly for existing %a';
    %a = Nil;
    ok %a.VAR.dynamic, 'dynamic set correctly for reset %a';
} #4

#?pugs   skip "Int is dynamic NYI"
#?niecza skip "Int is dynamic NYI"
# typed
{
    my Int %a is dynamic(42);
    ok %a.VAR.dynamic,    'dynamic set correctly for Int %a';
    ok %a.VAR.dynamic, 'dynamic set correctly for non-existing Int %a';
    %a = 42;
    ok %a.VAR.dynamic, 'dynamic set correctly for existing Int %a';
    %a = Nil;
    ok %a.VAR.dynamic, 'dynamic set correctly for reset Int %a';
} #4

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/name.t0000664000175000017500000000416312224265625016564 0ustar  moritzmoritzuse v6;
use Test;

plan 15;

#?pugs   skip "$a.VAR.name NYI"
#?niecza skip "$a.VAR.name NYI"
# not specifically typed
{
    my $a;
    is $a.VAR.name, '$a', "uninitialized untyped variable should have name";
    $a++;
    is $a.VAR.name, '$a', "initialized untyped variable should have name";
} #2

#?pugs   skip "Int $a.VAR.name NYI"
#?niecza skip "Int $a.VAR.name NYI"
# typed
{
    my Int $a;
    is $a.VAR.name, '$a', "uninitialized typed variable should have name";
    $a++;
    is $a.VAR.name, '$a', "initialized typed variable should have name";
} #2

#?pugs   skip "@a.VAR.name NYI"
#?niecza skip "@a.VAR.name NYI"
# not specifically typed
{
    my @a;
    is @a.VAR.name, '@a', "uninitialized untyped array should have name";
    @a.push(1);
    is @a.VAR.name, '@a', "initialized untyped array should have name";
} #2

#?pugs   skip "Int @a.VAR.name NYI"
#?niecza skip "Int @a.VAR.name NYI"
# typed
{
    my Int @a;
    is @a.VAR.name, '@a', "uninitialized typed array should have name";
    @a.push(1);
    is @a.VAR.name, '@a', "initialized typed array should have name";
} #2

#?pugs   skip "%a.VAR.name NYI"
#?niecza skip "%a.VAR.name NYI"
# not specifically typed
{
    my %a;
    is %a.VAR.name, '%a', "uninitialized untyped hash should have name";
    %a++;
    is %a.VAR.name, '%a', "initialized untyped hash should have name";
} #2

#?pugs   skip "Int %a.VAR.name NYI"
#?niecza skip "Int %a.VAR.name NYI"
# typed
{
    my Int %a;
    is %a.VAR.name, '%a', "uninitialized typed hash should have name";
    %a++;
    is %a.VAR.name, '%a', "initialized typed hash should have name";
} #2

#?pugs   skip "&a.VAR.name NYI"
#?niecza skip "&a.VAR.name NYI"
# not specifically typed
{
    my &a;
    is &a.VAR.name, '&a', "uninitialized untyped sub should have name";
    &a = -> { ... };
    is &a.VAR.name, '&a', "initialized untyped sub should have name";
} #2

#?pugs   skip "Int &a.VAR.name NYI"
#?niecza skip "Int &a.VAR.name NYI"
# typed
{
    my Int &a;
    is &a.VAR.name, '&a', "uninitialized typed sub should have name";
#    &a = -> { ... };
#    is &a.VAR.name, '&a', "initialized typed sub should have name";
} #2

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/our.t0000664000175000017500000000210712224265625016445 0ustar  moritzmoritzuse v6;
use Test;

plan 10;

# L

{
    eval_lives_ok 'our sub eval_born { 5 }', 'can define a sub in eval';
    #?pugs todo
    eval_dies_ok 'eval_born()', 'call to eval-born sub outside eval dies';
    #?rakudo skip 'Null PMC access in invoke()'
    #?pugs skip 'OUR NYI'
    is OUR::eval_born(), 5, 'call to eval-born our sub via OUR works';
}

# RT #63882
#?pugs skip "Unexpected: 'A'"
{
    my enum A ;
    is +c, 2, 'c is 2 from enum';
    eval_lives_ok 'our sub c { "sub c" }',
        'can define my sub c in eval after c defined in enum';
    is +c, 2, 'c is still 2 from enum';
    #?rakudo skip 'OUR::subname() does not work'
    is OUR::c(), 'sub c', 'sub c called with OUR:: works';
}

# RT #69460
{
    our $rt69460 = 1;
    eval_lives_ok 'class RT69460 { $GLOBAL::rt69460++ }',
                  'can compile a class that modifies our variable';
    ok ::OUR::RT69460.new ~~ ::OUR::RT69460, 'can instantiate class that modifies our variable';
    #?pugs todo
    is $rt69460, 2, 'class can modify our variable';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/pseudo.t0000664000175000017500000003211512224265625017141 0ustar  moritzmoritzuse v6;

use Test;

plan 142;

# I'm not convinced this is in the right place
# Some parts of this testing (i.e. WHO) seem a bit more S10ish -sorear

# L

# (root)
#?rakudo skip 'the binding in here is NYI'
{
    my $x = 1; #OK
    my $y = 2; #OK
    is ::<$x>, 1, 'Access via root finds lexicals';

    {
        my $y = 3; #OK
        is ::<$y>, 3, 'Access via root finds lexicals in inner block';
        is ::<$x>, 1, 'Access via root finds lexicals in outer block';
    }

    {
        ::<$x> := $y;
        $y = 1.5;
        is $x, 1.5, 'Can bind via root';
    }

    # XXX Where else should rooty access look?
    # OUR and GLOBAL are the main (mutually exclusive) choices.
}

# MY
#?rakudo skip 'various issues, skipping all for now'
{
    my $x = 10; #OK
    my $y = 11; #OK

    is $MY::x, 10, '$MY::x works';
    is MY::<$x>, 10, 'MY::<$x> works';
    is MY::.{'$x'}, 10, 'MY::.{\'$x\'} works';
    is MY.WHO.{'$x'}, 10, 'MY.WHO access works';

    {
        my $y = 12; #OK
        is $MY::y, 12, '$MY::y finds shadow';
        is $MY::x, 10, '$MY::x finds original';
        is MY::.{'$y'}, 12, 'Hash-like access finds shadow $y';
        is MY::.{'$x'}, 10, 'Hash-like access finds original $x';
    }

    my $z;
    {
        $x = [1,2,3];
        $MY::z := $x;
        ok $z =:= $x, 'Can bind through $MY::z';
        is +[$z], 1, '... it is a scalar binding';
        lives_ok { $z = 15 }, '... it is mutable';

        MY::.{'$z'} := $y;
        ok $z =:= $y, 'Can bind through MY::.{}';

        $MY::z ::= $y;
        is $z, $y, '::= binding through $MY::z works';
        dies_ok { $z = 5 }, '... and makes readonly';

        MY::.{'$z'} ::= $x;
        is $z, $x, '::= binding through MY::.{} works';
        dies_ok { $z = 5 }, '... and makes readonly';
    }

    my class A1 {
        our $pies = 14;
        method pies() { }
    }
    ok MY::A1.^can('pies'), 'MY::classname works';
    is $MY::A1::pies, 14, 'Can access package hashes through MY::A1';
    ok MY::.{'A1'}.^can('pies'), 'MY::.{classname} works';

    {
        ok MY::A1.^can('pies'), 'MY::classname works from inner scope';
        ok MY::.{'A1'}.^can('pies'), 'MY::.{classname} works from inner scope';

        my class A2 {
            method spies { 15 }
        }
    }

    dies_ok { eval 'MY::A2' }, 'Cannot use MY::A2 directly from outer scope';
    dies_ok { MY::.{'A2'}.spies }, 'Cannot use MY::.{"A2"} from outer scope';

    sub callee { MY::.{'$*k'} }
    sub callee2($f is rw) { MY::.{'$*k'} := $f }
    # slightly dubious, but a straightforward extrapolation from the behavior
    # of CALLER::<$*k> and OUTER::<$*k>
    {
        my $*k = 16;
        my $z  = 17;
        is callee(), 16, 'MY::.{\'$*k\'} does a dynamic search';
        callee2($z);
        ok $*k =:= $z, 'MY::.{\'$*k\'} can be used to bind dynamic variables';
    }

    # niecza does a case analysis on the variable's storage type to implement
    # this, so there is room for bugs to hide in all cases
    our $a18 = 19;
    is $MY::a18, 19, '$MY:: can be used on our-aliases';
    is MY::.{'$a18'}, 19, 'MY::.{} can be used on our-aliases';
    $MY::a18 := $x;
    ok $a18 =:= $x, '$MY:: binding works on our-aliases';

    my constant $?q = 20;
    is $?MY::q, 20, '$?MY:: can be used on constants';  #OK
    is MY::.{'$?q'}, 20, 'MY::.{} can be used on constants';

    ok MY::{'&say'} === &say, 'MY::.{} can find CORE names';
    ok &MY::say === &say, '&MY:: can find CORE names';

    for 1 .. 1 {
        state $r = 21;
        is MY::.{'$r'}, 21, 'MY::.{} can access state names';
        is $MY::r, 21, '$MY:: can access state names';
    }

    my $my = 'MY';
    my $l = 22; #OK
    is ::($my)::('$l'), 22, 'Can access MY itself indirectly ::()';
    is ::..WHO.<$l>, 22, 'Can access MY itself indirectly via ::';
}

# OUR

{
    {
        our $x30 = 31;
        our $x32 = 33;
        our $x34 = 35;
    }
    my $x = 39;

    is $OUR::x30, 31, 'basic OUR:: testing';
    $OUR::x30 := $x;
    ok $OUR::x30 =:= $x, 'can bind through OUR::';
    is OUR::.<$x32>, 33, 'basic OUR::.{} works';
    OUR::.<$x32> := $x;
    ok $OUR::x32 =:= $x, 'can bind through OUR::.{}';

    my $our = 'OUR';
    is ::($our)::('$x34'), 35, 'OUR works when indirectly accessed';

    our package A36 { # for explicitness
        { our $x37 = 38; }
        ok !defined($OUR::x30), '$OUR:: does not find GLOBAL';
        is $OUR::x37, 38, '$OUR:: does find current package';
        ok !defined(OUR::.<$x30>), 'OUR::.{} does not find GLOBAL';
        is OUR::.{'$x37'}, 38, 'OUR::.{} does find current package';
        ok !defined(::($our)::('$x34')), '::("OUR") does not find GLOBAL';
        is ::($our)::('$x37'), 38, '::("OUR") does find current package';
    }

    is $OUR::A36::x37, 38, '$OUR:: syntax can indirect through a package';
    is ::($our)::('A36')::('$x37'), 38, '::("OUR") can also indirect';

    $OUR::A40::x = 41;
    is OUR::A40.WHO.<$x>, 41, '$OUR:: can autovivify packages (reference)';
    $OUR::A41::x := 42;
    is OUR::A41.WHO.<$x>, 42, '$OUR:: can autovivify packages (binding)';
    #?rakudo emit #
    $::($our)::A42::x = 43;
    #?rakudo todo 'interpolation and auto-viv NYI'
    is ::($our)::A42.WHO.<$x>, 43, '::("OUR") can autovivify packages (r)';
    
    #?rakudo emit #
    $::($our)::A43::x := 44;
    #?rakudo todo 'binding and interpolation together NYI'
    is ::($our)::A43.WHO.<$x>, 44, '::("OUR") can autovivify packages (b)';

    #?rakudo emit #
    ::($our)::A44 := class { our $x = 41; };
    #?rakudo todo 'binding and interpolation together NYI'
    is $::($our)::A44::x, 41, '::("OUR") can follow aliased packages';
}

# CORE
#?rakudo skip 'CORE NYI'
{
    my $real = ¬
    my $core = "CORE";
    ok &CORE::not === $real, '&CORE:: works';
    ok CORE::.<¬> === $real, 'CORE::.{} works';
    ok ::($core)::('¬') === $real, '::("CORE") works';

    {
        sub not($x) { $x } #OK
        ok &CORE::not === $real, '&CORE:: works when shadowed';
        ok CORE::.<¬> === $real, 'CORE::.{} works when shadowed';
        ok &::($core)::not === $real, '::("CORE") works when shadowed';

        ok eval('&CORE::not') === $real, '&CORE:: is not &SETTING::';
        ok eval('CORE::.<¬>') === $real, 'CORE::.{} is not SETTING::';
        ok eval('&::($core)::not') === $real, '::("CORE") is not SETTING';
    }

    sub f1() { }; sub f2() { }; sub f3() { }
    lives_ok { &CORE::none := &f1 }, '&CORE:: binding lives';
    ok &none =:= &f1, '... and works';
    lives_ok { CORE::.<&none> := &f2 }, 'CORE::.{} binding lives';
    ok &none =:= &f2, '... and works';
    lives_ok { &::($core)::none := &f3 }, '::("CORE") binding lives';
    ok &none =:= &f3, '... and works';

    # in niecza v8, dynamic variables go through a separate code path.
    # make sure accessing it in CORE works
    lives_ok { $CORE::_ := 50 }, 'Binding to $CORE::_ lives';
    is $CORE::_, 50, 'Accessing $CORE::_ works';
    lives_ok { $::($core)::_ := 51 }, 'Binding to $::("CORE")::_ lives';
    is $::($core)::_, 51, 'Accessing $::("CORE")::_ works';
}

# GLOBAL - functionality is very similar to OUR
{
    { our $x60 = 60; }
    package A61 {
        is $GLOBAL::x60, 60, '$GLOBAL:: works';
        #?rakudo todo 'GLOBAL and interpolation'
        is ::("GLOBAL")::('$x60'), 60, '::("GLOBAL") works';
        is GLOBAL::.<$x60>, 60, 'GLOBAL::.{} works';
    }
    ok !defined(&GLOBAL::say), 'GLOBAL:: does not find CORE symbols';
}

# PROCESS - similar to GLOBAL and OUR
{
    package A71 {
        ok $PROCESS::IN === $*IN, '$PROCESS:: works';
        ok PROCESS::.<$IN> === $*IN, 'PROCESS::.{} works';
        ok $::("PROCESS")::IN === $*IN, '::("PROCESS") works';
    }
}

#RT #89706
#?niecza skip "readonly"
{
    $PROCESS::PROGRAM_NAME = "otter";
    is $*PROGRAM_NAME, "otter", 'existing $* assignable via PROCESS';
    $PROCESS::SOME_OTHER_VAR = "else";
    is $*SOME_OTHER_VAR, "else", 'new $* assignable via PROCESS';
}

# COMPILING - not testable without BEGIN

# DYNAMIC
#?rakudo skip 'various issues to resolve'
{
    my $dyn = "DYNAMIC";

    {
        my $*x80 = 82;
        my $y; my $z;
        is $*DYNAMIC::x80, 82, '$DYNAMIC:: works';
        is DYNAMIC::.<$*x80>, 82, 'DYNAMIC::.{} works';
        is ::($dyn)::('$*x80'), 82, '::("DYNAMIC") works';

        $*DYNAMIC::x80 := $y;
        ok $*x80 =:= $y, 'Can bind through $DYNAMIC::';
        ::($dyn)::('$*x80') := $z;
        ok $*x80 =:= $z, 'Can bind through ::("DYNAMIC")';

        ok !defined($*DYNAMIC::x82), 'Unfound dynamics are undefined';
        ok !defined(::($dyn)::('$*x82')), 'Unfound with ::("DYNAMIC")';
    }

    {
        my $x83 is dynamic = 83; #OK
        my $*x84 = 84; #OK

        is $DYNAMIC::x83, 83, 'DYNAMIC on non-$* vars works';
        is $::($dyn)::x83, 83, '::("DYNAMIC") on non-$* vars works';

        ok !defined($DYNAMIC::x84), 'DYNAMIC $x does not find $*x';
        ok !defined($::($dyn)::x84), '::("DYNAMIC") $x does not find $*x';
        ok !defined($*DYNAMIC::x83), 'DYNAMIC $*x does not find $x';
        ok !defined(::($dyn)::('$*x83')), '::("DYNAMIC") $x does not find $*x';
    }

    sub docall($f) { my $*x80 = 80; my $x81 is dynamic = 81; $f() } #OK

    {
        is docall({ $DYNAMIC::x81 }), 81, 'DYNAMIC:: searches callers';
        is docall({ $::($dyn)::x81 }), 81, '::("DYNAMIC") searches callers';
        my ($fun1, $fun2) = do {
            my $x81 is dynamic = 85; #OK
            { $DYNAMIC::x81 }, { $::($dyn)::x81 }
        };
        ok !defined($fun1()), 'DYNAMIC:: does not search outers';
        ok !defined($fun2()), '::("DYNAMIC") does not search outers';

        $GLOBAL::x86 = 86;
        ok !defined($DYNAMIC::x86), 'DYNAMIC:: without twigil ignores GLOBAL';
        ok !defined($::($dyn)::x86), '"DYNAMIC" without twigil ignores GLOBAL';
        is $*DYNAMIC::x86, 86, 'DYNAMIC:: with * searches GLOBAL';
        is ::($dyn)::('$*x86'), 86, '::("DYNAMIC") with * searches GLOBAL';

        ok DYNAMIC::<$*IN> === $PROCESS::IN,
            'DYNAMIC:: with * searches PROCESS';
        ok ::($dyn)::('$*IN') === $PROCESS::IN,
            '::("DYNAMIC") with * searches PROCESS';
    }
}

# CALLER - assumes MY:: has taken care of most access testing
{
    sub f1($f) { my $x is dynamic = 90; $f() } #OK
    sub f2($f) { my $x is dynamic = 91; f1($f) } #OK
    my $caller = 'CALLER';

    is f1({ $CALLER::x }), 90, '$CALLER:: works';
    is f1({ CALLER::.<$x> }), 90, 'CALLER::.{} works';
    is f1({ $::($caller)::x }), 90, '::("CALLER") works';

    is f2({ $CALLER::CALLER::x }), 91, 'CALLER::CALLER:: works';
    is f2({ $::($caller)::($caller)::x }), 91, 'indirect CALLER::CALLER works';

    my $*foo = 92;
    #?rakudo 2 todo 'not entirely sure these make sense...'
    is f2({ CALLER::<$*foo> }), 92, 'CALLER::<$*foo> works';
    is f2({ ::($caller)::('$*foo') }), 92, '::("CALLER")::<$*foo> works';

    my $y is dynamic = 93; #OK
    if 1 {
        is $CALLER::y, 93, 'CALLER:: works in inline blocks';
        is $::($caller)::y, 93, '::("CALLER") works in inline blocks';
    }
}

# OUTER
{
    sub f1($f) { my $x is dynamic = 100; $f() } #OK
    sub f2($f) { my $*x = 101; $f() } #OK
    my $outer = 'OUTER';

    my $x = 102; #OK
    my $y = 103; #OK
    {
        my $x = 104; #OK
        is $OUTER::x, 102, '$OUTER:: works';
        is OUTER::.<$x>, 102, 'OUTER::.{} works';
        is $::($outer)::x, 102, '::("OUTER") works';

        {
            my $x = 105; #OK
            my $y = 106; #OK
            #?rakudo 2 todo 'these tests disagree with STD'
            is $OUTER::y, 103, '$OUTER:: keeps going until match';
            is $::($outer)::y, 103, '::("OUTER") keeps going until match';

            is $OUTER::OUTER::x, 102, '$OUTER::OUTER:: works';
            is $::($outer)::($outer)::x, 102, '::("OUTER")::("OUTER") works';
        }

        is f1({ $OUTER::x }), 104, 'OUTER:: is not CALLER::';
        is f1({ $::($outer)::x }), 104, '::("OUTER") is not CALLER::';

        {
            is f1({ $CALLER::OUTER::x }), 102, 'CALLER::OUTER:: works';
        }
    }

    my $*x = 107;
    is f2({ OUTER::<$*x> }), 107, 'OUTER::<$*x> works';
    is f2({ ::($outer)::('$*x') }), 107, '::("OUTER")::<$*x> works';
}

# UNIT
my $x110 = 110; #OK
{
    my $x110 = 111; #OK
    my $unit = "UNIT";
    is $UNIT::x110, 110, '$UNIT:: works';
    is $::($unit)::x110, 110, '::("UNIT") works';
    is eval('my $x110 = 112; $UNIT::x110'), 112, '$UNIT:: finds eval heads';
    is eval('my $x110 = 112; $::($unit)::x110 #OK'), 112, '::("UNIT") finds eval heads';
    my $f = eval('my $x110 is dynamic = 113; -> $fn { my $x110 is dynamic = 114; $fn(); } #OK');
    is $f({ $CALLER::UNIT::x110 }), 113, 'CALLER::UNIT works';
    is $f({ $CALLER::($unit)::x110 }), 113, 'CALLER::UNIT works (indirect)';
}

# SETTING
#?rakudo skip 'SETTING NYI'
{
    sub not($x) { $x } #OK
    my $setting = 'SETTING';
    ok &SETTING::not(False), 'SETTING:: works';
    ok &::($setting)::not.(False), '::("SETTING") works';

    ok eval('&SETTING::not(True)'), 'SETTING finds eval context';
    ok eval('&::($setting)::not(True)'), '::("SETTING") finds eval context';
    my $f = eval('-> $fn { $fn(); }');
    ok $f({ &CALLER::SETTING::not(True) }), 'CALLER::SETTING works';
    ok $f({ &CALLER::($setting)::not(True) }), 'CALLER::SETTING works (ind)';
}

# PARENT - NYI in any compiler

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names/symbolic-deref.t0000664000175000017500000001173112224265625020547 0ustar  moritzmoritzuse v6;

use Test;

plan 35;

# See L --
# previously, "my $a; say $::("a")" died (you had to s/my/our/). Now, it was
# re-specced to work.

# L
{
  my $a_var = 42;
  my $b_var = "a_var";

  is $::($b_var), 42, 'basic symbolic scalar dereferentiation works';
  lives_ok { $::($b_var) = 23 }, 'can use $::(...) as lvalue';
  is $a_var, 23, 'and the assignment worked';
  $::($b_var) = 'a', 'b', 'c';
  is $a_var, 'a', '... and it is item assignment';
}

{
  my @a_var = ;
  my $b_var = "a_var";

  is @::($b_var)[1], "b", 'basic symbolic array dereferentiation works';
  @::($b_var) = ('X', 'Y', 'Z');
  is @a_var.join(' '), 'X Y Z', 'can assign to symbolic deref';
  @::($b_var) = 'u', 'v', 'w';
  is @a_var.join(' '), 'u v w', '... and it is list assignment when the sigil is @';
}

{
  my %a_var = (a => 42); #OK not used
  my $b_var = "a_var";

  is %::($b_var), 42, 'basic symbolic hash dereferentiation works';
}

{
  my &a_var := { 42 }; #OK not used
  my $b_var = "a_var";

  is &::($b_var)(), 42, 'basic symbolic code dereferentiation works';
}

my $outer = 'outside';
{
    my $inner = 'inside';

    ok ::('Int') === Int,    'can look up a type object with ::()';
    #?pugs 3 skip 'Invalid sigil ":$"'
    is ::('$inner'), $inner, 'can look up lexical from same block';
    is ::('$outer'), $outer, 'can look up lexical from outer block';

    lives_ok { ::('$outer') = 'new' }, 'Can use ::() as lvalue';
    #?pugs todo
    is $outer, 'new', 'and the assignment worked';
    sub c { 'sub c' }; #OK not used
    #?pugs 2 skip 'Invalid sigil ":&"'
    is ::('&c').(), 'sub c', 'can look up lexical sub';

    is ::('e'), e,  'Can look up numerical constants';
}

{
    package Outer {
        class Inner { }
    }

    class A::B { };

    #?pugs 2 skip 'No such subroutine'
    is ::('Outer::Inner').perl, Outer::Inner.perl, 'can look up name with :: (1)';
    #?niecza skip "Object reference not set to an instance of an object"
    is ::('A::B').perl, A::B.perl, 'can look up name with :: (1)';
}


{
  $pugs::is::cool = 42;
  my $cool = "cool";
  my $pugsis = 'pugs::is';

  #?niecza 2 skip "Object reference not set to an instance of an object"
  is $::("pugs")::is::($cool), 42, 'not so basic symbolic dereferentiation works';
  is $::($pugsis)::($cool),    42, 'symbolic derefertiation with multiple packages in one variable works';
  eval_dies_ok('$::($pugsis)cool', '$::($foo)bar is illegal');
}

{
  my $result;

  try {
    my $a_var is dynamic = 42; #OK not used
    my $sub   = sub { $::("CALLER")::("a_var") };
    $result = $sub();
  };

  is $result, 42, "symbolic dereferentation works with ::CALLER, too";
}

# Symbolic dereferentiation of Unicode vars (test primarily aimed at PIL2JS)
{
  my $äöü = 42; #OK not used
  is $::("äöü"), 42, "symbolic dereferentiation of Unicode vars works";
}

# The &::*::foo tests were removed as a result of
# http://irclog.perlgeek.de/perl6/2011-07-30#i_4189700

#?rakudo skip 'NYI'
{
  sub GLOBAL::a_global_sub () { 42 }
  #?pugs skip 'Invalid sigil'
  is ::("&*a_global_sub")(), 42,
    "symbolic dereferentiation of globals works (1)";

  my $*a_global_var = 42;
  #?pugs skip 'Invalid sigil'
  is ::('$*a_global_var'),   42,
    "symbolic dereferentiation of globals works (2)";
}

# Symbolic dereferentiation of globals *without the star*
{
  #?pugs skip 'Invalid sigil'
  #?rakudo todo 'no such symbol'
  ok ::('$*IN') === $*IN,
    "symbolic dereferentiation of globals works (3)";

  ok &::("say") === &say,
    "symbolic dereferentiation of CORE subs works (1)";
  #?rakudo skip 'no such symbol'
  ok &::("so")(42),
    "symbolic dereferentiation of CORE subs works (2)";
  is &::("truncate")(3.1), 3,
    "symbolic dereferentiation of CORE subs works (3)";
}

# Symbolic dereferentiation of type vars
#?niecza skip "Object reference not set to an instance of an object"
{
  ok ::Array === ::("Array"),
    "symbolic dereferentiation of type vars works (1)";
}

#?niecza skip "Object reference not set to an instance of an object"
{
  class A::B::C {};
  my $ok = ::A::B::C === ::A::("B")::C;
  ok $ok, "symbolic dereferentiation of (own) type vars works (2)";
}

# Symbolic dereferentiation syntax should work with $?SPECIAL etc. too.
# Note: I'm not 100% sure this is legal syntax. If it turns out it isn't, we'll
# have to s/ok/dies_ok/.
{
  try { die 'to set $!' };
  ok $::("!"),    "symbolic dereferentiation works with special chars (1)";
#  ok $::!,        "symbolic dereferentiation works with special chars (2)";
  #?pugs skip 'todo'
  #?rakudo todo 'NYI'
  ok ::("%*ENV"), "symbolic dereferentiation works with special chars (3)";
#  ok %::*ENV,     "symbolic dereferentiation works with special chars (4)";
}

# Symdereffing should find package vars as well:
{
  our $symderef_test_var = 42;

  is $::("symderef_test_var"), 42, "symbolic dereferentiation works with package vars";
}

eval_dies_ok ' ::().Str ', 'Cannot look up empty name';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/contextual.t0000664000175000017500000000433112224265625021000 0ustar  moritzmoritzuse v6;

use Test;

plan 23;

# L

sub foo() { $*VAR };

class CT {
    method foo() { $*VAR }
    method foo_priv { self!priv }
    method !priv { $*VAR }
}

my $o = CT.new;
{
    my $*VAR = 'one';
    is $*VAR,       'one', 'basic contextual declaration works';
    is foo(),       'one', 'called subroutine sees caller $*VAR';
    is $o.foo,      'one', 'called method sees caller $*VAR';
    is $o.foo_priv, 'one', 'called private method sees caller $*VAR';
    is CT.foo,      'one', 'called class method sees caller $*VAR';
    is CT.foo_priv, 'one', 'called private class method sees caller $*VAR';
    {
        my $*VAR = 'two';
        is $*VAR,  'two', 'inner contextual declaration works';
        is foo(),  'two', 'inner caller hides outer caller';
        is $o.foo, 'two', 'inner caller hides outer caller (method)';
        is CT.foo, 'two', 'inner caller hides outer caller (class method)';
        is $o.foo_priv, 'two', 'inner caller hides outer caller (private method)';
        is CT.foo_priv, 'two', 'inner caller hides outer caller (private class method)';
    }
    is foo(),       'one', 'back to seeing outer caller';
    is $o.foo,      'one', 'back (method)';
    is $o.foo_priv, 'one', 'back (private method)';
    is CT.foo,      'one', 'back (class method)';
    is CT.foo_priv, 'one', 'back (private class method)';
}

nok foo().defined, 'contextual $*VAR is undefined';

{
    sub  a1() { @*AR; @*AR.join('|') };
    my @*AR = ;
    is a1(), 'foo|bar', 'contextual @-variables work';
}

{
    sub a2() { &*CC('a') };
    my &*CC = -> $x { 'b' ~ $x };
    is a2(), 'ba', 'contextual Callable variables work';

}

# no idea if it actually makes sense to put contextuals inside a package, but
# the lexical alias that's also created should work just fine:
#
# Notsomuch in niecza, as the "lexical alias" is only seen by the compiler...
{
    sub f { $*a };
    our $*a = 'h';
    is f(), 'h', 'our $*a';
}

{
    sub f { %*a };
    our %*a =  a => 'h';
    is f().keys, 'a', 'our %*a';
}

#RT #63226
# Not every impl has an @*INC by default...
@*INC.push('not_a_directory');
{
    package Foo { our sub run() { return @*INC } };
    ok Foo::run().chars > 0;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/fmt.t0000664000175000017500000000510012224265625017373 0ustar  moritzmoritzuse v6;

use Test;

plan 21;

# L
{
    is "Hi".fmt("[%s]"), "[Hi]", 'fmt() works with %s';
    is '3.141'.fmt("[%d]"), "[3]",  "fmt() works with %d";
    is (5.6).fmt('%f'), '5.600000', 'fmt() works with %f';
}

# L
{
    is (1.3,2.4,3).fmt("%d", "_"), "1_2_3", "fmt() works with plain lists";
    my @list = 'a'..'c';
    is @list.fmt('<%s>', ':'), '::', 'fmt() works with @ array';

    my $list = ['a', 'b', 'c'];
    is $list.fmt('[%s]', ','), '[a],[b],[c]', 'fmt() works with Array object';

    # single elem Array:
    $list = ['a'];
    is $list.fmt('<<%s>>', '!!!'), '<>', 'fmt() works for single elem array';
}

# L
#?DOES 1
{
    my $hash = {
        a => 1.3,
        b => 2.4,
    };
    my $str = $hash.fmt("%s:%d", "_");
    if $str eq "a:1_b:2" || $str eq "b:2_a:1" {
        pass "fmt() works with hashes";
    } else {
        flunk "fmt() fails to work with hashes";
    }
}

is (1..3).fmt('%02d', '/'), '01/02/03', 'Range.fmt';
is (1..3).fmt,              '1 2 3',    'Range.fmt with defaults';

# L
#?DOES 4
{
    # a single pair:
    my $pair = (100 => 'lovely');
    is $pair.fmt("%d ==> %s"), "100 ==> lovely", '.fmt works with a single pair';

    # list of a single pair:
    my @pairs = (100 => 'lovely');
    is(@pairs.fmt("%d ==> %s", "\n"), "100 ==> lovely", '.fmt works with lists of a single pair');

    # list of pair:
    @pairs = (a => 1.3, b => 2.4);
    is @pairs.fmt("%s:%d", "_"), "a:1_b:2", "fmt() works with lists of pairs";
    is @pairs.fmt("(%s => %f)", ""), "(a => 1.300000)(b => 2.400000)",
        "fmt() works with lists of pairs";
}

# Test defaults on $comma
#?DOES 2
{
    is([1..3].fmt("%d"), "1 2 3", 'default $comma for array');

    my $hash = {
        a => 1.3,
        b => 2.4,
    };
    my $str = $hash.fmt("%s:%d");
    if $str eq "a:1\nb:2" || $str eq "b:2\na:1" {
        pass 'default $comma works with hashes';
    } else {
        flunk 'default $comma fails to work with hashes';
    }
}

# .fmt without arguments
#?DOES 5
{
    is (1).fmt(), '1', 'scalar .fmt without $fmt';
    is (1=>"a").fmt(), "1\ta", 'pair .fmt without $fmt';
    is (1,2).fmt(), '1 2', 'list .fmt without $fmt';
    is [1,2].fmt(), '1 2', 'array .fmt without $fmt';
    is {1=>"a"}.fmt(), "1\ta", 'hash .fmt without $fmt';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/list_array_perl.t0000664000175000017500000000525312224265625022011 0ustar  moritzmoritzuse v6;
use Test;
plan 21;

# L


my @tests = (

    # References to aggregates
    [],
    [ 42 ],  # only one elem
    [< a b c>],
    [ 3..42 ],

    # Infinite arrays, commented because they take infram and inftime in
    # current Pugs
    #?pugs emit #
    #[ 3..Inf ],

    #?pugs emit #
    #[ -Inf..Inf ],

    #?pugs emit #
    #[ 3..42, 17..Inf, -Inf..5 ],

    # Nested arrays
    [      [1,2,3] ],  # only one elem
    [[2,3],4,[6,8]], # three elems
);

{
    for @tests -> $obj {
        my $s = (~$obj).subst(/\n/, '␤');
        ok eval($obj.perl) eq $obj,
            "($s.perl()).perl returned something whose eval()ed stringification is unchanged";
        is (eval($obj.perl).WHAT).gist, $obj.WHAT.gist,
            "($s.perl()).perl returned something whose eval()ed .WHAT is unchanged";
    }
}

# Recursive data structures
#?rakudo skip 'recursive data structure'
{
    my $foo = [ 42 ]; $foo[1] = $foo;
    is $foo[1][1][1][0], 42, "basic recursive arrayref";

    #?pugs skip 'hanging test'
    #?niecza skip 'hanging test'
    is ~$foo.perl.eval, ~$foo,
        ".perl worked correctly on a recursive arrayref";
}

{
    # test bug in .perl on result of hyperoperator
    # first the trivial case without hyperop
    my @foo = ([-1, -2], -3);
    is @foo.item.perl, '[[-1, -2], -3]', ".perl on a nested list";

    my @hyp = -« ([1, 2], 3);
    # what it currently (r16460) gives
    #?pugs 2 todo 'bug'
    isnt @hyp.item.perl, '[(-1, -2), -3]', "strange inner parens from .perl on result of hyperop";

    # what it should give
    is @hyp.item.perl, '[[-1, -2], -3]', ".perl on a nested list result of hyper operator";
}

{
    # beware: S02 says that .perl should evaluate the invocant in item
    # context, so eval @thing.perl returns a scalar. Always.

    # L


    my @list = (1, 2);
    push @list, eval (3, 4).perl;
    #?rakudo todo "List.perl bug"
    #?niecza todo
    is +@list, 3, 'eval(@list.perl) gives a list, not an array ref';
}

# RT #63724
{
    my @original      = (1,2,3);
    my $dehydrated    = @original.perl;
    my @reconstituted = @( eval $dehydrated );

    is @reconstituted, @original,
       "eval of .perl returns original for '$dehydrated'";

    @original      = (1,);
    $dehydrated    = @original.perl;
    @reconstituted = @( eval $dehydrated );

    is @reconstituted, @original,
       "eval of .perl returns original for '$dehydrated'";
}

# RT #65988
{
    my $rt65988 = (\(1,2), \(3,4));
    is_deeply eval( $rt65988.perl ), $rt65988, $rt65988.perl ~ '.perl';
}

done;

# vim: ft=perl6

rakudo-2013.12/t/spec/S02-names-vars/names.t0000664000175000017500000001051012224265625017711 0ustar  moritzmoritzuse v6;

use Test;

plan 142;

# I'm using semi-random nouns for variable names since I'm tired of foo/bar/baz and alpha/beta/...

# L
# syn r14552

#?rakudo skip 'package variable autovivification'
#?niecza skip 'Undeclared name: Terrain::'
{
    my $mountain = 'Hill';
    $Terrain::mountain  = 108;
    $Terrain::Hill::mountain = 1024;
    our $river = 'Terrain::Hill';
    is($mountain, 'Hill', 'basic variable name');
    is($Terrain::mountain, 108, 'variable name with package');
    is(Terrain::<$mountain>, 108, 'variable name with sigil not in front of package');
    is($Terrain::Hill::mountain, 1024, 'variable name with 2 deep package');
    is(Terrain::Hill::<$mountain>, 1024, 'varaible name with sigil not in front of 2 package levels deep');
    is($Terrain::($mountain)::mountain, 1024, 'variable name with a package name partially given by a variable ');
    is($::($river)::mountain, 1024, 'variable name with package name completely given by variable');
}

{
    my $bear = 2.16;
    is($bear,       2.16, 'simple variable lookup');
    #?niecza skip 'Object reference not set to an instance of an object'
    #?rakudo skip 'this kind of lookup NYI'
    is($::{'bear'}, 2.16, 'variable lookup using $::{\'foo\'}');
    is(::{'$bear'}, 2.16, 'variable lookup using ::{\'$foo\'}');
    #?niecza skip 'Object reference not set to an instance of an object'
    #?rakudo skip 'this kind of lookup NYI'
    is($::,   2.16, 'variable lookup using $::');
    is(::<$bear>,   2.16, 'variable lookup using ::<$foo>');
}

#?rakudo skip '::{ } package lookup NYI'
#?niecza skip 'Postconstraints, and shapes on variable declarators NYI'
{
    my $:: =  2.22;
    is($::{'!@#$'}, 2.22, 'variable lookup using $::{\'symbols\'}');
    is(::{'$!@#$'}, 2.22, 'variable lookup using ::{\'$symbols\'}');
    is($::,   2.22, 'variable lookup using $::');
    is(::<$!@#$>,   2.22, 'variable lookup using ::<$symbols>');

}

# RT #65138, Foo::_foo() parsefails
{
    module A {
        our sub _b() { 'sub A::_b' }
    }
    is A::_b(), 'sub A::_b', 'A::_b() call works';
}

# RT #77750
#?rakudo todo 'dubious test - otherwise why is ::<$foo> allowed?'
eval_dies_ok '::.^methods', ':: is not a valid package';

# RT #63646
{
    dies_ok { OscarMikeGolf::whiskey_tango_foxtrot() },
            'dies when calling non-existent sub in non-existent package';
    dies_ok { Test::bravo_bravo_quebec() },
            'dies when calling non-existent sub in existing package';
    # RT #74520
    class TestA { };
    dies_ok { eval 'TestA::b(3, :foo)'},
        'calling non-existing function in foreign class dies';;
    #?rakudo todo 'nom regression'
    #?niecza todo
    ok "$!" ~~ / ' TestA::b' /, 'error message mentions function name';
}

# RT #71194
{
    sub self { 4 };
    is self(), 4, 'can define and call a sub self()';
}

# RT #77528
# Subroutines whose names begin with a keyword followed by a hyphen
# or apostrophe
# RT #72438
# Subroutines with keywords for names (may need to be called with
# parentheses).
#?DOES 114
{
    for <
        foo package module class role grammar my our state let
        temp has augment anon supersede sub method submethod
        macro multi proto only regex token rule constant enum
        subset if unless while repeat for foreach loop given
        when default > -> $kw {
        eval_lives_ok "sub $kw \{}; {$kw}();",
            "sub named \"$kw\" called with parentheses";
        eval_lives_ok "sub {$kw}-rest \{}; {$kw}-rest;",
            "sub whose name starts with \"$kw-\"";
        eval_lives_ok "sub {$kw}'rest \{}; {$kw}'rest;",
            "sub whose name starts with \"$kw'\"";
    }
}

# RT #77006
isa_ok (rule => 1), Pair, 'rule => something creates a Pair';

# RT #69752
{
    try { eval 'Module.new' };
    ok "$!" ~~ / 'Module' /,
        'error message mentions name not recognized, no maximum recursion depth exceeded';
}

# RT #74276
# Rakudo had troubles with names starting with Q
eval_lives_ok 'class Quox { }; Quox.new', 'class names can start with Q';

# RT #58488 
dies_ok {
    eval 'class A { has $.a};  my $a = A.new();';
    eval 'class A { has $.a};  my $a = A.new();';
    eval 'class A { has $.a};  my $a = A.new();';
}, 'can *not* redefine a class in eval -- classes are package scoped';

# RT #83874
{
    class Class { };
    ok Class.new ~~ Class, 'can call a class Class';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/perl.t0000664000175000017500000001161412224265625017556 0ustar  moritzmoritzuse v6;
use Test;
# L

#?pugs emit plan 89;

my @tests = (
    # Basic scalar values
    42, 
    42/10, 
    4.2, 
    #?pugs emit #
    sqrt(2),
    3e5,
    Inf, -Inf, NaN,

    "a string", "", "\0", "\t", "\n", 
    "\r\n", 
    "\o7",
    '{', # "\d123",	# XXX there is no \d escape!!!
    '}',
    '$a @string %with &sigils()',
    'שלום',

    ?1, ?0,
    #?rakudo emit # Mu eq Mu is an error now
    #?niecza emit # Dunno what's wrong with this one
    #?pugs emit #
    Mu,
    #?rakudo emit # parse error
    #?niecza emit # Autoloading NYI
    #?pugs emit #
    rx:P5/foo/, rx:P5//, rx:P5/^.*$/,

    # References to scalars
    \42, \Inf, \-Inf, \NaN, \"string", \"", \?1, \?0, 

    #?pugs emit #
    \Mu,

    #?pugs emit #
    (a => 1),
    #?pugs emit #
    :b(2),

    # References to aggregates
    #?pugs emit #
    {},           # empty hash
    #?pugs emit #
    { a => 42 },  # only one elem
    #?pugs emit #
    { :a(1), :b(2), :c(3) },

    # Nested things
    #?pugs emit #
    { a => [1,2,3] },  # only one elem
    #?pugs emit #
    { a => [1,2,3], b => [4,5,6] },
    #?pugs emit #
    [ { :a(1) }, { :b(2), :c(3) } ],

    # a Parcel
    
);

#?pugs emit unless $?PUGS_BACKEND eq "BACKEND_PUGS" {
#?pugs emit   skip_rest "eval() not yet implemented in $?PUGS_BACKEND.";
#?pugs emit   exit;
#?pugs emit }

# L
# Quoting S02 (emphasis added):
#   To get a Perlish representation of any data value, use the .perl method.
#   This will put quotes around strings, square brackets around list values,
#   curlies around hash values, etc., **such that standard Perl could reparse
#   the result**.
{
    for @tests -> $obj {
        my $s = (~$obj).subst(/\n/, '␤');
        ok eval($obj.perl) eq $obj,
            "($s.perl()).perl returned something whose eval()ed stringification is unchanged";
        is WHAT(eval($obj.perl)).gist, $obj.WHAT.gist,
            "($s.perl()).perl returned something whose eval()ed .WHAT is unchanged";
    }
}

# Recursive data structures
#?rakudo skip 'recursive data structure'
{
    my $foo = { a => 42 }; $foo = $foo;
    is $foo, 42, "basic recursive hashref";

    #?pugs skip 'hanging test'
    #?niecza skip 'hanging test'
    is ~$foo.perl.eval, ~$foo,
        ".perl worked correctly on a recursive hashref";
}

#?rakudo skip '{...}.perl does not work'
{
    my $foo = [ 42 ];
    my $bar = { a => 23 };
    $foo[1] = $bar;
    $bar = $foo;

    is $foo[1][1][0], 42, "mixed arrayref/hashref recursive structure";

    #?pugs skip 'hanging test'
    #?niecza skip 'hanging test'
    is ~$foo.perl.eval, ~$foo,
        ".perl worked correctly on a mixed arrayref/hashref recursive structure";
}

{
    # test a bug reported by Chewie[] - apparently this is from S03
    is(eval((("f","oo","bar").keys).perl), <0 1 2>, ".perl on a .keys list");
}


# RT #61918
#?niecza skip ">>>Stub code executed"
#?pugs   skip ">>>Stub code executed"
{
    class RT61918 {
        has $.inst is rw;
        has $!priv is rw;
        has $.string = 'krach';

        method init {
            $.inst = [ rand, rand ];
            $!priv = [ rand, rand ].perl;
        }
    }

    my $t1 = RT61918.new();
    my $t1_new = $t1.perl;
    $t1.init;
    my $t1_init = $t1.perl;

    ok $t1_new ne $t1_init, 'changing object changes .perl output';

    # TODO: more tests that show eval($t1_init) has the same guts as $t1.
    #?pugs todo
    ok $t1_new ~~ /<< krach >>/, 'attribute value appears in .perl output';

    # RT #62002 -- validity of default .perl
    my $t2_init = eval($t1_init).perl;
    is $t1_init, $t2_init, '.perl on user-defined type roundtrips okay';
}

# RT #64080
{
    my %h;
    lives_ok { %h = [%h] },
             'can assign list with new hash element to itself';
    lives_ok { %h.perl }, 'can take .perl from hash element';
    ok %h !=== %h[0], 'hoa does not refer to hash element';
}

# RT #67790
#?rakudo skip 'RT 67790'
{
    class RT67790 {}
    lives_ok { RT67790.HOW.perl }, 'can .perl on .HOW';
    #?niecza skip '>>>Stub code executed'
    #?pugs todo
    ok eval(RT67790.HOW.perl) === RT67790.HOW, '... and it returns the right thing';
}

# RT #69869
{
    is 1.0.WHAT.gist, Rat.gist, '1.0 is Rat';
    is eval( 1.0.perl ).WHAT.gist, Rat.gist, "1.0 perl'd and eval'd is Rat";
}


# RT #67948
#?DOES 6
#?pugs skip '&ITEM not found'
{
    my @a;
    ([0, 0], [1, 1]).grep({@a.push: .perl; 1}).eager;
    for @a {
        my $n = eval($_);
        isa_ok $n, Array, '.perl in .grep works - type';
        is $n.elems, 2, '.perl in .grep works - number of elems';
        is $n[0], $n[1], '.perl in .grep works - element equality';
    }
}

# Buf
#?niecza skip 'Unhandled exception'
#?pugs skip "doesn't have encode()"
{
    my Blob $a = "asdf".encode();
    is eval($a.perl).decode("utf8"), "asdf";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/signature.t0000664000175000017500000000367612224265625020626 0ustar  moritzmoritzuse v6;

use Test;

plan 13;

# The :() form constructs signatures similar to how \() constructs Captures.
# A subroutine's .signature is a Siglist object.

#L

{
    ok :($a) ~~ Signature, ':($a) create a Signature object';
    my ($a) := \3;
    is $a, 3, 'can bind to one-element signature';
    dies_ok { $a++ }, 'cannot increment an Int';

    my $b = :();
    ok $b.WHAT === Signature, '.WHAT on :() is Signature';
}

{
    my ($x,$y,$z) := (1,2,3);
    is("$x $y $z", "1 2 3", "siglist bindings works");
}

# Same, but more complex
{
    my ($x,@y,*@rest) := (42,[13,17],5,6,7);
    #?pugs todo 'feature'
    is("$x!{@y}!{@rest}", "42!13 17!5 6 7", "complex siglist bindings works (1)");
}

{
    my ($x?) := ();
    ok(!$x.defined, "complex siglist bindings works (2)");
}

# &sub.signature should return a Siglist object
{
    sub foo1 ($a, $b) {}    #OK not used
    my $siglist = :($a, $b);

    ok ~$siglist,
        "a siglist stringifies";
    #?pugs todo 'feature'
    #?rakudo todo 'eqv on signatures'
    ok $siglist eqv &foo1.signature,
        "a subroutine's siglist can be accessed via .signature (1)";
}

# Same as above, but more complex
{
    my sub foo (Num $a, $b?, *@rest) {}    #OK not used
    my $siglist = :(Num $a, $b?, *@rest);

    #?pugs todo 'feature'
    #?rakudo todo 'eqv on signatures'
    ok $siglist eqv &foo.signature ,
        "a subroutine's siglist can be accessed via .signature (2)";
}

{
    my sub foo ($a, $b) {}   #OK not used
    my $siglist = :($a);

    ok $siglist !eqv &foo.signature,
        "a subroutine's siglist can be accessed via .signature (3)";
}

{
    my @a = 1,2,3;
    my (@c) = @a;
    my $i = 0;
    $i++ for @c;
    is $i, 3, 'asigning to an array in a signature is sane';
}

# RT #83512
{
    my @list = 1..4;
    my (:@even, :@odd) := classify { $_ %% 2 ?? 'even' !! 'odd' }, @list;
    is @even, (2, 4), 'siglist binding with a hash works';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/variables-and-packages.t0000775000175000017500000000734612224265625023112 0ustar  moritzmoritzuse v6;

use Test;

plan 38;

# L
#?niecza todo 'System.NullReferenceException: Object reference not set to an instance of an object'
{
    eval_dies_ok 'module MY;', 'MY is an out of scope name';
    eval_dies_ok 'module OUR;', 'OUR is an out of scope name';
    eval_dies_ok 'module GLOBAL;', 'GLOBAL is an out of scope name';
    eval_dies_ok 'module PROCESS;', 'PROCESS is an out of scope name';
    eval_dies_ok 'module OUTER;', 'OUTER is an out of scope name';
    eval_dies_ok 'module CALLER;', 'CALLER is an out of scope name';
    #?pugs todo
    eval_dies_ok 'module DYNAMIC;', 'DYNAMIC is an out of scope name';
    eval_dies_ok 'module COMPILING;', 'COMPILING is an out of scope name';
}

# L

# XXX -- dunno why test test fails, but the next outer test works. --iblech
{ my $a = 1; {
   my $a=2; {
      my $a=3;
      is($a, 3,               'get regular a');
      is($OUTER::a, 2,        'get $OUTER::a');
      is($OUTER::OUTER::a, 1, 'get $OUTER::OUTER::a');
}}}

{
  my $a = 1;
  is $a, 1, 'get regular $a (1)';

  {
    my $a = 2;
    is $a, 2, 'get new regular $a (1)';

    {
      my $a = 3;

      is $a,               3, 'get very new regular $a';
      is $OUTER::a,        2, 'get $OUTER::a';
      is $OUTER::OUTER::a, 1, 'get $OUTER::OUTER::a';
    }
  }
}

# TODO: more smartlinks

{
  my $a = 3;
  my $sub = { $a++ };

  {
    my $a = -10;
    is $a, -10,   'get regular $a';
    is $sub(), 3, 'get hidden $a (1)';
    is $sub(), 4, 'get hidden $a (2)';
    is $sub(), 5, 'get hidden $a (3)';
  }
}

{
  my $sub = -> $stop {
    my $x = 3;
    if $stop {
      $x++;
    } else {
      $sub(1);
      $x;
    }
  };

  is $sub(0), 3,
    "recursively called subref shouldn't stomp on the lexical vars of other instances";
}

{
  sub stomptest ($stop) {
    my $x = 3;
    if $stop {
      $x++;
    } else {
      stomptest 1;
      $x;
    }
  };

  is stomptest(0), 3,
    "recursively called sub shouldn't stomp on the lexical vars of other instances";
}

{
  #?rakudo todo 'nom regression'
  #?niecza todo
  #?pugs todo
  nok foo().defined, "get variable not yet declared using a sub (1)";
  is foo(), 1, "get variable not yet declared using a sub (2)";
  is foo(), 2, "get variable not yet declared using a sub (3)";

  my $a;
  sub foo { $a++ }
}

{
  #?rakudo todo 'nom regression'
  #?niecza todo
  #?pugs todo
  nok bar().defined, "runtime part of my not yet executed (1)";
  is bar(), 1, "runtime part of my not yet executed (2)";
  is bar(), 2, "runtime part of my not yet executed (3)";

  my $a = 3;
  sub bar { $a++ }
}

{
  is baz(), 3, "initilization from BEGIN block (1)";
  is baz(), 4, "initilization from BEGIN block (2)";
  is baz(), 5, "initilization from BEGIN block (3)";

  my $a; BEGIN { $a = 3 };
  sub baz { $a++ }
}

#?rakudo skip 'nom regression'
#?niecza skip 'Undeclared routine grtz'
{
  {
    my $a = 3;
    our sub grtz { $a++ }
  }

  is grtz(), 3, "get real hidden var using a sub (1)";
  is grtz(), 4, "get real hidden var using a sub (1)";
  is grtz(), 5, "get real hidden var using a sub (1)";
}

{
  my $a;
  sub rmbl { $a++ }

  #?rakudo todo 'nom regression'
  #?niecza todo
  #?pugs todo
  nok rmbl().defined, "var captured by sub is the right var (1)";
  $a++;
  is rmbl(), 2, "var captured by sub is the right var (2)";
}

{
  eval_dies_ok(q/
    sub s($i is copy) {
        my @array;
        for 1..3 {
            @array.push($i);
            my $i = 1 + $i;
        }
    };
    s(9);/, "can't redeclare something with an implicit outer binding");
}

#?pugs todo
{
    # RT #74076
    my $t;
    for 'a' {
        $t = sub { $OUTER::_ };
    }
    is $t(), 'a', '$OUTER::_ can access a $_';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-names-vars/varnames.t0000664000175000017500000000157612224265625020436 0ustar  moritzmoritzuse v6;

use Test;

plan 8;

# L

eval_lives_ok 'my $!', '$! can be declared again';
eval_lives_ok 'my $/', 'as can $/';

#?niecza todo
eval_lives_ok 'my proto $!', '$! can be declared again if proto is used though';
#?niecza todo
eval_lives_ok 'my proto $/', 'as can $/';

eval_dies_ok 'my $f!ao = "beh";', "normal varnames can't have ! in their name";
eval_dies_ok 'my $fo:o::b:ar = "bla"', "var names can't have colons in their names either";

#?pugs skip "Can't modify constant item: VObject"
{
    class MyMatch {
        method postcircumfix:<[ ]>($x) {  # METHOD TO SUB CASUALTY
            "foo$x";
        }
    }
    $/ := MyMatch.new;
    #?rakudo 2 skip "cannot easily override [] at the moment"
    is $0, 'foo0', 'Aliasing of $0 into $/ (1)';
    is $4, 'foo4', 'Aliasing of $0 into $/ (2)';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-one-pass-parsing/less-than.t0000664000175000017500000000166712224265625021633 0ustar  moritzmoritzuse v6;

use Test;

plan 9;

# L

# test parsing of < and >, especially distinction between operators
# and terms (when used as a quote as in )
#
# nearly all of these tests had been regressions at one point,
# so don't discard them for being too simple ;-)

ok(rand >= 0, 'random numbers are greater than or equal to 0');
ok(rand < 1, 'random numbers are less than 1');

ok 3 > 0, "3 is greater than 0";


# used to be a pugs regression
#   ~< foo bar >
# doesn't parse (as does +< foo bar >).
is eval('~< foo bar >'), "foo bar", "~<...> is parsed correctly";
is eval('+< foo bar >'),         2, "+<...> is parsed correctly";
ok eval('?< foo bar >'),            "?<...> is parsed correctly";

is eval('~(< foo bar >)'), "foo bar", "~(<...>) is parsed correctly";
is eval('+(< foo bar >)'),         2, "+(<...>) is parsed correctly";
ok eval('?(< foo bar >)'),            "?(<...>) is parsed correctly";

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-packages/package-lookup.t0000664000175000017500000000147712224265625021226 0ustar  moritzmoritzuse v6;
use Test;

plan 7;

# L

class A {
    my $x = 10;
    method x { $A::x = 5; return $A::x; }
    our sub foo() { 'I am foo' };
    method lexical() { $x }
}

isa_ok A::, Stash, 'Typename:: is a Stash';
ok A::<&foo>, 'can access a subroutine in the stash';
ok A:: === A.WHO, 'A::  returns the same as A.WHO';

# RT 74412
my $a = A.new;
is $a.x, 5,
    'can autovivify an our-variable in a class package through its long name from class method';
is $a.lexical, 10, 'but a lexical of the same name is independent';

# RT 75632
lives_ok { my $A::y = 6; $A::y ~~ 6 or die },
    'can declare and access variable in a class package through its long name from outside class';
lives_ok { my $B::x = 7; $B::x ~~ 7 or die },
    'can declare and access variable through its long name without declaring package';
rakudo-2013.12/t/spec/S02-types/anon_block.t0000664000175000017500000001117712224265625020015 0ustar  moritzmoritzuse v6;

use Test;

=begin description

Block tests

This covers anonymous blocks and subs, as well as pointy blocks
(with and without args) and bare blocks.

=end description

plan 42;

# L
# L
# anon blocks
my $anon_sub = sub { 1 };
isa_ok($anon_sub, Sub);
is($anon_sub(), 1, 'sub { } works');

my $anon_sub_w_arg = sub ($arg) { 1 + $arg };
isa_ok($anon_sub_w_arg, Sub);
is($anon_sub_w_arg(3), 4, 'sub ($arg) {} works');

# L
# anon blocks
my $anon_block = { 1 };
isa_ok($anon_block, Block);
is($anon_block(), 1, '{}  works');

# RT #64844
#?niecza skip "Exception NYI"
#?pugs   skip "Exception NYI"
{
    eval '$anon_block( 1 )';
    #?rakudo todo 'Parrot support for zero-arg subs?'
    ok $! ~~ Exception, 'too many parameters';

    if $! !~~ Exception {
        skip q{tests don't work if previous test fails}, 2;
    }
    else {
        my $errmsg = ~$!;

        eval '$anon_block( foo => "RT #64844" )';
        ok $! ~~ Exception, 'too many parameters';
        is ~$!, $errmsg, 'same error for named param as positional';
    }
}

# L
{
    # pointy subs
    my $pointy_block = -> { 1 };
    isa_ok($pointy_block, Block);
    is($pointy_block(), 1, '-> {} <"pointy" block> works');

    my $pointy_block_w_arg = -> $arg { 1 + $arg };
    isa_ok($pointy_block_w_arg, Block);
    is($pointy_block_w_arg(3), 4, '-> $arg {} <"pointy" block w/args> works');

    my $pointy_block_w_multiple_args = -> $arg1, $arg2 { $arg1 + $arg2 };
    isa_ok($pointy_block_w_multiple_args, Block);
    is($pointy_block_w_multiple_args(3, 4), 7, '-> $arg1, $arg2 {} <"pointy" block w/multiple args> works');

    my $pointy_block_nested = -> $a { -> $b { $a + $b }};
    isa_ok($pointy_block_nested, Block);
    isa_ok($pointy_block_nested(5), Block);
    is $pointy_block_nested(5)(6), 11, '-> $a { -> $b { $a+$b }} nested <"pointy" block> works';
}

# L
# bare blocks

my $foo;
{$foo = "blah"};
is($foo, "blah", "lone block actually executes it's content");

my $foo2;
{$foo2 = "blah"};
is($foo2, "blah", "lone block w/out a semicolon actually executes it's content");

my $foo4;
({$foo4 = "blah"},);
ok(!defined($foo4), "block enclosed by parentheses should not auto-execute (2)");

my $one;
my $two;
# The try's here because it should die: $foo{...} should only work if $foo isa
# Hash (or sth. which provides appropriate tieing/&postcircumfix:<{
# }>/whatever, but a Code should surely not support hash access).
# Additionally, a smart compiler will detect thus errors at compile-time, so I
# added an eval().  --iblech
try { eval '0,{$one = 1}{$two = 2}' };
ok(!defined($one), 'two blocks ({} {}) no semicolon after either,.. first block does not execute');
is($two, 2, '... but second block does (parsed as hash subscript)');

my $one_a;
my $two_a;
{$one_a = 1}; {$two_a = 2}
is($one_a, 1, '... two blocks ({}; {}) semicolon after the first only,.. first block does execute');
is($two_a, 2, '... and second block does too');

my $one_b;
my $two_b;
{
    $one_b = 1
}
{
    $two_b = 2
};
is($one_b, 1, '... two stand-alone blocks ({\n...\n}\n{\n...\n}),.. first block does execute');
is($two_b, 2, '... and second block does too');

my $one_c;
my $two_c;
{$one_c = 1}; {$two_c = 2};
is($one_c, 1, '... two blocks ({}; {};) semicolon after both,.. first block does execute');
is($two_c, 2, '... and second block does too');

sub f { { 3 } }
is(f(), 3, 'bare blocks immediately runs even as the last statement');
is((sub { { 3 } }).(), 3, 'ditto for anonymous subs');
is((sub { { { 3 } } }).(), 3, 'ditto, even if nested');
dies_ok({(sub { { $^x } }).()}, 'implicit params become errors');
isnt((sub { -> { 3 } }).(), 3, 'as are pointies');

# RT #68116
{
    sub rt68116 { 68116 }
    is &rt68116(), 68116, 'check that sub is callable via &';
    #?pugs 2 skip "is multi"
    is { &^x() }.( &rt68116 ), 68116,
        'call via { &^pos() }( &s ) works for sub';
    is -> &x { &x() }.( &rt68116 ), 68116,
        'call via -> &point { &point() }.( &s ) works for sub';
    is (sub (&x) { &x() }).( &rt68116 ), 68116,
        'call via (sub (&x) { &x() }).( &s ) works for sub';
}

#?niecza skip 'No candidates for dispatch to mone'
#?pugs skip 'parsefail'
{
    proto mone(|) { * }
    multi mone { 'one' }
    is &mone(), 'one', 'check that mutli is callable via &';
    is { &^x() }.( &mone ), 'one',
        'call via { &^pos() }( &s ) works for multi';
    is -> &x { &x() }.( &mone ), 'one',
        'call via -> &point { &point() }.( &s ) works for multi';
    is (sub (&x) { &x() }).( &mone ), 'one',
        'call via (sub (&x) { &x() }).( &s ) works for multi';
    
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/array_extending.t0000664000175000017500000000656112224265625021074 0ustar  moritzmoritzuse v6;

use Test;

plan 21;

# L
{
    # Compare with Perl 5:
    #   $ perl -we '
    #     my @array = qw;
    #     my $foo = $array[100];
    #     print exists $array[30] ? "exists" : "does not exist"
    #   '
    #   does not exist
    my @array = ;
    is +@array, 4, "basic sanity";
    my $foo = @array[20];
    # We've only *accessed* @array[20], but we haven't assigned anything to it, so
    # @array shouldn't change. But currently, @array *is* automatically extended,
    # i.e. @array is ("a", "b", "c", "d", Mu, Mu, ...). This is wrong.
    is +@array, 4,
      "accessing a not existing array element should not automatically extend the array";
}

{
    my @array = ;
    @array[20] = 42;
    # Now, we did assign @array[20], so @array should get automatically extended.
    # @array should be ("a", "b", "c", "d", Mu, Mu, ..., 42).
    is +@array, 21,
      "creating an array element should automatically extend the array (1)";
    # And, of course, @array[20]:exists has to be true -- we've just assigned
    # @array[20].
    #?niecza skip 'Unable to resolve method exists in class Array'
    #?pugs skip ':exists'
    ok @array[20]:exists,
      "creating an array element should automatically extend the array (2)";
}

{
    my @array   = ;
    my $defined = defined @array[100];

    ok !$defined,
        'defined @array[$index_out_of_bounds] should be false';
    is +@array, 4,
        'defined @array[$index_out_of_bounds] should not have altered @array';
}

{
    my @array   = ;
    my $defined;
    try { $defined = defined @array[*-5]; }

    #?pugs todo
    ok !$defined,
        'defined @array[$negative_index_out_of_bounds] should be false';
    is +@array, 4,
        'defined @array[$negative_index_out_of_bounds] should not have altered @array';
}

#?niecza skip 'Unable to resolve method exists in class Array'
#?pugs skip ':exists'
{
    my @array  = ;
    my $exists = @array[100]:exists;

    ok !$exists,
        '@array[$index_out_of_bounds]:exists should be false';
    is +@array, 4,
        '@array[$index_out_of_bounds]:exists should not have altered @array';
}
    
#?niecza skip 'Unable to resolve method exists in class Array'
#?pugs skip ':exists'
{
    my @array  = ;
    my $exists = @array[-5]:exists;

    ok !$exists,
        '@array[$negative_index_out_of_bounds]:exists should be false';
    is +@array, 4,
        '@array[$negative_index_out_of_bounds]:exists should not have altered @array';
}

{
    my @a;
    @a[2] = 6;
    is +@a, 3, '@a[2] = 6 ensures that @a has three items';
    nok @a[0].defined, '... and the first is not defined';
    nok @a[1].defined, '... and the second is not defined';
    is @a[2], 6,       '... and  the third is 6';
}

# RT #62948
{
    my @a;
    @a[2] = 'b';
    my @b = @a;
    is +@b, 3, 'really a degenerative case of assigning list to array';
    @b = (6, @a);
    is +@b, 4, 'assigning list with extended array to an array';
    my $s = @a.join(':');
    is $s, '::b', 'join on extended array';
    my $n = + @a.grep({ $_ eq 'b'});
    is $n, 1, 'grep on extended array';
    @a[1] = 'c'; # cmp doesn't handle Mu cmp Mu yet
    #?niecza todo 'min on list with undefined el ignores it'
    #?pugs todo
    is @a.min(), 'b', 'min on list with undefined el ignores it';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/array_ref.t0000664000175000017500000001076712224265625017666 0ustar  moritzmoritzuse v6;

use Test;

plan 45;

# array_ref of strings

my $array_ref1 = ("foo", "bar", "baz");
#?pugs skip 'Parcel'
isa_ok($array_ref1, Parcel);

is(+$array_ref1, 3, 'the array_ref1 has 3 elements');
is($array_ref1[0], 'foo', 'got the right value at array_ref1 index 0');
is($array_ref1[1], 'bar', 'got the right value at array_ref1 index 1');
is($array_ref1[2], 'baz', 'got the right value at array_ref1 index 2');

is($array_ref1.[0], 'foo', 'got the right value at array_ref1 index 0 using the . notation');

# array_ref with strings, numbers and undef

my $array_ref2 = [ "test", 1, Mu ];
isa_ok($array_ref2, Array);
is(+$array_ref2, 3, 'the array_ref2 has 3 elements');
is($array_ref2[0], 'test', 'got the right value at array_ref2 index 0');
is($array_ref2[1], 1,      'got the right value at array_ref2 index 1');
ok(!$array_ref2[2].defined,'got the right value at array_ref2 index 2');

# array_ref slice

# NOTE:
# the [] creation must be forced here, because $array_ref = is
# not seen as array_ref context, because it's not

my $array_ref4 = [ $array_ref2[2, 1, 0] ];
isa_ok($array_ref4, Array);

{
    is(+$array_ref4, 3, 'the array_ref4 has 3 elements');
    ok(!$array_ref4[0].defined, 'got the right value at array_ref4 index 0');
    is($array_ref4[1], 1,      'got the right value at array_ref4 index 1');
    is($array_ref4[2], 'test', 'got the right value at array_ref4 index 2');
}

# create new array_ref with 2 array_ref slices

my $array_ref5 = [ $array_ref2[2, 1, 0], $array_ref1[2, 1, 0] ];
isa_ok($array_ref5, Array);

{
    is(+$array_ref5, 6, 'the array_ref5 has 6 elements');
    ok(!$array_ref5[0].defined, 'got the right value at array_ref5 index 0');
    is($array_ref5[1], 1,      'got the right value at array_ref5 index 1');
    is($array_ref5[2], 'test', 'got the right value at array_ref5 index 2');
    is($array_ref5[3], 'baz',  'got the right value at array_ref5 index 3');
    is($array_ref5[4], 'bar',  'got the right value at array_ref5 index 4');
    is($array_ref5[5], 'foo',  'got the right value at array_ref5 index 5');
}

# create an array_ref slice with an array_ref (in a variable)

{
    my $slice = [ 2, 0, 1 ];
    my $array_ref6 = [ $array_ref1[@($slice)] ];
    isa_ok($array_ref6, Array);

    is(+$array_ref6, 3, 'the array_ref6 has 3 elements');
    is($array_ref6[0], 'baz', 'got the right value at array_ref6 index 0');
    is($array_ref6[1], 'foo', 'got the right value at array_ref6 index 1');
    is($array_ref6[2], 'bar', 'got the right value at array_ref6 index 2');
}

# create an array_ref slice with an array_ref constructed with []

my $array_ref7 = [ $array_ref1[(2, 1, 0)] ];
isa_ok($array_ref7, Array);

{
    is(+$array_ref7, 3, 'the array_ref7 has 3 elements');
    is($array_ref7[0], 'baz', 'got the right value at array_ref7 index 0');
    is($array_ref7[1], 'bar', 'got the right value at array_ref7 index 1');
    is($array_ref7[2], 'foo', 'got the right value at array_ref7 index 2');
}

my $array_ref8 = [ 1, 2, 3, ];
is(+$array_ref8, 3, "trailing commas make correct array");

# recursive array
my $array9 = [42, "nothing"];
$array9[1] = $array9;
isa_ok $array9,             Array;
isa_ok $array9[1],          Array;
is     $array9[0],          42, "recursive array access (0)";
is     $array9[1][0],       42, "recursive array access (1)";
is     $array9[1][1][0],    42, "recursive array access (2)";
is     $array9[1][1][1][0], 42, "recursive array access (3)";

# changing nested array
{
    my $array10 = [[2]];
    $array10[0][0] = 6;
    is $array10[0][0], 6, "changing nested array (1)";
    my $array11 = [[2,3]];
    $array11[0][0] = 6;
    is $array11[0][0], 6, "changing nested array (2)";
}

# creating a AoA using ";" doesn't work any longer
# As of L<"http://www.nntp.perl.org/group/perl.perl6.language/20795">:
#   In ordinary list context, infix:<;> is just a list-op-ending "big comma",
#   but is otherwise treated like an ordinary comma (but only if the
#   list is in some kind of brackets, of course).
#my $array11;
#eval '$array11 = [ "a","b","c"; "d","e","f" ]';
#is +$array11,      2, "AoA created using ';' contains correct number of elems";
#is +$array11[0],   3, "AoA's subarray created using ';' contains correct number of elems";
#is $array11[1][1], "e", "AoA created using ';' contains correct elem";

# [] creates new containers (() does not)
{
  my $foo;
  ok !([$foo][0] =:= $foo), "creating arrays using [] creates new containers (1)";
}

{
  my $foo;
  my $arrayref = [$foo];
  ok $arrayref[0] !=:= $foo, "creating arrays using [] creates new containers (2)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/array-shapes.t0000664000175000017500000000400412224265625020276 0ustar  moritzmoritzuse v6;
use Test;
plan(*);

# L

{
    my @arr[*];
    @arr[42] = "foo";
    is(+@arr, 43, 'my @arr[*] autoextends like my @arr');
}

{
    my @arr[7] = ;
    is(@arr, [], 'my @arr[num] can hold num things');
    dies_ok({push @arr, 'h'}, 'adding past num items in my @arr[num] dies');
    dies_ok({@arr[7]}, 'accessing past num items in my @arr[num] dies');
}

{
    lives_ok({ my @arr\    [7]}, 'array with fixed size with unspace');
    eval_dies_ok('my @arr.[8]', 'array with dot form dies');
    eval_dies_ok('my @arr\    .[8]', 'array with dot form and unspace dies');
}

# L

{
    my @arr of Int = 1, 2, 3, 4, 5;
    is(@arr, <1 2 3 4 5>, 'my @arr of Type works');
    #?rakudo 2 todo "parametrization issues"
    dies_ok({push @arr, 's'}, 'type constraints on my @arr of Type works (1)');
    dies_ok({push @arr, 4.2}, 'type constraints on my @arr of Type works (2)');
}

{
    my @arr[5] of Int = <1 2 3 4 5>;
    is(@arr, <1 2 3 4 5>, 'my @arr[num] of Type works');

    dies_ok({push @arr, 123}, 'boundary constraints on my @arr[num] of Type works');
    pop @arr; # remove the last item to ensure the next ones are type constraints
    dies_ok({push @arr, 's'}, 'type constraints on my @arr[num] of Type works (1)');
    dies_ok({push @arr, 4.2}, 'type constraints on my @arr[num] of Type works (2)');
}

{
    my int @arr = 1, 2, 3, 4, 5;
    is(@arr, <1 2 3 4 5>, 'my Type @arr works');
    dies_ok({push @arr, 's'}, 'type constraints on my Type @arr works (1)');
    dies_ok({push @arr, 4.2}, 'type constraints on my Type @arr works (2)');
}

{
    my int @arr[5] = <1 2 3 4 5>;
    is(@arr, <1 2 3 4 5>, 'my Type @arr[num] works');

    dies_ok({push @arr, 123}, 'boundary constraints on my Type @arr[num] works');
    pop @arr; # remove the last item to ensure the next ones are type constraints
    dies_ok({push @arr, 's'}, 'type constraints on my Type @arr[num] works (1)');
    dies_ok({push @arr, 4.2}, 'type constraints on my Type @arr[num]  works (2)');
}
rakudo-2013.12/t/spec/S02-types/array.t0000664000175000017500000002352412224265625017025 0ustar  moritzmoritzuse v6;

use Test;

plan 99;

#L

{
    my $i = 0;
    $i++ for 1, 2, 3;
    is $i, 3, 'for 1, 2, 3 does three iterations';
}


{
    # see RT #63350 for discussion
    # also: 78284
    my $i = 0;
    $i++ for (1, 2, 3).item;
    #?pugs todo
    is $i, 1, 'for (1, 2, 3).item does one iteration';

    $i = 0;
    $i++ for $(1, 2, 3);
    #?pugs todo
    is $i, 1, 'for $(1, 2, 3) does one iteration';
}

{
    my $i = 0;
    $i++ for [1, 2, 3];
    is $i, 1, 'for [1, 2, 3] does one iteration';
}

# uninitialized array variables should work too...
#?pugs todo
{
    my @a;
    is eval(@a.perl).elems, 0, '@a.perl on uninitialized variable';
}

# array of strings

my @array1 = ("foo", "bar", "baz");
isa_ok(@array1, Array);

is(+@array1, 3, 'the array1 has 3 elements');
is(@array1[0], 'foo', 'got the right value at array1 index 0');
is(@array1[1], 'bar', 'got the right value at array1 index 1');
is(@array1[2], 'baz', 'got the right value at array1 index 2');


is(@array1.[0], 'foo', 'got the right value at array1 index 0 using the . notation');


# array with strings, numbers and undef
my @array2 = ("test", 1, Mu);

{
    isa_ok(@array2, Array);

    is(+@array2, 3, 'the array2 has 3 elements');
    is(@array2[0], 'test', 'got the right value at array2 index 0');
    is(@array2[1], 1,      'got the right value at array2 index 1');
    ok(!@array2[2].defined,  'got the right value at array2 index 2');
}

# combine 2 arrays
{
    my @array3 = (@array1, @array2);
    isa_ok(@array3, Array);

    is(+@array3, 6, 'the array3 has 6 elements');
    is(@array3[0], 'foo', 'got the right value at array3 index 0');
    is(@array3[1], 'bar', 'got the right value at array3 index 1');
    is(@array3[2], 'baz', 'got the right value at array3 index 2');
    is(@array3[3], 'test', 'got the right value at array3 index 3');
    is(@array3[4], 1,      'got the right value at array3 index 4');
    ok(!@array3[5].defined,'got the right value at array3 index 5');
}

{
    # array slice
    my @array4 = @array2[2, 1, 0];
    isa_ok(@array4, Array);

    is(+@array4, 3, 'the array4 has 3 elements');
    ok(!defined(@array4[0]), 'got the right value at array4 index 0');
    is(@array4[1], 1,      'got the right value at array4 index 1');
    is(@array4[2], 'test', 'got the right value at array4 index 2');
}

{
    # create new array with 2 array slices
    my @array5 = ( @array2[2, 1, 0], @array1[2, 1, 0] );
    isa_ok(@array5, Array);

    is(+@array5, 6, 'the array5 has 6 elements');
    ok(!defined(@array5[0]),  'got the right value at array5 index 0');
    is(@array5[1], 1,      'got the right value at array5 index 1');
    is(@array5[2], 'test', 'got the right value at array5 index 2');
    is(@array5[3], 'baz',  'got the right value at array5 index 3');
    is(@array5[4], 'bar',  'got the right value at array5 index 4');
    is(@array5[5], 'foo',  'got the right value at array5 index 5');
}

{
    # create an array slice with an array (in a variable)

    my @slice = (2, 0, 1);
    my @array6 = @array1[@slice];
    isa_ok(@array6, Array);

    is(+@array6, 3, 'the array6 has 3 elements');
    is(@array6[0], 'baz', 'got the right value at array6 index 0');
    is(@array6[1], 'foo', 'got the right value at array6 index 1');
    is(@array6[2], 'bar', 'got the right value at array6 index 2');
}

{
    # create an array slice with an array constructed with ()
    my @array7 = @array1[(2, 1, 0)];
    isa_ok(@array7, Array);

    is(+@array7, 3, 'the array7 has 3 elements');
    is(@array7[0], 'baz', 'got the right value at array7 index 0');
    is(@array7[1], 'bar', 'got the right value at array7 index 1');
    is(@array7[2], 'foo', 'got the right value at array7 index 2');
}

{
    # odd slices
    my $result1 = (1, 2, 3, 4)[1];
    is($result1, 2, 'got the right value from the slice');

    my $result2 = [1, 2, 3, 4][2];
    is($result2, 3, 'got the right value from the slice');
}

# swap two elements test moved to t/op/assign.t

# empty arrays
{
    my @array9;
    isa_ok(@array9, Array);
    is(+@array9, 0, "new arrays are empty");

    my @array10 = (1, 2, 3,);
    is(+@array10, 3, "trailing commas make correct array");
}

#?pugs todo "multi-dim arrays not implemented"
#?rakudo skip "multi-dim arrays"
#?niecza skip "multi-dim arrays"
{
# declare a multidimension array
    eval_lives_ok('my @multidim[0..3; 0..1]', "multidimension array");
    my @array11 is shape(2,4);

    # XXX what should that test actually do?
    ok(eval('@array11[2;0] = 12'), "push the value to a multidimension array");
}

{
    # declare the array with data type
    my Int @array;
    lives_ok { @array[0] = 23 },                   "stuffing Ints in an Int array works";
    #?niecza todo "type constraints"
    #?pugs todo
    dies_ok  { @array[1] = $*ERR }, "stuffing IO in an Int array does not work";
}

#?pugs skip "no whatever star yet"
{
    my @array12 = ('a', 'b', 'c', 'e');

    # indexing from the end
    is @array12[*-1],'e', "indexing from the end [*-1]";

    # end index range
    #?niecza skip "WhateverCode/.. interaction"
    is ~@array12[*-4 .. *-2], 'a b c', "end indices [*-4 .. *-2]";

    # end index as lvalue
    @array12[*-1]   = 'd';
    is @array12[*-1], 'd', "assigns to the correct end slice index";
    is ~@array12,'a b c d', "assignment to end index correctly alters the array";
}

#?pugs skip "no whatever star yet"
#?niecza skip "*/.. interaction"
{
    my @array13 = ('a', 'b', 'c', 'd');
    # end index range as lvalue
    @array13[*-4 .. *-1]   = ('d', 'c', 'b', 'a'); # ('a'..'d').reverse
    is ~@array13, 'd c b a', "end range as lvalue";

    #hat trick
    my @array14 = ('a', 'b', 'c', 'd');
    my @b = 0..3;
    ((@b[*-3,*-2,*-1,*-4] = @array14)= @array14[*-1,*-2,*-3,*-4]);

    is ~@b,
        'a d c b',
        "hat trick:
        assign to a end-indexed slice array from array
        lvalue in assignment is then lvalue to end-indexed slice as rvalue";
}

# RT #76676
#?niecza todo
#?pugs todo
{
    is ~.[^10], 'a b', 'Range subscript as rvalues clip to existing elems';
}

# This test may seem overly simplistic, but it was actually a bug in PIL2JS, so
# why not write a test for it so other backends can benefit of it, too? :)
{
  my @arr = (0, 1, 2, 3);
  @arr[0] = "new value";
  is @arr[0], "new value", "modifying of array contents (constants) works";
}

{
  my @arr;
  #?niecza skip "Failure NYI"
  #?pugs skip "Failure NYI"
  ok @arr[*-1] ~~ Failure, "readonly accessing [*-1] of an empty array gives Failure";
  ok !(try { @arr[*-1] }), "readonly accessing [*-1] of an empty array does not die";
  #?pugs 2 todo
  dies_ok { @arr[*-1] = 42 },      "assigning to [*-1] of an empty array is fatal";
  dies_ok { @arr[*-1] := 42 },     "binding [*-1] of an empty array is fatal";
}

{
  my @arr = (23);
  #?niecza skip "Failure NYI"
  #?pugs skip "Failure NYI"
  ok @arr[*-2] ~~ Failure, "readonly accessing [*-2] of an one-elem array gives Failure";
  #?pugs 3 todo
  ok !(try { @arr[*-2] }), "readonly accessing [*-2] of an one-elem array does not die";
  dies_ok { @arr[*-2] = 42 },      "assigning to [*-2] of an one-elem array is fatal";
  dies_ok { @arr[*-2] := 42 },     "binding [*-2] of an empty array is fatal";
}

{
  my @arr = ;
  my $minus_one = -1;

  eval_dies_ok '@arr[-1]', "readonly accessing [-1] of normal array is compile-time error";
  #?niecza todo '@arr[-1] returns undef'
  #?pugs todo
  dies_ok { @arr[ $minus_one ] }, "indirectly accessing [-1] " ~
                                   "through a variable is run-time error";
  #?pugs todo
  dies_ok { @arr[$minus_one] = 42 }, "assigning to [-1] of a normal array is fatal";
  #?pugs todo
  dies_ok { @arr[$minus_one] := 42 }, "binding [-1] of a normal array is fatal";
}

# RT #73308
{
    is [][].elems, 0, '[][] returns empty list/array';
}

# RT #58372 and RT #57790
# by current group understanding of #perl6, postcircumifx:<[ ]> is actually
# defined in Any, so that .[0] is the identity operation for non-Positional
# types
{
    is 1[0], 1, '.[0] is identity operation for scalars (Int)';
    is 'abc'[0], 'abc', '.[0] is identity operation for scalars (Str)';
    nok 'abc'[1].defined, '.[1] on a scalar is not defined';
    #?pugs skip "Failure"
    #?niecza skip "Failure NYI"
    isa_ok 1[1],  Failure, 'indexing a scalar with other than 0 returns a Failure';
    #?pugs todo
    dies_ok { Mu.[0] }, 'but Mu has no .[]';
}

#RT #77072
#?niecza skip "Zen slices"
#?pugs todo
{
    my @a = <1 2 3>;
    is @a[*], <1 2 3> , 'using * to access all array elements works';
}

#RT #73402
{
    my @a = <1 2 3>;
    isa_ok +@a, Int, "Numifying an Array yields an Int";
}

#RT #75342
{
    my @a = 0, 1, 2;
    for @a {
        $_++ if $_;
    }
    is ~@a, '0 2 3', "modifier form of 'if' within 'for' loop works";
    
    my @b = 0, 1, 2;
    for @b {
        if $_ {
            $_++;
        }
    }
    is ~@b, '0 2 3', "non-modifier form of 'if' within 'for' loop also works"
}

# RT #95850
# Array.hash used to eat up the array in some early version of rakudo/nom
#?pugs skip '.hash'
{
    my @a = a => 1, b => 2;
    my %h = @a.hash;
    is %h.elems, 2, 'Array.hash created a sensible hash';
    is @a.elems, 2, '... and did not consume itself in the process';
}

# RT #79270
#?niecza skip 'Cannot use value like WhateverCode as a number'
#?pugs skip 'parsefail'
{
    my @a = ;
    @a[0 ..^ *-1] >>~=>> "x";
    is @a.join(','), 'ax,bx,c', '0..^ *-1 works as an array index';
}

#?niecza skip 'coercion syntax'
#?pugs skip "Array"
{
    is Array(1,2,3).WHAT.gist, '(Array)', 'Array(...) makes an Array';
    ok Array(1,2,3) eqv [1,2,3],          'Array(1,2,3) makes correct array';
}

#?niecza skip "throws_like"
#?pugs skip 'Test Util parsefail'
#?DOES 8
{
    use lib "t/spec/packages";
    use Test::Util;
    throws_like 'my @a = 1..*; @a[Inf] = "dog"', X::Item, index => Inf, aggregate => 1..*;
    throws_like 'my @a = 1..*; @a[NaN] = "cat"', X::Item, index => NaN, aggregate => 1..*;
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/assigning-refs.t0000664000175000017500000000637612224265625020634 0ustar  moritzmoritzuse v6;

use Test;

# See thread "@array = $scalar" on p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22959">

plan 18;

# @array = $arrayref
{
  my $arrayref = [];
  my @array    = ($arrayref,);

  is +@array, 1, '@array = ($arrayref,) does not flatten the arrayref';
}

{
  my $arrayref = [];
  my @array    = ($arrayref);

  is +@array, 1, '@array = ($arrayref) does not flatten the arrayref';
}

{
  my $arrayref = [];
  my @array    = $arrayref;

  is +@array, 1, '@array = $arrayref does not flatten the arrayref';
}

# %hash = $hashref
# Of course, these (should) give a warning ("odd number in hash construction").
{
  my $hashref = {:a(1), :b(2), :c(3)};
  my %hash;
  try { %hash = ($hashref,) };

  #?rakudo todo 'non-flattening hash refs'
  #?niecza todo
  is +%hash, 0, '%hash = ($hashref,) does not flatten the hashref';
}

{
  my $hashref = {:a(1), :b(2), :c(3)};
  my %hash    = ($hashref);

  #?rakudo todo 'non-flattening hash refs'
  #?pugs todo 'non-flattening hash refs'
  #?niecza todo
  is +%hash, 0, '%hash = ($hashref) does not flatten the hashref';
}

{
  my $hashref = {:a(1), :b(2), :c(3)};
  my %hash    = $hashref;

  #?rakudo todo 'non-flattening hash refs'
  #?pugs todo 'non-flattening hash refs'
  #?niecza todo
  is +%hash, 0, '%hash = $hashref does not flatten the hashref';
}

# Same as above, but now we never use arrays, but only array*refs*.
# $arrayref2 = $arrayref1
{
  my $foo = [];
  my $bar = ($foo,);

  is +$bar, 1, '$bar = ($foo,) does not flatten the arrayref';
}

{
  my $foo = [];
  my $bar = ($foo);

  is +$bar, 3, '$bar = ($foo) does flatten the arrayref';
}

{
  my $foo = [];
  my $bar = $foo;

  is +$bar, 3, '$bar = $foo does flatten the arrayref';
}

# $hashref2 = $hashref1
# Of course, these (should) give a warning ("odd number in hash construction").
{
  my $foo = {:a(1), :b(2), :c(3)};
  my $bar = ($foo,);

  is +$bar, 1, '$bar = ($foo,) does not flatten the hashref';
}

{
  my $foo = {:a(1), :b(2), :c(3)};
  my $bar = ($foo);

  is +$bar, 3, '$bar = ($foo) does flatten the hashref';
}

{
  my $foo = {:a(1), :b(2), :c(3)};
  my $bar = $foo;

  is +$bar, 3, '$bar = $foo does flatten the hashref';
}

# Same as above, but now we directly assign into an element.
{
  my $arrayref = [];
  my @array;
  @array[0]    = ($arrayref,);

  is +@array, 1, '@array[0] = ($arrayref,) does not flatten the arrayref';
}

{
  my $arrayref = [];
  my @array;
  @array[0]    = ($arrayref);

  is +@array, 1, '@array[0] = ($arrayref) does not flatten the arrayref';
}

{
  my $arrayref = [];
  my @array;
  @array[0]    = $arrayref;

  is +@array, 1, '@array[0] = $arrayref does not flatten the arrayref';
}

# Of course, these (should) give a warning ("odd number in hash construction").
{
  my $hashref = {:a(1), :b(2), :c(3)};
  my %hash;
  %hash    = ($hashref,);

  is +%hash, 1, '%hash = ($hashref,) does not flatten the hashref';
}

{
  my $hashref = {:a(1), :b(2), :c(3)};
  my %hash;
  %hash    = ($hashref);

  is +%hash, 1, '%hash = ($hashref) does not flatten the hashref';
}

{
  my $hashref = {:a(1), :b(2), :c(3)};
  my %hash;
  %hash    = $hashref;

  is +%hash, 1, '%hash = $hashref does not flatten the hashref';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/autovivification.t0000664000175000017500000000522412224265625021267 0ustar  moritzmoritzuse v6;

use Test;

plan 25;

# L
#?pugs todo
{
    my %h;
    my $b = %h;
    is %h.keys.elems, 0, "fetching doesn't autovivify.";
    ok $b === Any, 'and the return value is not defined';
}

#?pugs skip ':exists'
{
    my %h;
    my $exists = %h:exists;
    is %h.keys.elems, 0, "exists doesn't autovivify.";
    ok $exists === False, '... and it returns the right value';
}

# L
#?pugs todo
{
    my %h;
    bar(%h);
    is %h.keys.elems, 0, "in ro arguments doesn't autovivify.";
}

{
    my %h;
    my $b := %h;
    #?pugs todo
    #?niecza todo "https://github.com/sorear/niecza/issues/176"
    is %h.keys.elems, 0, 'binding does not immediately autovivify';
    #?pugs todo
    ok $b === Any, '... to an undefined value';
    $b = 42;
    is %h.keys.elems, 1, '.. but autovivifies after assignment';
    is %h, 42, 'having it in there';
    ok %h =:= $b, 'check binding';
}

#?pugs todo
{
    my %h;
    my $b = \(%h);
    is %h.keys.elems, 0, 'capturing does not autovivify';
}

{
    my %h;
    foo(%h);
    #?pugs todo
    #?niecza todo "https://github.com/sorear/niecza/issues/176"
    is %h.keys.elems, 0, 'in rw arguments does not autovivify';
    foo(%h,42);
    is %h.keys.elems, 1, 'storing from within the sub does autovivify';
    is %h, 42, 'got the right value';
}

{
    my %h;
    %h = 42;
    is %h.keys.elems, 1, 'store autovivify.';
    is %h, 42, 'got the right value';
}

# helper subs
sub foo ($baz is rw, $assign? ) { $baz = $assign if $assign }
sub bar ($baz is readonly) { }

# RT #77038
#?niecza skip "Unable to resolve method push in type Any"
{
    my %h;
    push %h, 4, 2;
    is %h.join, '42', 'can autovivify in sub form of push';
    unshift %h, 5, 3;
    is %h.join, '53', 'can autovivify in sub form of unshift';
    %h.push( 7, 8 );
    is %h.join, '78', 'can autovivify in method form of push';
    %h.unshift( 9, 10 );
    is %h.join, '910', 'can autovivify in method form of unshift';
    is %h.keys.elems, 4, 'successfully autovivified lower level';
}

{
    my $a;
    $a[0] = '4';
    $a[1] = '2';
    is $a.join, '42', 'Can autovivify Array';
}

# RT #77048
{
    my Array $a;
    $a[0] = '4';
    $a[1] = '2';
    is $a.join, '42', 'Can autovivify Array-typed scalar';
}

{
    my $h;
    $h = '4';
    $h = '2';
    is $h.join, '42', 'Can autovivify Hash';
}

{
    my Hash $h;
    $h = '4';
    $h = '2';
    is $h.join, '42', 'Can autovivify Hash-typed scalar';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/baghash.t0000664000175000017500000004706312250462647017312 0ustar  moritzmoritzuse v6;
use Test;

plan 225;

# L

# A BagHash is a QuantHash of UInt, i.e. the values are positive Int

sub showkv($x) {
    $x.keys.sort.map({"$_:{$x{$_}}"}).join(' ')
}

# L

{
    say "We do get here, right?";
    my $b = BagHash.new("a", "foo", "a", "a", "a", "a", "b", "foo");
    isa_ok $b, BagHash, 'we got a BagHash';
    is showkv($b), 'a:5 b:1 foo:2', '...with the right elements';

    is $b.default, 0, "Defaults to 0";
    is $b, 5, 'Single-key subscript (existing element)';
    isa_ok $b, Int, 'Single-key subscript yields an Int';
    is $b, 0, 'Single-key subscript (nonexistent element)';
    isa_ok $b, Int, 'Single-key subscript yields an Int (nonexistent element)';
    ok $b:exists, 'exists with existing element';
    nok $b:exists, 'exists with nonexistent element';

    is $b.values.elems, 3, "Values returns the correct number of values";
    is ([+] $b.values), 8, "Values returns the correct sum";
    ok ?$b, "Bool returns True if there is something in the BagHash";
    nok ?BagHash.new(), "Bool returns False if there is nothing in the BagHash";
    
    my $hash;
    lives_ok { $hash = $b.hash }, ".hash doesn't die";
    isa_ok $hash, Hash, "...and it returned a Hash";
    is showkv($hash), 'a:5 b:1 foo:2', '...with the right elements';

    dies_ok { $b.keys =  }, "Can't assign to .keys";
    dies_ok { $b.values = 3, 4 }, "Can't assign to .values";

    is ~$b, "5 1", 'Multiple-element access';
    is ~$b, "5 0 1 0", 'Multiple-element access (with nonexistent elements)';

    #?pugs   skip '.total NYI'
    is $b.total, 8, '.total gives sum of values';
    is $b.elems, 3, '.elems gives number of elements';
    is +$b, 8, '+$bag gives sum of values';

    lives_ok { $b = 42 }, "Can assign to an existing element";
    is $b, 42, "... and assignment takes effect";
    lives_ok { $b = 12 }, "Can assign to a new element";
    is $b, 12, "... and assignment takes effect";
    lives_ok { $b = 0 }, "Can assign zero to a nonexistent element";
    nok $b:exists, "... and that didn't create the element";
    lives_ok { $b = 0 }, "Can assign zero to a existing element";
    nok $b:exists, "... and it goes away";
    
    lives_ok { $b++ }, "Can ++ an existing element";
    is $b, 43, "... and the increment happens";
    lives_ok { $b++ }, "Can ++ a new element";
    is $b, 1, "... and the element is created";
    lives_ok { $b-- }, "Can -- an existing element";
    is $b, 42, "... and the decrement happens";
    lives_ok { $b-- }, "Can -- an element with value 1";
    nok $b:exists, "... and it goes away";
    #?niecza todo
    dies_ok { $b-- }, "Cannot -- an element that doesn't exist";
    nok $b:exists, "... and everything is still okay";
}

{
    ok (BagHash.new: ) ~~ (BagHash.new: ), "Identical bags smartmatch with each other";
    ok (BagHash.new: ) ~~ (BagHash.new: ), "Identical bags smartmatch with each other";
    nok (BagHash.new: ) ~~ (BagHash.new: ), "Subset does not smartmatch";
    nok (BagHash.new: ) ~~ (BagHash.new: ), "Subset (only quantity different) does not smartmatch";
    nok (BagHash.new: ) ~~ (BagHash.new: ), "Superset does not smartmatch";
    nok (BagHash.new: ) ~~ (BagHash.new: ), "Superset (only quantity different) does not smartmatch";
    nok "a" ~~ (BagHash.new: ), "Smartmatch is not element of";
    ok (BagHash.new: ) ~~ BagHash, "Type-checking smartmatch works";

    ok (set ) ~~ (BagHash.new: ), "Set smartmatches with equivalent BagHash.new:";
    nok (set ) ~~ (BagHash.new: ), "... but not if the Bag has greater quantities";
    nok (set ) ~~ BagHash, "Type-checking smartmatch works";
}

{
    isa_ok "a".BagHash, BagHash, "Str.BagHash makes a BagHash";
    is showkv("a".BagHash), 'a:1', "'a'.BagHash is bag a";

    isa_ok (a => 100000).BagHash, BagHash, "Pair.BagHash makes a BagHash";
    is showkv((a => 100000).BagHash), 'a:100000', "(a => 100000).BagHash is bag a:100000";
    is showkv((a => 0).BagHash), '', "(a => 0).BagHash is the empty bag";

    isa_ok .BagHash, BagHash, ".BagHash makes a BagHash";
    is showkv(.BagHash), 'a:2 b:1 c:1', ".BagHash makes the bag a:2 b:1 c:1";
    is showkv(["a", "b", "c", "a"].BagHash), 'a:2 b:1 c:1', "[a b c a].BagHash makes the bag a:2 b:1 c:1";
    is showkv([a => 3, b => 0, 'c', 'a'].BagHash), 'a:4 c:1', "[a => 3, b => 0, 'c', 'a'].BagHash makes the bag a:4 c:1";

    isa_ok {a => 2, b => 4, c => 0}.BagHash, BagHash, "{a => 2, b => 4, c => 0}.BagHash makes a BagHash";
    is showkv({a => 2, b => 4, c => 0}.BagHash), 'a:2 b:4', "{a => 2, b => 4, c => 0}.BagHash makes the bag a:2 b:4";
}

{
    my $b = BagHash.new();
    is $b:exists, True, ':exists with existing element';
    is $b:exists, False, ':exists with nonexistent element';
    is $b:delete, 2, ':delete works on BagHash';
    is showkv($b), 'b:1 foo:1', '...and actually deletes';
}

{
    my $b = BagHash.new('a', False, 2, 'a', False, False);
    my @ks = $b.keys;
    #?niecza 3 skip "Non-Str keys NYI"
    is @ks.grep(Int)[0], 2, 'Int keys are left as Ints';
    is @ks.grep(* eqv False).elems, 1, 'Bool keys are left as Bools';
    is @ks.grep(Str)[0], 'a', 'And Str keys are permitted in the same set';
    is $b{2, 'a', False}.join(' '), '1 2 3', 'All keys have the right values';
}

#?rakudo skip "Odd number of elements"
#?niecza skip "Unmatched key in Hash.LISTSTORE"
{
    my %h = bag ;
    ok %h ~~ Hash, 'A hash to which a Bag has been assigned remains a hash';
    is showkv(%h), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $b = BagHash.new();
    isa_ok $b, BagHash, '&BagHash.new given an array of strings produces a BagHash';
    is showkv($b), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $b = BagHash.new([ foo => 10, bar => 17, baz => 42, santa => 0 ]);
    isa_ok $b, BagHash, '&BagHash.new given an array of pairs produces a BagHash';
    is +$b, 1, "... with one element";
}

{
    my $b = BagHash.new({ foo => 10, bar => 17, baz => 42, santa => 0 }.hash);
    isa_ok $b, BagHash, '&BagHash.new given a Hash produces a BagHash';
    #?rakudo todo "Needs to catch up with spec"
    is +$b, 4, "... with four elements";
    #?niecza todo "Non-string bag elements NYI"
    #?rakudo todo "Needs to catch up with spec"
    is +$b.grep(Pair), 4, "... which are all Pairs";
}

{
    my $b = BagHash.new({ foo => 10, bar => 17, baz => 42, santa => 0 });
    isa_ok $b, BagHash, '&BagHash.new given a Hash produces a BagHash';
    is +$b, 1, "... with one element";
}

{
    my $b = BagHash.new(set );
    isa_ok $b, BagHash, '&BagHash.new given a Set produces a BagHash';
    is +$b, 1, "... with one element";
}

{
    my $b = BagHash.new(SetHash.new());
    isa_ok $b, BagHash, '&BagHash.new given a SetHash produces a BagHash';
    is +$b, 1, "... with one element";
}

{
    my $b = BagHash.new(bag );
    isa_ok $b, BagHash, '&BagHash.new given a Bag produces a BagHash';
    is +$b, 1, "... with one element";
}

# Not sure how one should do this with the new BagHash constructor
# {
#     my $b = BagHash.new(set );
#     $b += 2;
#     my $c = BagHash.new($b);
#     isa_ok $c, BagHash, '&BagHash.new given a BagHash produces a BagHash';
#     is showkv($c), 'bar:3 baz:1 foo:1', '... with the right elements';
#     $c = 10;
#     is showkv($c), 'bar:3 baz:1 foo:1 manning:10', 'Creating a new element works';
#     is showkv($b), 'bar:3 baz:1 foo:1', '... and does not affect the original BagHash';
# }

{
    my $b = { foo => 10, bar => 1, baz => 2}.BagHash;

    # .list is just the keys, as per TimToady: 
    # http://irclog.perlgeek.de/perl6/2012-02-07#i_5112706
    isa_ok $b.list.elems, 3, ".list returns 3 things";
    is $b.list.grep(Str).elems, 3, "... all of which are Str";

    isa_ok $b.pairs.elems, 3, ".pairs returns 3 things";
    is $b.pairs.grep(Pair).elems, 3, "... all of which are Pairs";
    is $b.pairs.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $b.pairs.grep({ .value ~~ Int }).elems, 3, "... and the values of which are Ints";

    #?rakudo 3 skip 'No longer Iterable'
    is $b.iterator.grep(Pair).elems, 3, ".iterator yields three Pairs";
    is $b.iterator.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $b.iterator.grep({True}).elems, 3, "... and nothing else";
}

{
    my $b = { foo => 10000000000, bar => 17, baz => 42 }.BagHash;
    my $s;
    my $c;
    lives_ok { $s = $b.perl }, ".perl lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    lives_ok { $c = eval $s }, ".perl.eval lives";
    isa_ok $c, BagHash, "... and produces a BagHash";
    is showkv($c), showkv($b), "... and it has the correct values";
}

{
    my $b = { foo => 2, bar => 3, baz => 1 }.BagHash;
    my $s;
    lives_ok { $s = $b.Str }, ".Str lives";
    isa_ok $s, Str, "... and produces a string";
    is $s.split(" ").sort.join(" "), "bar(3) baz foo(2)", "... which only contains bar baz and foo with the proper counts and separated by spaces";
}

{
    my $b = { foo => 10000000000, bar => 17, baz => 42 }.BagHash;
    my $s;
    lives_ok { $s = $b.gist }, ".gist lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    ok $s ~~ /foo/, "... which mentions foo";
    ok $s ~~ /bar/, "... which mentions bar";
    ok $s ~~ /baz/, "... which mentions baz";
}

# L may be bound to'>

{
    my %b := BagHash.new("a", "b", "c", "b");
    isa_ok %b, BagHash, 'A BagHash bound to a %var is a BagHash';
    is showkv(%b), 'a:1 b:2 c:1', '...with the right elements';

    is %b, 2, 'Single-key subscript (existing element)';
    is %b, 0, 'Single-key subscript (nonexistent element)';

    lives_ok { %b = 4 }, "Assign to an element";
    is %b, 4, "... and gets the correct value";
}

# L

{
    my $b = BagHash.new("a", "b", "b");

    my $a = $b.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $b.roll(2);
    is +@a, 2, '.roll(2) returns the right number of items';
    is @a.grep(* eq 'a').elems + @a.grep(* eq 'b').elems, 2, '.roll(2) returned "a"s and "b"s';

    @a = $b.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(100) (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(100) (2)';

    @a = $b.roll(*)[^100];
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(100) (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(100) (2)';

    #?pugs   skip '.total NYI'
    is $b.total, 3, '.roll should not change BagHash';
    is $b.elems, 2, '.roll should not change BagHash';
}

{
    my $b = {"a" => 100000000000, "b" => 1}.BagHash;

    my $a = $b.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $b.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok @a.grep(* eq 'a') > 97, '.roll(100) (1)';
    ok @a.grep(* eq 'b') < 3, '.roll(100) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 100000000001, '.roll should not change BagHash';
    is $b.elems, 2, '.roll should not change BagHash';
}

# L

{
    my $b = BagHash.new("a", "b", "b");

    my $a = $b.pick;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $b.pick(2);
    is +@a, 2, '.pick(2) returns the right number of items';
    ok @a.grep(* eq 'a').elems <= 1, '.pick(2) returned at most one "a"';
    is @a.grep(* eq 'b').elems, 2 - @a.grep(* eq 'a').elems, '.pick(2) and the rest are "b"';

    @a = $b.pick: *;
    is +@a, 3, '.pick(*) returns the right number of items';
    is @a.grep(* eq 'a').elems, 1, '.pick(*) (1)';
    is @a.grep(* eq 'b').elems, 2, '.pick(*) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 3, '.pick should not change BagHash';
    is $b.elems, 2, '.pick should not change BagHash';
}

{
    my $b = {"a" => 100000000000, "b" => 1}.BagHash;

    my $a = $b.pick;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $b.pick: 100;
    is +@a, 100, '.pick(100) returns 100 items';
    ok @a.grep(* eq 'a') > 98, '.pick(100) (1)';
    ok @a.grep(* eq 'b') < 2, '.pick(100) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 100000000001, '.pick should not change BagHash';
    is $b.elems, 2, '.pick should not change BagHash';
}

# L

#?niecza skip '.pickpairs NYI'
{
    my $b = BagHash.new("a", "b", "b");

    my $a = $b.pickpairs;
    say :$a.perl;
    isa_ok $a, List, 'Did we get a List';
    is $a.elems, 1, 'Did we get one element';
    isa_ok $a[0], Pair, 'Did we get a Pair in the List';
    ok ($a[0] eq "a\t1" or $a[0] eq "b\t2"), "We got one of the two choices";

    my @a = $b.pickpairs(2);
    is +@a, 2, '.pickpairs(2) returns the right number of items';
    is @a.grep(* eq "a\t1").elems, 1, '.pickpairs(2) returned one "a"';
    is @a.grep(* eq "b\t2").elems, 1, '.pickpairs(2) returned one "b"';

    @a = $b.pickpairs: *;
    is +@a, 2, '.pickpairs(*) returns the right number of items';
    is @a.grep(* eq "a\t1").elems, 1, '.pickpairs(*) (1)';
    is @a.grep(* eq "b\t2").elems, 1, '.pickpairs(*) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 3, '.pickpairs should not change Bag';
}

# L

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $b = BagHash.new("a", "b", "b");

    my $a = $b.grab;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $b.grab(2);
    is +@a, 2, '.grab(2) returns the right number of items';
    ok @a.grep(* eq 'a').elems <= 1, '.grab(2) returned at most one "a"';
    is @a.grep(* eq 'b').elems, 2 - @a.grep(* eq 'a').elems, '.grab(2) and the rest are "b"';
    is $b.total, 0, '.grab *should* change BagHash';
    #?rakudo.jvm todo "RT #120407"
    is $b.elems, 0, '.grab *should* change BagHash';
}

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $b = BagHash.new("a", "b", "b");
    my @a = $b.grab: *;
    is +@a, 3, '.grab(*) returns the right number of items';
    is @a.grep(* eq 'a').elems, 1, '.grab(*) (1)';
    is @a.grep(* eq 'b').elems, 2, '.grab(*) (2)';
    is $b.total, 0, '.grab *should* change BagHash';
    #?rakudo.jvm todo "RT #120407"
    is $b.elems, 0, '.grab *should* change BagHash';
}

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $b = {"a" => 100000000000, "b" => 1}.BagHash;

    my $a = $b.grab;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $b.grab: 100;
    is +@a, 100, '.grab(100) returns 100 items';
    ok @a.grep(* eq 'a') > 98, '.grab(100) (1)';
    ok @a.grep(* eq 'b') < 2, '.grab(100) (2)';
    is $b.total, 99999999900, '.grab *should* change BagHash';
    ok 0 <= $b.elems <= 2, '.grab *should* change BagHash';
}

# L

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $b = BagHash.new("a", "b", "b");

    my $a = $b.grabpairs[0];
    isa_ok $a, Pair, 'did we get a Pair';
    ok $a.key eq "a" || $a.key eq "b", "We got one of the two choices";

    my @a = $b.grabpairs(2);
    is +@a, 1, '.grabpairs(2) returns the right number of items';
    is @a.grep( {.isa(Pair)} ).Num, 1, 'are they all Pairs';
    ok @a[0].key eq "a" || @a[0].key eq "b", "We got one of the two choices";
    is $b.total, 0, '.grabpairs *should* change BagHash';
    is $b.elems, 0, '.grabpairs *should* change BagHash';
}

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $b = BagHash.new();
    my @a = $b.grabpairs: *;
    is +@a, 8, '.grabpairs(*) returns the right number of items';
    is @a.grep( {.isa(Pair)} ).Num, 8, 'are they all Pairs';
    is @a.grep( {.value == 2} ).Num, 8, 'and they all have an expected value';
    is @a.sort.map({.key}).join, "abcdefgh", 'SetHash.grabpairs(*) gets all elements';
    isnt @a.map({.key}).join, "abcdefgh", 'SetHash.grabpairs(*) returns elements in a random order';
    is $b.total, 0, '.grabpairs *should* change BagHash';
    is $b.elems, 0, '.grabpairs *should* change BagHash';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "Trait name not available on variables"
{
    my %h is BagHash = a => 1, b => 0, c => 2;
    #?rakudo todo 'todo'
    nok %h:exists, '"b", initialized to zero, does not exist';
    #?rakudo todo 'todo'
    is +%h.keys, 2, 'Inititalization worked';
    is %h.elems, 3, '.elems works';
    #?rakudo todo 'todo'
    isa_ok %h, Int, '%h is an Int';
    #?rakudo todo 'todo'
    is %h, 0, '%h is 0';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "Trait name not available on variables"
{
    my %h is BagHash = a => 1, b => 0, c => 2;

    lives_ok { %h = 0 }, 'can set an item to 0';
    #?rakudo todo 'todo'
    nok %h:exists, '"c", set to zero, does not exist';
    #?rakudo todo 'todo'
    is %h.elems, 1, 'one item left';
    #?rakudo todo 'todo'
    is %h.keys, ('a'), '... and the right one is gone';

    lives_ok { %h++ }, 'can add (++) an item that was removed';
    #?rakudo todo 'todo'
    is %h.keys.sort, , '++ on an item reinstates it';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "Trait name not available on variables"
{
    my %h is BagHash = a => 1, c => 1;

    lives_ok { %h++ }, 'can "add" (++) an existing item';
    is %h, 2, '++ on an existing item increments the counter';
    is %h.keys.sort, , '++ on an existing item does not add a key';

    lives_ok { %h-- }, 'can remove an item with decrement (--)';
    #?rakudo todo 'todo'
    is %h.keys, ('c'), 'decrement (--) removes items';
    #?rakudo todo 'todo'
    nok %h:exists, 'item is gone according to exists too';
    is %h, 0, 'removed item is zero';

    lives_ok { %h-- }, 'remove a missing item lives';
    #?rakudo todo 'todo'
    is %h.keys, ('c'), 'removing missing item does not change contents';
    #?rakudo todo 'todo'
    is %h, 0, 'item removed again is still zero';
}

#?niecza skip "Trait name not available on variables"
{
    my %h of BagHash;
    ok %h.of.perl eq 'BagHash', 'is the hash really a BagHash';
    #?rakudo 2 todo 'in flux'
    lives_ok { %h = bag  }, 'Assigning a Bag to a BagHash';
    is %h.keys.sort.map({ $^k ~ ':' ~ %h{$k} }).join(' '),
        'a:1 b:2 c:2 d:1', '... works as expected';
}

{
    isa_ok 42.BagHash, BagHash, "Method .BagHash works on Int-1";
    is showkv(42.BagHash), "42:1", "Method .BagHash works on Int-2";
    isa_ok "blue".BagHash, BagHash, "Method .BagHash works on Str-1";
    is showkv("blue".BagHash), "blue:1", "Method .BagHash works on Str-2";
    my @a = ;
    isa_ok @a.BagHash, BagHash, "Method .BagHash works on Array-1";
    is showkv(@a.BagHash), "Now:1 Paradise:1 cross-handed:1 set:1 the:2 was:1 way:1", "Method .BagHash works on Array-2";
    my %x = "a" => 1, "b" => 2;
    isa_ok %x.BagHash, BagHash, "Method .BagHash works on Hash-1";
    is showkv(%x.BagHash), "a:1 b:2", "Method .BagHash works on Hash-2";
    isa_ok (@a, %x).BagHash, BagHash, "Method .BagHash works on Parcel-1";
    is showkv((@a, %x).BagHash), "Now:1 Paradise:1 a:1 b:2 cross-handed:1 set:1 the:2 was:1 way:1",
       "Method .BagHash works on Parcel-2";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/bag.t0000664000175000017500000003436312250462647016445 0ustar  moritzmoritzuse v6;
use Test;

plan 173;

sub showkv($x) {
    $x.keys.sort.map({ $^k ~ ':' ~ $x{$k} }).join(' ')
}

# L

{
    my $b = bag ;
    isa_ok $b, Bag, '&bag produces a Bag';
    is showkv($b), 'a:5 b:1 foo:2', '...with the right elements';

    is $b.default, 0, "Defaults to 0";
    is $b, 5, 'Single-key subscript (existing element)';
    isa_ok $b, Int, 'Single-key subscript yields an Int';
    is $b, 0, 'Single-key subscript (nonexistent element)';
    isa_ok $b, Int, 'Single-key subscript yields an Int (nonexistent element)';
    ok $b:exists, 'exists with existing element';
    nok $b:exists, 'exists with nonexistent element';

    is $b.values.elems, 3, "Values returns the correct number of values";
    is ([+] $b.values), 8, "Values returns the correct sum";
    ok ?$b, "Bool returns True if there is something in the Bag";
    nok ?Bag.new(), "Bool returns False if there is nothing in the Bag";

    my $hash;
    lives_ok { $hash = $b.hash }, ".hash doesn't die";
    isa_ok $hash, Hash, "...and it returned a Hash";
    is showkv($hash), 'a:5 b:1 foo:2', '...with the right elements';

    dies_ok { $b = 5 }, "Can't assign to an element (Bags are immutable)";
    dies_ok { $b++ }, "Can't increment an element (Bags are immutable)";
    dies_ok { $b.keys =  }, "Can't assign to .keys";
    dies_ok { $b.values = 3, 4 }, "Can't assign to .values";
    dies_ok { $b:delete }, "Can't :delete from Bag";
    dies_ok { $b.delete_key("a") }, "Can't .delete_key from Bag";

    is ~$b, "5 1", 'Multiple-element access';
    is ~$b, "5 0 1 0", 'Multiple-element access (with nonexistent elements)';

    #?pugs   skip '.total NYI'
    is $b.total, 8, '.total gives sum of values';
    is +$b, 8, '+$bag gives sum of values';
}

{
    ok (bag ) ~~ (bag ), "Identical bags smartmatch with each other";
    ok (bag ) ~~ (bag ), "Identical bags smartmatch with each other";
    nok (bag ) ~~ (bag ), "Subset does not smartmatch";
    nok (bag ) ~~ (bag ), "Subset (only quantity different) does not smartmatch";
    nok (bag ) ~~ (bag ), "Superset does not smartmatch";
    nok (bag ) ~~ (bag ), "Superset (only quantity different) does not smartmatch";
    nok "a" ~~ (bag ), "Smartmatch is not element of";
    ok (bag ) ~~ Bag, "Type-checking smartmatch works";

    ok (set ) ~~ (bag ), "Set smartmatches with equivalent bag";
    nok (set ) ~~ (bag ), "... but not if the Bag has greater quantities";
    nok (set ) ~~ Bag, "Type-checking smartmatch works";
}

{
    isa_ok "a".Bag, Bag, "Str.Bag makes a Bag";
    is showkv("a".Bag), 'a:1', "'a'.Bag is bag a";

    isa_ok (a => 100000).Bag, Bag, "Pair.Bag makes a Bag";
    is showkv((a => 100000).Bag), 'a:100000', "(a => 100000).Bag is bag a:100000";
    is showkv((a => 0).Bag), '', "(a => 0).Bag is the empty bag";

    isa_ok .Bag, Bag, ".Bag makes a Bag";
    is showkv(.Bag), 'a:2 b:1 c:1', ".Bag makes the bag a:2 b:1 c:1";
    is showkv(["a", "b", "c", "a"].Bag), 'a:2 b:1 c:1', "[a b c a].Bag makes the bag a:2 b:1 c:1";
    is showkv([a => 3, b => 0, 'c', 'a'].Bag), 'a:4 c:1', "[a => 3, b => 0, 'c', 'a'].Bag makes the bag a:4 c:1";

    isa_ok {a => 2, b => 4, c => 0}.Bag, Bag, "{a => 2, b => 4, c => 0}.Bag makes a Bag";
    is showkv({a => 2, b => 4, c => 0}.Bag), 'a:2 b:4', "{a => 2, b => 4, c => 0}.Bag makes the bag a:2 b:4";
}

{
    my $b = bag ;
    is $b:exists, True, ':exists with existing element';
    is $b:exists, False, ':exists with nonexistent element';
    dies_ok { $b:delete }, ':delete does not work on bag';
    dies_ok { $b.delete_key("a") }, '.delete_key does not work on bag';
}

{
    my $b = bag 'a', False, 2, 'a', False, False;
    my @ks = $b.keys;
    #?niecza 3 skip "Non-Str keys NYI"
    is @ks.grep(Int)[0], 2, 'Int keys are left as Ints';
    is @ks.grep(* eqv False).elems, 1, 'Bool keys are left as Bools';
    is @ks.grep(Str)[0], 'a', 'And Str keys are permitted in the same set';
    is $b{2, 'a', False}.join(' '), '1 2 3', 'All keys have the right values';
}

#?rakudo skip "Odd number of elements"
#?niecza skip "Unmatched key in Hash.LISTSTORE"
{
    my %h = bag ;
    ok %h ~~ Hash, 'A hash to which a Bag has been assigned remains a hash';
    is showkv(%h), 'a:2 b:1 o:3 p:2', '...with the right elements';
}
{
    my %h := bag ;
    ok %h ~~ Bag, 'A hash to which a Bag has been bound becomes a Bag';
    is showkv(%h), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $b = bag ;
    isa_ok $b, Bag, '&Bag.new given an array of strings produces a Bag';
    is showkv($b), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $b = bag [ foo => 10, bar => 17, baz => 42, santa => 0 ];
    isa_ok $b, Bag, '&Bag.new given an array of pairs produces a Bag';
    is +$b, 1, "... with one element";
}

{
    # {}.hash interpolates in list context
    my $b = bag { foo => 10, bar => 17, baz => 42, santa => 0 }.hash;
    isa_ok $b, Bag, '&Bag.new given a Hash produces a Bag';
    #?rakudo todo "Not properly interpolating"
    is +$b, 4, "... with four elements";
    #?niecza todo "Non-string bag elements NYI"
    #?rakudo todo "Not properly interpolating"
    is +$b.grep(Pair), 4, "... which are all Pairs";
}

{
    # plain {} does not interpolate in list context
    my $b = bag { foo => 10, bar => 17, baz => 42, santa => 0 };
    isa_ok $b, Bag, '&Bag.new given a Hash produces a Bag';
    is +$b, 1, "... with one element";
}

{
    my $b = bag set ;
    isa_ok $b, Bag, '&Bag.new given a Set produces a Bag';
    is +$b, 1, "... with one element";
}

#?niecza skip 'SetHash'
{
    my $b = bag SetHash.new();
    isa_ok $b, Bag, '&Bag.new given a SetHash produces a Bag';
    is +$b, 1, "... with one element";
}

#?niecza skip 'BagHash'
{
    my $b = bag BagHash.new();
    isa_ok $b, Bag, '&Bag.new given a BagHash produces a Bag';
    is +$b, 1, "... with one element";
}

{
    my $b = bag set ;
    isa_ok $b, Bag, '&bag given a Set produces a Bag';
    is +$b, 1, "... with one element";
}

# L may be bound to'>

{
    my %b := bag ;
    isa_ok %b, Bag, 'A Bag bound to a %var is a Bag';
    is showkv(%b), 'a:1 b:2 c:1', '...with the right elements';

    is %b, 2, 'Single-key subscript (existing element)';
    is %b, 0, 'Single-key subscript (nonexistent element)';

    dies_ok { %b = 1 }, "Can't assign to an element (Bags are immutable)";
    dies_ok { %b = bag  }, "Can't assign to a %var implemented by Bag";
    dies_ok { %b:delete }, "Can't :delete from a Bag";
    dies_ok { %b.delete_key("a") }, "Can't .delete_key from a Bag";
}

{
    my $b = { foo => 10, bar => 1, baz => 2}.Bag;

    # .list is just the keys, as per TimToady: 
    # http://irclog.perlgeek.de/perl6/2012-02-07#i_5112706
    isa_ok $b.list.elems, 3, ".list returns 3 things";
    is $b.list.grep(Str).elems, 3, "... all of which are Str";

    isa_ok $b.pairs.elems, 3, ".pairs returns 3 things";
    is $b.pairs.grep(Pair).elems, 3, "... all of which are Pairs";
    is $b.pairs.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $b.pairs.grep({ .value ~~ Int }).elems, 3, "... and the values of which are Ints";

    #?rakudo 3 skip 'No longer Iterable'
    is $b.iterator.grep(Pair).elems, 3, ".iterator yields three Pairs";
    is $b.iterator.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $b.iterator.grep({True}).elems, 3, "... and nothing else";
}

{
    my $b = { foo => 10000000000, bar => 17, baz => 42 }.Bag;
    my $s;
    my $c;
    lives_ok { $s = $b.perl }, ".perl lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    lives_ok { $c = eval $s }, ".perl.eval lives";
    isa_ok $c, Bag, "... and produces a Bag";
    is showkv($c), showkv($b), "... and it has the correct values";
}

{
    my $b = { foo => 2, bar => 3, baz => 1 }.Bag;
    my $s;
    lives_ok { $s = $b.Str }, ".Str lives";
    isa_ok $s, Str, "... and produces a string";
    is $s.split(" ").sort.join(" "), "bar(3) baz foo(2)", "... which only contains bar baz and foo with the proper counts and separated by spaces";
}

{
    my $b = { foo => 10000000000, bar => 17, baz => 42 }.Bag;
    my $s;
    lives_ok { $s = $b.gist }, ".gist lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    ok $s ~~ /foo/, "... which mentions foo";
    ok $s ~~ /bar/, "... which mentions bar";
    ok $s ~~ /baz/, "... which mentions baz";
}

# L may be bound to'>

{
    my %b := bag "a", "b", "c", "b";
    isa_ok %b, Bag, 'A Bag bound to a %var is a Bag';
    is showkv(%b), 'a:1 b:2 c:1', '...with the right elements';

    is %b, 2, 'Single-key subscript (existing element)';
    is %b, 0, 'Single-key subscript (nonexistent element)';
}

# L

{
    my $b = Bag.new("a", "b", "b");

    my $a = $b.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $b.roll(2);
    is +@a, 2, '.roll(2) returns the right number of items';
    is @a.grep(* eq 'a').elems + @a.grep(* eq 'b').elems, 2, '.roll(2) returned "a"s and "b"s';

    @a = $b.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(100) (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(100) (2)';

    @a = $b.roll(*)[^100];
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(100) (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(100) (2)';

    #?pugs   skip '.total NYI'
    is $b.total, 3, '.roll should not change Bag';
}

{
    my $b = {"a" => 100000000000, "b" => 1}.Bag;

    my $a = $b.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $b.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok @a.grep(* eq 'a') > 97, '.roll(100) (1)';
    ok @a.grep(* eq 'b') < 3, '.roll(100) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 100000000001, '.roll should not change Bag';
}

# L

{
    my $b = Bag.new("a", "b", "b");

    my $a = $b.pick;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $b.pick(2);
    is +@a, 2, '.pick(2) returns the right number of items';
    ok @a.grep(* eq 'a').elems <= 1, '.pick(2) returned at most one "a"';
    is @a.grep(* eq 'b').elems, 2 - @a.grep(* eq 'a').elems, '.pick(2) and the rest are "b"';

    @a = $b.pick: *;
    is +@a, 3, '.pick(*) returns the right number of items';
    is @a.grep(* eq 'a').elems, 1, '.pick(*) (1)';
    is @a.grep(* eq 'b').elems, 2, '.pick(*) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 3, '.pick should not change Bag';
}

{
    my $b = {"a" => 100000000000, "b" => 1}.Bag;

    my $a = $b.pick;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $b.pick: 100;
    is +@a, 100, '.pick(100) returns 100 items';
    ok @a.grep(* eq 'a') > 98, '.pick(100) (1)';
    ok @a.grep(* eq 'b') < 2, '.pick(100) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 100000000001, '.pick should not change Bag';
}

# L

#?niecza skip ".pickpairs NYI"
{
    my $b = Bag.new("a", "b", "b");

    my $a = $b.pickpairs;
    isa_ok $a, List, 'Did we get a List';
    is $a.elems, 1, 'Did we get one element';
    isa_ok $a[0], Pair, 'Did we get a Pair in the List';
    ok ($a[0] eq "a\t1" or $a[0] eq "b\t2"), "We got one of the two choices";

    my @a = $b.pickpairs(2);
    is +@a, 2, '.pickpairs(2) returns the right number of items';
    is @a.grep(* eq "a\t1").elems, 1, '.pickpairs(2) returned one "a"';
    is @a.grep(* eq "b\t2").elems, 1, '.pickpairs(2) returned one "b"';

    @a = $b.pickpairs: *;
    is +@a, 2, '.pickpairs(*) returns the right number of items';
    is @a.grep(* eq "a\t1").elems, 1, '.pickpairs(*) (1)';
    is @a.grep(* eq "b\t2").elems, 1, '.pickpairs(*) (2)';
    #?pugs   skip '.total NYI'
    is $b.total, 3, '.pickpairs should not change Bag';
}

# L

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $b = bag ;
    dies_ok { $b.grab }, 'cannot call .grab on a Bag';
}

# L

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $b = bag ;
    dies_ok { $b.grabpairs }, 'cannot call .grabpairs on a Bag';
}

{
    my $b1 = bag ( bag  ), ;
    is +$b1, 8, "Three elements";
    is $b1, 3, "One of them is 'c'";
    is $b1, 4, "One of them is 'd'";
    my $inner-bag = $b1.list.first(Bag);
    #?niecza 2 todo 'Bag in Bag does not work correctly yet'
    isa_ok $inner-bag, Bag, "One of the bag's elements is indeed a bag!";
    is showkv($inner-bag), "a:1 b:1 c:1", "With the proper elements";

    my $b = bag ;
    $b1 = bag $b, ;
    is +$b1, 3, "Three elements";
    is $b1, 1, "One of them is 'c'";
    is $b1, 1, "One of them is 'd'";
    $inner-bag = $b1.list.first(Bag);
    #?niecza 2 todo 'Bag in Bag does not work correctly yet'
    isa_ok $inner-bag, Bag, "One of the bag's elements is indeed a bag!";
    is showkv($inner-bag), "a:1 b:1 c:1", "With the proper elements";
}

{
    isa_ok 42.Bag, Bag, "Method .Bag works on Int-1";
    is showkv(42.Bag), "42:1", "Method .Bag works on Int-2";
    isa_ok "blue".Bag, Bag, "Method .Bag works on Str-1";
    is showkv("blue".Bag), "blue:1", "Method .Bag works on Str-2";
    my @a = ;
    isa_ok @a.Bag, Bag, "Method .Bag works on Array-1";
    is showkv(@a.Bag), "Now:1 Paradise:1 cross-handed:1 set:1 the:2 was:1 way:1", "Method .Bag works on Array-2";
    my %x = "a" => 1, "b" => 2;
    isa_ok %x.Bag, Bag, "Method .Bag works on Hash-1";
    is showkv(%x.Bag), "a:1 b:2", "Method .Bag works on Hash-2";
    isa_ok (@a, %x).Bag, Bag, "Method .Bag works on Parcel-1";
    is showkv((@a, %x).Bag), "Now:1 Paradise:1 a:1 b:2 cross-handed:1 set:1 the:2 was:1 way:1",
       "Method .Bag works on Parcel-2";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/bool.t0000664000175000017500000000673712224265625016651 0ustar  moritzmoritzuse v6;
use Test;
plan 51;

#L

# tests True and False are Bool's
isa_ok(Bool::True, Bool);
isa_ok(Bool::False, Bool);

# tests they keep their Bool'ness when stored
my $a = Bool::True;
isa_ok($a, Bool);

$a = Bool::False;
isa_ok($a, Bool);

# tests that Bool.Bool works
isa_ok (Bool::True).Bool, Bool, "Bool.Bool is a Bool";
isa_ok (Bool::False).Bool, Bool, "Bool.Bool is a Bool";
is (Bool::True).Bool, Bool::True, "Bool.Bool works for True";
is (Bool::False).Bool, Bool::False, "Bool.Bool works for False";

# tests that ?Bool works
isa_ok ?(Bool::True), Bool, "?Bool is a Bool";
isa_ok ?(Bool::False), Bool, "?Bool is a Bool";
is ?(Bool::True), Bool::True, "?Bool works for True";
is ?(Bool::False), Bool::False, "?Bool works for False";

# tests they work with && and ||
#?pugs 4 skip 'pass'
Bool::True  && pass('True works');
Bool::False || pass('False works');

# tests they work with !
!Bool::True  || pass('!True works');
!Bool::False && pass('!False works');

# tests True with ok()
ok(Bool::True, 'True works');

# tests False with ok() and !
ok(!Bool::False, 'False works');

# tests Bool stringification - interaction with ~
isa_ok(~Bool::True, Str);
isa_ok(~Bool::False, Str);
#?pugs 2 todo "stringification"
is(~Bool::True, 'True', 'Bool stringification (True)');
is(~Bool::False, 'False', 'Bool stringification (False)');
#?pugs 2 todo '.Str'
is Bool::True.Str, 'True', 'True.Str';
is Bool::False.Str, 'False', 'False.Str';
#?pugs 2 todo '.gist'
is Bool::True.gist, 'True', 'True.gist';
is Bool::False.gist, 'False', 'False.gist';
is Bool::True.perl, 'Bool::True', 'True.perl';
is Bool::False.perl, 'Bool::False', 'False.perl';

# numification - interaction with +
#?pugs 2 skip "Numeric"
ok(+Bool::True ~~ Numeric);
ok(+Bool::False ~~ Numeric);
#?pugs 2 todo "Int"
isa_ok(+Bool::True, Int, 'True numifies to an Int');
isa_ok(+Bool::False, Int, 'False numifies to an Int');

is(Bool::True.Int, '1', 'True Intifies to 1');
is(Bool::False.Int, '0', 'False Intifies to 1');

is(+Bool::True, '1', 'True numifies to 1');
is(+Bool::False, '0', 'False numifies to 0');

# Arithmetic operations
my $bool = Bool::False;
is(++$bool, Bool::True, 'Increment of Bool::False produces Bool::True');
#?pugs todo
is(++$bool, Bool::True, 'Increment of Bool::True still produces Bool::True');
#?pugs todo 'Cannot cast from VBool True to VCode'
is(--$bool, Bool::False, 'Decrement of Bool::True produces Bool::False');
#?pugs todo
is(--$bool, Bool::False, 'Decrement of Bool::False produces Bool::False');

# RT #65514
{
    #?pugs 2 skip 'Cannot cast from VBool True to VCode'
    ok (0 but Bool::True), 'Bool::True works with "but"';
    is (0 but Bool::True), 0, 'Bool::True works with "but"';
    #?pugs 2 skip 'Cannot cast from VBool False to VCode'
    ok !('RT65514' but Bool::False), 'Bool::False works with "but"';
    is ('RT65514' but Bool::False), 'RT65514', 'Bool::False works with "but"';
}

#?pugs skip '.key'
{
    is Bool::True.key, 'True', 'Bool::True.key works (is "True")';
    is Bool::False.key, 'False', 'Bool::False.key works (is "False")';
}

#?pugs skip '.pick'
{
    my $x = Bool.pick;
    ok ($x === True || $x === False), 'Bool.pick return True or False';
    is Bool.pick(*).elems, 2, 'Bool.pick(*) returns two elems';;
    my @a = Bool.roll(30);
    ok @a.grep({$_}),  'Bool.roll(30) contains a True';
    ok @a.grep({!$_}), 'Bool.roll(30) contains a False';
    is Bool.roll(*).[^10].elems, 10, 'Bool.roll(*) contains at least 10 elems';

}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/capture.t0000664000175000017500000000652112224265625017350 0ustar  moritzmoritzuse v6;

use Test;

plan 21;

{
    my $capture = \(1,2,3);

    # L
    sub foo1 ($a, $b, $c) { "$a!$b!$c" }
    is foo1(|$capture), "1!2!3",
        'simply capture creation with \\( works (1)';
}

{
    my $capture = \(1,2,3,'too','many','args');

    # L
    sub foo2 ($a, $b, $c) { "$a!$b!$c" }
    dies_ok { foo2(|$capture) },
        'simply capture creation with \\( works (2)';
}

{
    my $capture = \(1, named => "arg");

    # L
    sub foo3 ($a, :$named) { "$a!$named" }
    is foo3(|$capture), "1!arg",
        'simply capture creation with \\( works (3)';
}

#?rakudo skip 'nom regression'
{
    my $capture = \(1, 'positional' => "pair");

    # L
    sub foo4 ($a, $pair) { "$a!$pair" }
    is foo4(|$capture), "1!positional\tpair",
        'simply capture creation with \\( works (4)';
}

{
    my @array   = ;
    my $capture = \(@array);

    # L
    sub foo5 (@arr) { ~@arr }
    is foo5(|$capture), "a b c",
        'capture creation with \\( works';
}

# L
{
    sub bar6 ($a, $b, $c) { "$a!$b!$c" }
    sub foo6 (|capture)  { bar6(|capture) }

    #?pugs todo "feature"
    is foo6(1,2,3), "1!2!3",
        'capture creation with \\$ works (1)';
    dies_ok { foo6(1,2,3,4) },  # too many args
        'capture creation with \\$ works (2)';
    dies_ok { foo6(1,2) },      # too few args
        'capture creation with \\$ works (3)';
    #?pugs 2 todo "feature"
    #?rakudo todo 'nom regression'
    is try { foo6(a => 1, b => 2, c => 3) }, "1!2!3",
        'capture creation with \\$ works (4)';
    #?rakudo todo 'nom regression'
    is try { foo6(1, b => 2, c => 3) }, "1!2!3",
        'capture creation with \\$ works (5)';
}

# Arglists are first-class objects
{
    my $capture;
    sub foo7 (|args) { $capture = args }

    lives_ok { foo7(1,2,3,4) }, "captures are first-class objects (1)";
    #?pugs todo "feature"
    ok $capture,               "captures are first-class objects (2)";

    my $old_capture = $capture;
    lives_ok { foo7(5,6,7,8) }, "captures are first-class objects (3)";
    #?pugs 2 todo "feature"
    ok $capture,               "captures are first-class objects (4)";
    ok !($capture === $old_capture), "captures are first-class objects (5)";
}

{
    my $capture1;
    sub foo8 ($args) { $capture1 = $args }

    my $capture2 = \(1,2,3);
    try { foo8 $capture2 };  # note: no |$args here

    ok $capture1 === $capture2,
        "unflattened captures can be passed to subs";
}

# Mixing ordinary args with captures
{
    my $capture = \(:foo, :baz);
    sub foo9 ($a,$b, :$foo, :$baz) { "$a!$b!$foo!$baz" }

    dies_ok { foo9(|$capture) },  # too few args
        "mixing ordinary args with captures (1)";
    is foo9(1, 2, |$capture), "1!2!bar!grtz",
        "mixing ordinary args with captures (2)";
}

{
    # RT #78496
    my $c = ('OH' => 'HAI').Capture;
    is $c,   'OH',  '. of Pair.Capture';
    is $c, 'HAI', '. of Pair.Capture';
}

# RT #89766
nok (defined  \()[0]), '\()[0] is not defined';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/catch_type_cast_mismatch.t0000664000175000017500000000251112224265625022722 0ustar  moritzmoritzuse v6;

use Test;

=begin description

Test that conversion errors when accessing
anonymous structures C in a way that can
be trapped by Pugs.

=end description

plan 10;

my $ref = { val => 42 };
isa_ok($ref, Hash);
#?rakudo todo "die or fail?"
#?niecza todo "questionable test"
#?pugs todo
dies_ok { $ref[0] }, 'Hash !~~ Positional';

{
    $ref = [ 42 ];
    isa_ok($ref, Array);
    #?pugs skip 'Cannot cast into Hash: VRef'
    #?niecza skip "Failure NYI"
    ok( $ref<0> ~~ Failure, 'Accessing an array as a hash fails');
}

# Also test that scalars give up their container types - this time a
# regression in rakudo

{
    # scalar -> arrayref and back
    my $x = 2;
    lives_ok { $x = [0] }, 'Can assign an arrayref to a scalar';
    my $y = [0];
    lives_ok { $y = 3   }, 'Can assign a number to scalar with an array ref';
}

{
    # scalar -> hashref and back
    my $x = 2;
    lives_ok { $x = {a => 1} }, 'Can assign an hashref to a scalar';
    my $y = { b => 34 };
    lives_ok { $y = 3   },   'Can assign a number to scalar with an hashref';
}

{
    # hash -> array and back
    my $x = [0, 1];
    lives_ok { $x = { a => 3 } }, 'can assign hashref to scalar that held an array ref';
    my $y = { df => 'dfd', 'ui' => 3 };
    lives_ok { $y = [0, 7] }, 'can assign arrayref to scalar that held an hashref';

}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/compact.t0000664000175000017500000000314112224265625017326 0ustar  moritzmoritzuse v6;
use Test;

plan 10;

# L

#?rakudo skip "No such method STORE for Int"
# compact array acting as a buffer
{
    my uint8 @buffer = ('A' .. 'Z').map({ .ord });
    is(@buffer[0],  ord('A'), 'basic sanity test (1)');
    is(@buffer[25], ord('Z'), 'basic sanity test (2)');
    #?pugs todo
    is(substr(@buffer,   0, 8), ord('A'), 'substr on compact array (1)');
    #?pugs todo
    is(substr(@buffer, 200, 8), ord('Z'), 'substr on compact array (2)');
    #?pugs skip 'sprintf hangs'
    is(
        substr(@buffer, 0, 16),
        sprintf('%08d%08d', ord('A'), ord('B')),
        'substr on compacy array (3)'
    );
}

#?rakudo skip "No such method cat for List"
# buffer acting as a compact array
#?pugs skip 'sprintf hangs'
{
    my buf8 $buffer = ('A' .. 'Z').map({sprintf('%08d', .ord)}).cat;
    is($buffer[0],  ord('A'), 'array indexing on buffer (1)');
    is($buffer[25], ord('Z'), 'array indexing on buffer (2)');
    is(
        $buffer[0 .. 1],
        sprintf('%08d%08d', ord('A'), ord('B')),
        'array slice on buffer (3)'
    );
}

#?rakudo skip "No such method cat for List"
# L
#?pugs skip 'sprintf hangs'
{
    my buf8  $buf8  = ('A' .. 'Z').map({sprintf('%08d', .ord)}).cat;
    my buf16 $buf16 = ('A' .. 'Z').map({sprintf('%08d', .ord)}).cat;
    is($buf8.bytes,  26, '.bytes works on a buf8');
    is($buf16.bytes, 26, '.bytes works on a buf16 (and returns the size in bytes)');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/declare.t0000664000175000017500000002307212225464703017303 0ustar  moritzmoritzuse v6;
use Test;

# see if you can declare the various built-in types
# a broad but not in depth test of the existence of various types

plan 78;

# L

# immutable types (e.g. Int, Num, Complex, Rat, Str, Bit, Regex, Set, Block, List)

{
 my Int $namcu =2;
 isa_ok($namcu,Int);
}

{
 my Num $namcu =1.1e1;
 isa_ok($namcu,Num);
}

# Type mismatch in assignment; expected something matching type Complex but got something of type Num()

#?rakudo skip 'Complex not type converted properly during assignment from Num'
#?niecza skip 'Complex not type converted properly during assignment from Rat'
{
 my Complex $namcu =1.3;
 isa_ok($namcu,Complex);
}

{
 my Rat $namcu = 7 / 4;
 isa_ok($namcu,Rat);
}

{
 my Str $lerpoi = "broda";
 isa_ok($lerpoi,Str);
}

#?rakudo skip 'Bit not implemented'
#?niecza skip 'Bit not implemented'
#?pugs todo
{
 my Bit $namcu =1;
 isa_ok($namcu,Bit);
}

{
 my Regex $morna;
 isa_ok($morna, Regex);
}

#?pugs skip 'Set'
{
 my Set $selcmima;
 isa_ok($selcmima, Set);
}

{
 my Block $broda;
 isa_ok($broda, Block);
}

{
 my List $liste;
 isa_ok($liste, List);
}


# mutable (container) types, such as Scalar, Array, Hash, Buf, Routine, Module
# Buf nacpoi

{
 my Scalar $brode;
 isa_ok($brode, Scalar);
}

{
 my Array $porsi;
 isa_ok($porsi, Array);
}

{
 my Hash $brodi;
 isa_ok($brodi, Hash);
}

#?niecza skip "Buf NYI"
#?pugs skip 'Buf'
{
 my Buf $nacpoi;
 ok($nacpoi ~~ Buf);
}

{
 my Routine $gunka;
 isa_ok($gunka, Routine);
}

#?rakudo skip 'No Module type yet'
#?niecza skip 'No Module type yet'
{
 my Module $brodu;
 isa_ok($brodu, Module);
}


# non-instantiable Roles such as Callable, Failure, and Integral

#?pugs skip 'Callable'
{
 my Callable $fancu ;
 ok($fancu ~~ Callable);
}

#?rakudo skip 'Integral not implemented'
#?pugs skip 'Integral'
{
 my Integral $foo;
 ok($foo ~~ Integral);
}


# Non-object (native) types are lowercase: int, num, complex, rat, buf, bit.

#?rakudo todo 'int not implemented'
#?niecza skip 'int not implemented'
#?pugs skip 'parsefail'
{
 my int $namcu =2;
 isa_ok($namcu,int);
}

#?rakudo todo 'num not implemented'
#?niecza skip 'num not implemented'
#?pugs skip 'num'
{
 my num $namcu =1.1e0;
 isa_ok($namcu,num);
}

# Type mismatch in assignment; expected something matching type Complex but got something of type Num()

#?rakudo skip 'complex not implemented'
#?niecza skip 'complex not implemented'
#?pugs skip 'complex'
{
 my complex $namcu =1.3;
 isa_ok($namcu,complex);
}

#?rakudo skip 'rat not implemented'
#?niecza skip 'rat not implemented'
#?pugs skip 'rat'

{
 my rat $namcu = 7 / 4;
 isa_ok($namcu,rat);
}

#?rakudo skip 'bit not implemented'
#?niecza skip 'bit not implemented'
#?pugs skip 'bit'
{
 my bit $namcu =1;
 isa_ok($namcu,bit);
}

#?rakudo skip 'buf not implemented'
#?niecza skip 'buf not implemented'
#?pugs skip 'buf'
{
 my buf $nacpoi;
 isa_ok($nacpoi, buf);
}

# junction StrPos StrLen uint Nil Whatever Mu Failure
# Exception Range Bag Signature Capture Blob Instant Duration
# Keyhash SetHash BagHash Pair Mapping IO Routine Sub Method
# Submethod Macro Match Package Module Class Role Grammar Any

#?rakudo skip 'junction not implemented'
#?niecza skip 'junction not implemented'
#?pugs skip 'junction'
{
 my junction $sor;
 isa_ok($sor, junction);
}

#?rakudo skip 'StrPos not implemented'
#?niecza skip 'StrPos not implemented'
#?pugs skip 'StrPos'
{
 my StrPos $pa;
 isa_ok($pa,StrPos  );
}


#?rakudo skip 'StrLen not implemented'
#?niecza skip 'StrLen not implemented'
#?pugs skip 'StrLen'
{
 my StrLen $re;
 isa_ok($re,StrLen  );
}

#?pugs skip 'Nil'
#?niecza skip 'No value for parameter $l in infix:<===>'
{
 my Nil $ci;
 ok($ci === Nil);
}

#?pugs skip 'Whatever'
{
 my Whatever $vo;
 isa_ok($vo,Whatever  );
}

{
 my Mu $mu;
 ok($mu ~~ Mu  );
}

#?niecza skip 'Failure not implemented'
#?pugs skip 'Failure'
{
 my Failure $xa;
 isa_ok($xa,Failure  );
}

#?niecza skip 'Exception not implemented'
#?pugs skip 'Exception'
{
 my Exception $ze;
 isa_ok($ze,Exception  );
}

#?pugs skip 'Range'
{
 my Range $bi;
 isa_ok($bi,Range  );
}

#?pugs skip 'Bag'
{
 my Bag $so;
 isa_ok($so,Bag  );
}

{
 my Signature $pano;
 isa_ok($pano,Signature  );
}

{
 my Capture $papa;
 isa_ok($papa,Capture  );
}

#?niecza skip 'Blob not implemented'
#?pugs skip 'Blob'
{
 my Blob $pare;
 ok($pare ~~ Blob);
}

#?pugs skip 'Instant'
{
 my Instant $paci;
 isa_ok($paci,Instant  );
}

#?niecza skip 'Duration not implemented'
#?pugs skip 'Duration'
{
 my Duration $pavo;
 isa_ok($pavo,Duration  );
}

#?niecza skip 'QuantHash not implemented'
#?pugs skip 'QuantHash'
{
 my QuantHash $pamu;
 ok($pamu ~~ QuantHash, 'The object does QuantHash' );
}

#?pugs skip 'SetHash'
#?niecza skip 'SetHash'
{
 my SetHash $paxa;
 isa_ok($paxa,SetHash  );
}

#?pugs skip 'BagHash'
#?niecza skip 'BagHash'
{
 my BagHash $paze;
 isa_ok($paze,BagHash  );
}

{
 my Pair $pabi;
 isa_ok($pabi,Pair  );
}

#?pugs skip 'EnumMap'
{
 my EnumMap $paso;
 isa_ok($paso,EnumMap  );
}

{
 my Routine $repa;
 isa_ok($repa,Routine  );
}

{
 my Sub $rere;
 isa_ok($rere, Sub );
}

{
 my sub bar() { say 'blah' };
 my Sub $rr = &bar;
 isa_ok($rr, Sub );
}

{
 my sub baz() { return 1;};
 my sub bar() { return baz;} ;
 my &foo := &bar;
 is(&foo(), 1,'nested sub call');
}

{
 my sub baz() { return 1;};
 my sub bar() { return baz;} ;
 my $foo = &bar;
 is($($foo()), 1, 'nested sub call');
}


{
 my Method $reci;
 isa_ok($reci, Method );
}

{
 my Submethod $revo;
 isa_ok($revo, Submethod );
}

#?niecza skip 'Macro not implemented'
{
 my Macro $remu;
 isa_ok($remu,Macro  );
}

{
 my Match $rexa;
 isa_ok($rexa,Match  );
}

{
 my Grammar $cire;
 isa_ok($cire,Grammar  );
}

{
 my Any $civo;
 isa_ok($civo, Any );
}

# http://svn.pugscode.org/pugs/src/perl6/CORE.pad had list of types pugs supports

{
 my Bool $jetfu;
 isa_ok($jetfu, Bool);
}

#?pugs skip 'Order'
{
 my Order $karbi;
 isa_ok($karbi, Order);
}

#?rakudo skip 'Matcher isa not implemented'
#?niecza skip 'Matcher not implemented'
#?pugs skip 'Matcher'
{
  my Matcher $mapti;
  isa_ok($mapti, Matcher);
}

{
  my Proxy $krati;
  isa_ok($krati, Proxy);
}

# CharLingua Byte Char AnyChar 

#?rakudo skip 'Char not implemented'
#?niecza skip 'Char not implemented'
#?pugs skip 'Char'
{
  my Char $pav;
  isa_ok($pav, Char);
}

#?rakudo skip 'Byte not implemented'
#?niecza skip 'Byte not implemented'
#?pugs skip 'Byte'
{
  my Byte $biv;
  isa_ok($biv, Byte);
}

#?rakudo skip 'AnyChar not implemented'
#?niecza skip 'AnyChar not implemented'
#?pugs skip 'AnyChar'
{
  my AnyChar $lerfu;
  isa_ok($lerfu, AnyChar);
}

#?rakudo skip 'CharLingua not implemented'
#?niecza skip 'CharLingua not implemented'
#?pugs skip 'CharLingua'
{
  my CharLingua  $lerfu;
  isa_ok($lerfu, CharLingua );
}

#?rakudo skip 'Codepoint not implemented'
#?niecza skip 'Codepoint not implemented'
#?pugs skip 'Codepoint'
{
  my Codepoint $cypy;
  isa_ok($cypy,Codepoint );
}

#?rakudo skip 'Grapheme not implemented'
#?niecza skip 'Grapheme not implemented'
#?pugs skip 'Grapheme'
{
  my Grapheme $gy;
  isa_ok($gy,Grapheme );
}

# Positional Associative Ordering Ordered
# KeyExtractor Comparator OrderingPair HyperWhatever

#?pugs skip 'Positional'
{
  my Positional $mokca;
  ok($mokca ~~ Positional,'Positional exists');
}

#?pugs skip 'Associative'
{
  my Associative $kansa;
  ok($kansa ~~ Associative,'Associative exists');
}

#?rakudo skip 'Ordering not implemented'
#?niecza skip 'Ordering not implemented'
#?pugs skip 'Ordering'
{
  my Ordering $foo;
  isa_ok($foo,Ordering);
}

#?rakudo skip 'KeyExtractor not implemented'
#?niecza skip 'KeyExtractor not implemented'
#?pugs skip 'KeyExtractor'
{
  my KeyExtractor $ckiku;
  isa_ok($ckiku, KeyExtractor);
}

# KeyExtractor Comparator OrderingPair HyperWhatever

#?rakudo skip 'Comparator not implemented'
#?niecza skip 'Comparator not implemented'
#?pugs skip 'Comparator'
{
  my Comparator $bar;
  isa_ok($bar,Comparator);
}

#?rakudo skip 'OrderingPair not implemented'
#?niecza skip 'OrderingPair not implemented'
#?pugs skip 'OrderingPair'
{
  my OrderingPair $foop;
  isa_ok($foop,OrderingPair);
}

#?rakudo skip 'HyperWhatever not implemented'
#?niecza skip 'HyperWhatever not implemented'
#?pugs skip 'HyperWhatever'
{
  my HyperWhatever $baz;
  isa_ok($baz,HyperWhatever);
}

# utf8 utf16 utf32

#?niecza skip 'utf8 not implemented'
#?pugs skip 'utf8'
{
  my utf8 $ubi;
  isa_ok($ubi,utf8);
}

#?niecza skip 'utf16 not implemented'
#?pugs skip 'utf16'
{
  my utf16 $upaxa;
  isa_ok($upaxa,utf16);
}

#?niecza skip 'utf32 not implemented'
#?pugs skip 'utf32'
{
  my utf32 $ucire;
  isa_ok($ucire,utf32);
}

# L
# int in1 int2 int4 int8 int16 in32 int64
# uint uin1 uint2 uint4 uint8 uint16 uint32 uint64
# t/spec/S02-builtin_data_types/int-uint.t already has these covered

# L
# num16 num32 num64 num128
# complex16 complex32 complex64 complex128
# buf8 buf16 buf32 buf64 

#?rakudo skip 'num16  not implemented'
#?niecza skip 'num16 not implemented'
#?pugs skip 'num16'
{
  my num16 $namcupaxa;
  isa_ok($namcupaxa,num16);
}

# TODO FIXME rakudo does not have any of them anyway

# L
# my Egg $cup; my Egg @carton; my Array of Egg @box; my Array of Array of Egg @crate;
# my Hash of Array of Recipe %book;
# my Hash:of(Array:of(Recipe)) %book;
# my Hash of Array of Recipe %book; my %book of Hash of Array of Recipe

#RT #75896
#?niecza skip 'Coercive declarations NYI'
#?pugs skip 'parsefail'
{
  my Array of Int @box;
  ok(1,'Array of Int @box');
}

#?niecza skip 'Coercive declarations NYI'
#?pugs skip 'parsefail'
{
  my Array of Array of Int @box;
  ok(1,'Array of Array of Int @box');
}

# TODO FIXME



# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/deprecations.t0000664000175000017500000003514712253365500020366 0ustar  moritzmoritzuse v6;

use Test;

plan 27;

# currently deprecated core features

my $line;

# Any
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Any.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Any.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from Any) called at:
  $*PROGRAM_NAME, line $line
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Any.delete("a");
    Any.delete("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation for Any.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Any) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Any.KeySet;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Any.KeySet';
Saw 1 call to deprecated code during execution.
================================================================================
Method KeySet (from Any) called at:
  $*PROGRAM_NAME, line $line
Please use 'SetHash' instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Any.KeyBag;
    Any.KeyBag;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation for Any.KeyBag';
Saw 1 call to deprecated code during execution.
================================================================================
Method KeyBag (from Any) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'BagHash' instead.
--------------------------------------------------------------------------------
TEXT
} #4

# Array
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; [].delete(1);
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Array.delete(1)';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Array) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Bag
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; try Bag.new.delete("a"); # try because cannot mutate Bag
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Bag.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Bag) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# BagHash
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; BagHash.new.delete("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. BagHash.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from BagHash) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Baggy
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Bag.new.exists("a");
    Bag.new.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Bag.new.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from Baggy) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; BagHash.new.exists("a");
    BagHash.new.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. BagHash.new.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from Baggy) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT
} #2

# Capture
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Capture.new.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. Capture.new.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from Capture) called at:
  $*PROGRAM_NAME, line $line
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Cool
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; "a".ucfirst;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation "a".ucfirst';
Saw 1 call to deprecated code during execution.
================================================================================
Method ucfirst (from Cool) called at:
  $*PROGRAM_NAME, line $line
Please use 'tc' instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Decrease
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Decrease;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Decrease';
Saw 1 call to deprecated code during execution.
================================================================================
Sub Decrease (from GLOBAL) called at:
  $*PROGRAM_NAME, line $line
Please use More instead.
--------------------------------------------------------------------------------
TEXT
} #1

# EnumMap
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; EnumMap.exists;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation EnumMap.exists';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from EnumMap) called at:
  $*PROGRAM_NAME, line $line
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; EnumMap.new.exists("a");
    EnumMap.new.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. EnumMap.new.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from EnumMap) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT
} #2

# GLOBAL
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{

    $line = $?LINE; ucfirst("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation ucfirst("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Sub ucfirst (from GLOBAL) called at:
  $*PROGRAM_NAME, line $line
Please use 'tc' instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Hash
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Hash.delete;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Hash.delete';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Hash) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Hash.new.delete("a");
    Hash.new.delete("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Hash.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Hash) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #2

# Increase
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Increase;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Increase';
Saw 1 call to deprecated code during execution.
================================================================================
Sub Increase (from GLOBAL) called at:
  $*PROGRAM_NAME, line $line
Please use Less instead.
--------------------------------------------------------------------------------
TEXT
} #1

# List
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; List.new.exists(1);
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation List.new.exists(1)';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from List) called at:
  $*PROGRAM_NAME, line $line
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Mix
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; try Mix.new.delete("a"); # try because cannot mutate Mix
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Mix.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Mix) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# MixHash
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; MixHash.new.delete("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. MixHash.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from MixHash) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Order::Decrease
#?rakudo skip 'Could not create deprecated Order::Decrease'
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Order::Decrease;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Order::Decrease';
Saw 1 call to deprecated code during execution.
================================================================================
Sub Decrease (from Order) called at:
  $*PROGRAM_NAME, line $line
Please use More instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Order::Increase
#?rakudo skip 'Could not create deprecated Order::Increase'
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Order::Increase;
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Order::Increase';
Saw 1 call to deprecated code during execution.
================================================================================
Sub Increase (from Order) called at:
  $*PROGRAM_NAME, line $line
Please use Less instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Set
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; try Set.new.delete("a"); # try because cannot mutate Set
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Set.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from Set) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# SetHash
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; SetHash.new.delete("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. SetHash.new.delete("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method delete (from SetHash) called at:
  $*PROGRAM_NAME, line $line
Please use the :delete adverb instead.
--------------------------------------------------------------------------------
TEXT
} #1

# Setty
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
#?rakudo.jvm skip 'tracebacks in deprecations'
{
    $line = $?LINE; Set.new.exists("a");
    Set.new.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'deprecation Set.new.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from Setty) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; SetHash.new.exists("a");
    SetHash.new.exists("a");
    is Deprecation.report, qq:to/TEXT/.chop, 'depr. SetHash.new.exists("a")';
Saw 1 call to deprecated code during execution.
================================================================================
Method exists (from Setty) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use the :exists adverb instead.
--------------------------------------------------------------------------------
TEXT
} #2

# vim:set ft=perl6
rakudo-2013.12/t/spec/S02-types/fatrat.t0000664000175000017500000000031012224265625017154 0ustar  moritzmoritzuse v6;

use Test;

plan 1;

#L and C Types/For applications that really need arbitrary precision>
{
  my $fatty := FatRat.new(9,10);
  isa_ok( $fatty, FatRat);
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/flattening.t0000664000175000017500000000564612224265625020047 0ustar  moritzmoritzuse v6;

use Test;

plan 37;

{
    my @array = 11 .. 15;

    is(@array.elems,     5, 'array has 5 elements');
    is(@array[0],       11, 'first value is 11');
    #?pugs todo
    is(@array[*-1],     15, 'last value is 15');
    # 3[0] etc. should *not* work, but (3,)[0] should.
    # That's similar as with the .kv issue we've had: 3.kv should fail, but
    # (3,).kv should work.
}

{
    my @array = [ 11 .. 15 ];

    is(@array[0].elems,  5, 'arrayref has 5 elements');
    is(@array[0][0],    11, 'first element in arrayref is 11');

    #?pugs todo
    is(@array[0][*-1],  15, 'last element in arrayref is 15');
}

{
    my @array = [ 11 .. 15 ], [ 21 .. 25 ], [ 31 .. 35 ];

    is(@array[0].elems,  5, 'first arrayref has 5 elements');
    is(@array[1].elems,  5, 'second arrayref has 5 elements');
    is(@array[0][0],    11, 'first element in first arrayref is 11');
    #?pugs todo
    is(@array[0][*-1],  15, 'last element in first arrayref is 15');
    is(@array[1][0],    21, 'first element in second arrayref is 21');
    #?pugs todo
    is(@array[1][*-1],  25, 'last element in second arrayref is 25');
    #?pugs todo
    is(@array[*-1][0],  31, 'first element in last arrayref is 31');
    #?pugs todo
    is(@array[*-1][*-1], 35, 'last element in last arrayref is 35');
}

{
    my %hash = (k1 => [ 11 .. 15 ]);

    #?pugs todo
    is(%hash.elems,  5, 'k1 has 5 elements');
    is(%hash[0],    11, 'first element in k1 is 11');
    #?pugs todo
    is(%hash[*-1],  15, 'last element in k1 is 15');
    #?pugs todo
    nok(%hash<12>.defined,  'nothing at key "12"');
}

{
    my %hash = (k1 => [ 11 .. 15 ], k2 => [ 21 .. 25 ]);

    is(%hash.elems,  5, 'k1 has 5 elements');
    is(%hash.elems,  5, 'k2 has 5 elements');
    is(%hash[0],    11, 'first element in k1 is 11');
    #?pugs todo
    is(%hash[*-1],  15, 'last element in k1 is 15');
    is(%hash[0],    21, 'first element in k1 is 21');
    #?pugs todo
    is(%hash[*-1],  25, 'last element in k1 is 25');
    nok(%hash<12>.defined, 'nothing at key "12"');
    nok(%hash<22>.defined, 'nothing at key "22"');
}

{
    my @a;
    push @a, 1;
    is(@a.elems, 1, 'Simple push works');
    push @a, [];
    is(@a.elems, 2, 'Arrayref literal not flattened');
    push @a, {};
    is(@a.elems, 3, 'Hashref literal not flattened');
    my @foo;
    push @a, \@foo;
    is(@a.elems, 4, 'Arrayref not flattened');
    my %foo;
    push @a, \%foo;
    is(@a.elems, 5, 'Hashref not flattened');
    push @a, @foo;
    is(@a.elems, 5, 'Array flattened');
    push @a, %foo;
    is(@a.elems, 5, 'Hash flattened');
}

# RT #112362
#?pugs skip 'parsefail'
{
    my @a = ;
    is @a[[3, 4], 0,], 'c a', '[] in array slice numifies (1)';
    is @a[[3, 4]],     'c',    '[] in array slice numifies (2)';

    my %h = a => 1, b => 2, 'a b' => 3;
    is %h{}, '1 2', 'hash slicing sanity';
    is %h{[]}, '3', 'hash slicing stringifies []';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/hash_ref.t0000664000175000017500000000533212224265625017463 0ustar  moritzmoritzuse v6;

use Test;

plan 31;

# basic lvalue assignment
{
    my $hash;
    isa_ok $hash, Any;

    $hash{"1st"} = 5;
    isa_ok $hash, Hash;

    is $hash{"1st"}, 5, 'lvalue hash assignment works (w/ double quoted keys)';

    $hash{'1st'} = 4;
    is $hash{'1st'}, 4, 'lvalue hash re-assignment works (w/ single quoted keys)';

    $hash<3rd> = 3;
    is $hash<3rd>, 3, 'lvalue hash assignment works (w/ unquoted style )';
}

# basic hash creation w/ comma separated key/values
{
    my $hash = hash("1st", 1);
    isa_ok $hash, Hash;
    is $hash{"1st"}, 1, 'comma separated key/value hash creation works';
    is $hash<1st>,   1, 'unquoted  fetching works';
}

{
    my $hash = hash("1st", 1, "2nd", 2);
    isa_ok $hash, Hash;
    is $hash{"1st"}, 1,
      'comma separated key/value hash creation works with more than 1st pair';
    is $hash{"2nd"}, 2,
      'comma separated key/value hash creation works with more than 1st pair';
}

# hash slicing
{
    my $hash = {'1st' => 1, '2nd' => 2, '3rd' => 3};
    isa_ok $hash, Hash;

    my @slice1 = $hash{"1st", "3rd"};
    is +@slice1,   2, 'got the right amount of values from the %hash{} slice';
    is @slice1[0], 1, '%hash{} slice successful (1)';
    is @slice1[1], 3, '%hash{} slice successful (2)';

    my @slice2;
    @slice2 = $hash<3rd 1st>;
    is +@slice2,   2, 'got the right amount of values from the %hash<> slice';
    is @slice2[0], 3, '%hash<> slice was successful (1)';
    is @slice2[1], 1, '%hash<> slice was successful (2)';

    # slice assignment
    $hash{"1st", "3rd"} = (5, 10);
    is $hash<1st>,  5, 'value was changed successfully with slice assignment';
    is $hash<3rd>, 10, 'value was changed successfully with slice assignment';

    $hash<1st 3rd> = (3, 1);
    is $hash<1st>, 3, 'value was changed successfully with slice assignment';
    is $hash<3rd>, 1, 'value was changed successfully with slice assignment';
}

# hashref assignment using {}
# L
{
    my $hash_a = { a => 1, b => 2 };
    #?niecza todo
    isa_ok $hash_a, "Hash";
    my $hash_b = { a => 1, "b", 2 };
    #?niecza todo
    isa_ok $hash_b, "Hash";
    my $hash_c = hash('a', 1, "b", 2);
    #?niecza todo
    isa_ok $hash_c, "Hash";
    my $hash_d = hash 'a', 1, "b", 2;
    #?niecza todo
    isa_ok $hash_d, "Hash";
}

# infinity HoHoHoH...
{
    my %hash = (val => 42);
    %hash = %hash;
    isa_ok %hash,           Hash;
    #?pugs todo
    isa_ok %hash,      Hash;
    #?pugs 3 skip 'Cannot cast into Hash: VRef'
    isa_ok %hash, Hash;
    is %hash,      42, "access to infinite HoHoHoH... (1)";
    is %hash, 42, "access to infinite HoHoHoH... (2)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/hash.t0000664000175000017500000002220712237474612016631 0ustar  moritzmoritzuse v6;

use Test;

plan 88;

# basic lvalue assignment
# L

my %hash1;
ok(%hash1.does(Hash), '%hash1 does Hash');
%hash1{"one"} = 5;
is(%hash1{"one"}, 5, 'lvalue hash assignment works (w/ double quoted keys)');

%hash1{'one'} = 4;
is(%hash1{'one'}, 4, 'lvalue hash re-assignment works (w/ single quoted keys)');

%hash1 = 3;
is(%hash1, 3, 'lvalue hash assignment works (w/ unquoted style )');

# basic hash creation w/ comma separated key/values

my %hash2 = ("one", 1);
ok(%hash2.does(Hash), '%hash2 does Hash');
is(%hash2{"one"}, 1, 'comma separated key/value hash creation works');
is(%hash2, 1, 'unquoted  fetching works');

my %hash3 = ("one", 1, "two", 2);
ok(%hash3.does(Hash), '%hash3 does Hash');
is(%hash3{"one"}, 1, 'comma separated key/value hash creation works with more than one pair');
is(%hash3{"two"}, 2, 'comma separated key/value hash creation works with more than one pair');

# basic hash creation w/ => separated key/values (pairs?)

my %hash4;
ok(%hash4.does(Hash), '%hash4 does Hash');
%hash4 = ("key" => "value");
is(%hash4{"key"}, 'value', '(key => value) separated key/value has creation works');

is( (map { .WHAT.gist } , {"a"=> 1 , "b"=>2}).join(' ') , Hash.gist , 'Non flattening Hashes do not become Pairs when passed to map');
my $does_not_flatten= {"a"=> 1 , "b"=>2};
is( (map { .WHAT.gist } , $does_not_flatten).join(' ') , Hash.gist , 'Non flattening Hashes do not become Pairs when passed to map');
my %flattens= ("a"=> 1 , "b"=>2);
is( (map { .WHAT.gist } , %flattens).join(' ') , Pair.gist ~ ' ' ~ Pair.gist, 'Flattening Hashes become Pairs when passed to map');

# hash slicing

my %hash5 = ("one", 1, "two", 2, "three", 3);
ok(%hash5.does(Hash), '%hash5 does Hash');

{
    my @slice1 = %hash5{"one", "three"};
    is(+@slice1, 2, 'got the right amount of values from the %hash{} slice');
    is(@slice1[0], 1, '%hash{} slice successful');
    is(@slice1[1], 3, '%hash{} slice successful');

    my @slice2 = %hash5;
    is(+@slice2, 2, 'got the right amount of values from the %hash<> slice');
    is(@slice2[0], 3, '%hash<> slice was successful');
    is(@slice2[1], 1, '%hash<> slice was successful');
}

#?niecza todo
#?pugs skip '.value'
{
    my @slice3 = %hash5<>.sort(*.value);
    is(+@slice3, 3, 'empty slice got all hash pairs');
    is(@slice3[0], "one" => 1, 'empty slice got all hash pairs');
    is(@slice3[1], "two" => 2, 'empty slice got all hash pairs');
    is(@slice3[2], "three" =>  3, 'empty slice got all hash pairs');
}

# slice assignment
{
    %hash5{"one", "three"} = (5, 10);
    is(%hash5, 5, 'value was changed successfully with slice assignment');
    is(%hash5, 10, 'value was changed successfully with slice assignment');

    %hash5 = (3, 1);
    is(%hash5, 3, 'value was changed successfully with slice assignment');
    is(%hash5, 1, 'value was changed successfully with slice assignment');

    %hash5 = [3, 1];
    is(%hash5[0], 3, 'value assigned successfully with arrayref in list context');
    is(%hash5[1], 1, 'value assigned successfully with arrayref in list context');
}

# keys

my %hash6 = ("one", 1, "two", 2, "three", 3);
ok(%hash6.does(Hash), '%hash6 does Hash');

my @keys1 = (keys %hash6).sort;
is(+@keys1, 3, 'got the right number of keys');
is(@keys1[0], 'one', 'got the right key');
is(@keys1[1], 'three', 'got the right key');
is(@keys1[2], 'two', 'got the right key');

my @keys2 = %hash6.keys.sort;
is(+@keys2, 3, 'got the right number of keys');
is(@keys2[0], 'one', 'got the right key');
is(@keys2[1], 'three', 'got the right key');
is(@keys2[2], 'two', 'got the right key');

# values

my %hash7 = ("one", 1, "two", 2, "three", 3);
ok(%hash7.does(Hash), '%hash7 does Hash');

my @values1 = (values %hash7).sort;
is(+@values1, 3, 'got the right number of values');
#?pugs 3 todo
is(@values1[0], 1, 'got the right values');
is(@values1[1], 2, 'got the right values');
is(@values1[2], 3, 'got the right values');

@values1 = %hash7.values.sort;
is(+@values1, 3, 'got the right number of values');
#?pugs 3 todo
is(@values1[0], 1, 'got the right values');
is(@values1[1], 2, 'got the right values');
is(@values1[2], 3, 'got the right values');

# misc stuff ...

my %hash8;
ok(%hash8.does(Hash), '%hash8 does Hash');
%hash8 = (:one, :key, :three(3));
ok(%hash8{'one'} === True, 'colonpair :one');
is(%hash8{'key'}, 'value', 'colonpair :key');
is(%hash8{'three'}, 3, 'colonpair :three(3)');

# kv method

my $key;
my $val;

my %hash9;
ok(%hash9.does(Hash), '%hash9 does Hash');
%hash9{1} = 2;

for (%hash9.kv) -> $k,$v {
    $key = $k;
    $val = $v;
}

is($key, 1, '%hash.kv gave us our key');
is($val, 2, '%hash.kv gave us our val');

%hash9{2} = 3;
#?pugs todo
ok(~%hash9 ~~ /^(1\t2\s+2\t3|2\t3\s+1\t2)\s*$/, "hash can stringify");

my %hash10 = <1 2>;
is(%hash10<1>, 2, "assignment of pointy qw to hash");

# after t/pugsbugs/unhashify.t

sub test1 {
    my %sane = hash ('a'=>'b');
    is(%sane.WHAT.gist,Hash.gist,'%sane is a Hash');
}

sub test2 (%hash) {
    is(%hash.WHAT.gist,Hash.gist,'%hash is a Hash');
}

my %h = hash (a => 'b');

#sanity: Hash created in a sub is a Hash
test1;

test2 %h;

# See thread "Hash creation with duplicate keys" on p6l started by Ingo
# Blechschmidt: L<"http://www.nntp.perl.org/group/perl.perl6.language/22401">
#
# 20060604: Now that defaulting works the other way around, hashes resume
# the bias-to-the-right behaviour, consistent with Perl 5.
#

my %dupl = (a => 1, b => 2, a => 3);
is %dupl, 3, "hash creation with duplicate keys works correctly";

# Moved from t/xx-uncategorized/hashes-segfault.t
# Caused some versions of pugs to segfault
{
    my %hash = %('a'..'d' Z 1..4);
    my $i = %hash.elems; # segfaults
    is $i, 4, "%hash.elems works";

    $i = 0;
    $i++ for %hash; # segfaults
    is $i, 4, "for %hash works";
}


#?pugs todo
{
    dies_ok { eval ' @%(a => )' },
     "doesn't really make sense, but shouldn't segfault, either ($!)";
}

# test for RT #62730
#?niecza todo
#?pugs todo
lives_ok { Hash.new("a" => "b") }, 'Hash.new($pair) lives';

# RT #71022
{
    my %rt71022;
    %rt71022 = %rt71022;
    ok( ! defined( %rt71022 ),
        'non-existent hash element assigned to itself is not defined, not segfault' );
}

# This test breaks all hash access after it in Rakudo, so keep it last.
# RT #71064
{
    class RT71064 {
        method postcircumfix:<{ }>($x) { 'bughunt' }    #OK not used
        method rt71064() {
            my %h = ( foo => 'victory' );
            return %h;
        }
    }

    is( RT71064.new.rt71064(), 'victory',
        'postcircumfix:<{ }> method does not break ordinary hash access' );
}

{
    my %h;
    my $x = %h;
    is %h.elems, 0, 'merely reading a non-existing hash keys does not create it';
    my $y = %h;
    #?pugs todo
    is %h.elems, 0, 'reading multi-level non-existing hash keys does not create it';
    %h = "baz";
    is %h.elems, 1, 'multi-level auto-vivify number of elements';
    #?pugs skip 'Unimplemented unaryOp: hash'
    is_deeply %h, (bar => "baz").hash, "multi-level auto-vivify";
} #4

#RT #76644
{
    my %h = statement => 3;
    is %h.keys.[0], 'statement',
        '"statement" autoquoted hash key does not collide with "state"';
}

# RT #58372
# By collective knowledge of #perl6 and @larry, .{ } is actually defined in
# Any
{
    my $x;
    lives_ok { $x{'a'} }, 'can index a variable that defaults to Any';
    nok $x{'a'}.defined, '... and the result is not defined';
    #?pugs todo
    dies_ok { Mu.{'a'} }, 'no .{ } in Mu';
}

# Whatever/Zen slices work on hashes too
{
    my %h = { a => 1, b => 2, c => 3};
    #?pugs todo
    is %h{*}.join('|'), %h.values.join('|'), '{*} whatever slice';
    is %h{}.join('|'),  %h.join('|'),        '{} zen slice';
} #2

# RT #75868
#?pugs todo
{
    my %h = (ab => 'x', 'a' => 'y');
    'abc' ~~ /^(.)./;
    is %h{$/}, 'x', 'can use $/ as hash key';
    is %h{$0}, 'y', 'can use $0 as hash key';

}

# RT #61412
{
    my %hash;
    %hash := 'bar';
    is %hash, 'bar', 'binding hash value works';
}

# RT #118947
{
    my %hash;
    %hash := 'zoom';
    is %hash, 'zoom', 'binding on auto-vivified hash value works';
    %hash := my $b;
    #?rakudo todo 'auto-vivified binding does not work yet'
    ok $b =:= %hash, 'binding variable worked';
} #1

# RT #75694
#?pugs todo
eval_lives_ok('my $rt75694 = { has-b => 42 }', "can have a bareword key starting with 'has-' in a hash");

# RT #99854
#?pugs todo
{
    eval_lives_ok 'my $rt = { grammar => 5 }',
                  "can have a bareword 'grammar' as a hash key";
}

# RT #77922
#?niecza skip "Excess arguments to Hash.new, unused named a"
{
    my $h = Hash.new(a => 3);
    $h = 5;
    is $h, 5, 'can normally modify items created from Hash.new';
}

# RT 77598
#?pugs skip 'No compatible multi variant found: "&is"'
#?niecza skip "Unsupported use of [-1] subscript to access from end of array"
{
    is {}[*-1], Failure, 'array-indexing a hash with a negative index is Failure';
}

# RT #73230
#?pugs todo
{
    my Hash $RT73230;
    $RT73230[1];
    is($RT73230.perl, 'Hash', 'test for positional (.[]) indexing on a Hash (RT #73230)');
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/infinity.t0000664000175000017500000000243412224265625017535 0ustar  moritzmoritzuse v6;
use Test;
plan 13;

# L" /Perl 6 by default makes standard IEEE floating point concepts visible>

{
    my $x = Inf;

    ok( $x == Inf  , 'numeric equal');
    ok( $x eq 'Inf', 'string equal');
}

{
    my $x = -Inf;
    ok( $x == -Inf,   'negative numeric equal' );
    ok( $x eq '-Inf', 'negative string equal' );
}

#?rakudo skip 'integer Inf'
{
    my $x = Inf.Int;
    ok( $x == Inf,   'int numeric equal' );
    #?pugs todo
    ok( $x eq 'Inf', 'int string equal' );
}

#?rakudo skip 'integer Inf'
{
    my $x = ( -Inf ).Int;
    ok( $x == -Inf,   'int numeric equal' );
    #?pugs todo
    ok( $x eq '-Inf', 'int string equal' );
}

# Inf should == Inf. Additionally, Inf's stringification (~Inf), "Inf", should
# eq to the stringification of other Infs.
# Thus:
#     Inf == Inf     # true
# and:
#     Inf  eq  Inf   # same as
#     ~Inf eq ~Inf   # true

#?pugs 4 todo
ok truncate(Inf) ~~ Inf,    'truncate(Inf) ~~ Inf';
#?rakudo 3 todo 'Int conversion of NaN and Inf'
ok NaN.Int === NaN,         'Inf.Int === Int';
ok Inf.Int === Inf,         'Inf.Int === Int';
ok (-Inf).Int === (-Inf),   'Inf.Int === Int';

# RT #70730
#?pugs skip 'parsefail'
{
    ok ( rand * Inf ) === Inf, 'multiply rand by Inf without maximum recursion depth exceeded';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/instants-and-durations.t0000664000175000017500000000204112224265625022307 0ustar  moritzmoritzuse v6;
use Test;

plan 12;

# L

{
    my $i = now;
    isa_ok $i, Instant, 'now returns an Instant';
    isa_ok 5 + $i, Instant, 'Int + Instant ~~ Instant';
    isa_ok $i - 1/3, Instant, 'Instant - Rat ~~ Instant';
}

isa_ok eval('now +300'), Instant, 'now is a term, not a function';

# L

{
    my $t0 = Instant.from-posix(1295002122);

    my $t1 = Instant.from-posix(1303059935);

    my $d = $t1 - $t0;

    ok $t0 < $t1, 'later Instants are greater';
    dies_ok { $t0 + $t1 }, 'Instant + Instant is illegal';
    isa_ok $d, Duration, 'Instant - Instant ~~ Duration';
    ok $d ~~ Real, 'Durations are Real';
    isa_ok $d + $t0, Instant, 'Instant + Duration ~~ Instant';
    isa_ok $d + $t0, Instant, 'Duration + Instant ~~ Instant';
    isa_ok $t0 - $d, Instant, 'Instant - Duration ~~ Instant';
    is $t0 + ($t1 - $t0), $t1, 'Instant A + (Instant B - Instant A) == Instant B';
}

done;

# See S32-temporal/DateTime-Instant-Duration.t for more.

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/int-uint.t0000664000175000017500000000272212224265625017453 0ustar  moritzmoritzuse v6;
use Test;

# L

my @inttypes = map {"int$_", "uint$_"}, <1 2 4 8 16 32 64>;
plan 10 * @inttypes;

for @inttypes -> $type {
    eval_lives_ok "my $type \$var; 1", "Type $type lives"
        or do {
            skip "low-level data type $type not supported on this platform", 7;
            next;
        }

    my $maxval; my $minval;
    $type ~~ /(\d+)/;
    my $len = $/[0]; # get the numeric value
    if $type ~~ /^uint/ {
        $maxval = 2**$len - 1;
        $minval = 0;
    } else { # /^int/
        $maxval = 2**($len - 1) - 1;
        $minval = -(2**($len - 1));
    }

    is(eval("my $type \$var = $maxval"), $maxval, "$type can be $maxval");
    is(eval("my $type \$var = $minval"), $minval, "$type can be $minval");
    #?pugs 5 todo
    eval_dies_ok("my $type \$var = {$maxval+1}", "$type cannot be {$maxval+1}");
    eval_dies_ok("my $type \$var = {$minval-1}", "$type cannot be {$minval-1}");
    eval_dies_ok("my $type \$var = 'foo'", "$type cannot be a string");
    eval_dies_ok("my $type \$var = 42.1", "$type cannot be non-integer");
    eval_dies_ok("my $type \$var = NaN", "$type cannot be NaN");

    #?rakudo 2 skip "Cannot modify an immutable value"
    is(eval("my $type \$var = 0; \$var++; \$var"), 1, "$type \$var++ works");
    is(eval("my $type \$var = 1; \$var--; \$var"), 0, "$type \$var-- works");
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/isDEPRECATED.t0000664000175000017500000001663712253365500017645 0ustar  moritzmoritzuse v6;

use Test;

plan 20;

# L

my $line;

# just a sub
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
{
    my $a;
    my $awith;
    sub a     is DEPRECATED              { $a++     };
    sub awith is DEPRECATED("'fnorkle'") { $awith++ };

    $line = $?LINE; a();
    is $a, 1, 'was "a" really called';
    #?rakudo.jvm todo 'tracebacks in deprecations'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for a()';
Saw 1 call to deprecated code during execution.
================================================================================
Sub a (from GLOBAL) called at:
  $*PROGRAM_NAME, line $line
Please use something else instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; awith();
    awith();
    is $awith, 2, 'was "awith" really called';
    #?rakudo.jvm todo 'tracebacks in deprecations'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for awith()';
Saw 1 call to deprecated code during execution.
================================================================================
Sub awith (from GLOBAL) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'fnorkle' instead.
--------------------------------------------------------------------------------
TEXT
} #4

# class with auto/inherited new()
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
{
    class A     is DEPRECATED                  { };
    class Awith is DEPRECATED("'Fnorkle.new'") { };

    $line = $?LINE; A.new;
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for A.new';
Saw 1 call to deprecated code during execution.
================================================================================
Method new (from A) called at:
  $*PROGRAM_NAME, line $line
Please use something else instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Awith.new;
    Awith.new;
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for Awith.new';
Saw 1 call to deprecated code during execution.
================================================================================
Method new (from Awith) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'Fnorkle.new' instead.
--------------------------------------------------------------------------------
TEXT
} #2

# class with explicit new()
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
{
    my $B;
    my $Bwith;
    class B     is DEPRECATED                 { method new { $B++     } };
    class Bwith is DEPRECATED("'Borkle.new'") { method new { $Bwith++ } };

    $line = $?LINE; B.new;
    is $B, 1, 'was "B.new" really called';
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for B.new';
Saw 1 call to deprecated code during execution.
================================================================================
Method new (from B) called at:
  $*PROGRAM_NAME, line $line
Please use something else instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Bwith.new;
    Bwith.new;
    is $Bwith, 2, 'was "Bwith.new" really called';
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for Bwith.new';
Saw 1 call to deprecated code during execution.
================================================================================
Method new (from Bwith) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'Borkle.new' instead.
--------------------------------------------------------------------------------
TEXT
} #4

# method in class
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
{
    my $C;
    my $Cwith;
    class C     { method foo is DEPRECATED          { $C++     } };
    class Cwith { method foo is DEPRECATED("'bar'") { $Cwith++ } };

    $line = $?LINE; C.new.foo;
    is $C, 1, 'was "C.new.foo" really called';
    #?rakudo.jvm todo 'tracebacks in deprecations'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for C.new.foo';
Saw 1 call to deprecated code during execution.
================================================================================
Method foo (from C) called at:
  $*PROGRAM_NAME, line $line
Please use something else instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Cwith.new.foo;
    Cwith.new.foo;
    is $Cwith, 2, 'was "Cwith.new.foo" really called';
    #?rakudo.jvm todo 'tracebacks in deprecations'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation Cwith.new.foo';
Saw 1 call to deprecated code during execution.
================================================================================
Method foo (from Cwith) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'bar' instead.
--------------------------------------------------------------------------------
TEXT
} #4

# class with auto-generated public attribute
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
{
    class D     { has $.foo is DEPRECATED          };
    class Dwith { has $.foo is DEPRECATED("'bar'") };

    $line = $?LINE; D.new.foo;
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for D.new.foo';
Saw 1 call to deprecated code during execution.
================================================================================
Method foo (from D) called at:
  $*PROGRAM_NAME, line $line
Please use something else instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Dwith.new;
    Dwith.new;
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation Dwith.new.foo';
Saw 1 call to deprecated code during execution.
================================================================================
Method foo (from Dwith) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'bar' instead.
--------------------------------------------------------------------------------
TEXT
} #2

# class with private attribute and homemade accessor
#?niecza skip 'is DEPRECATED NYI'
#?pugs   skip 'is DEPRECATED NYI'
{
    my $E;
    my $Ewith;
    class E     { has $!foo is DEPRECATED;          method foo { $E++     } };
    class Ewith { has $!foo is DEPRECATED("'bar'"); method foo { $Ewith++ } };

    $line = $?LINE; E.new.foo;
    is $E, 1, 'was "E.new.foo" really called';
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation for E.new.foo';
Saw 1 call to deprecated code during execution.
================================================================================
Method foo (from E) called at:
  $*PROGRAM_NAME, line $line
Please use something else instead.
--------------------------------------------------------------------------------
TEXT

    $line = $?LINE; Ewith.new.foo;
    Ewith.new.foo;
    is $Ewith, 2, 'was "Ewith.new.foo" really called';
    #?rakudo todo 'NYI'
    is Deprecation.report, qq:to/TEXT/.chop, 'right deprecation Ewith.new.foo';
Saw 1 call to deprecated code during execution.
================================================================================
Method foo (from Ewith) called at:
  $*PROGRAM_NAME, lines $line,{$line + 1}
Please use 'bar' instead.
--------------------------------------------------------------------------------
TEXT
} #4

# vim:set ft=perl6
rakudo-2013.12/t/spec/S02-types/keyhash.t0000664000175000017500000001304612224265625017341 0ustar  moritzmoritzuse v6;
use Test;

plan 59;

sub showkh($h) {
    $h.keys.sort.map({ $^k ~ ':' ~ $h{$k} }).join(' ')
}

# L

# untyped QuantHash
{
    my %h is QuantHash = a => 1, b => 3, c => -1, d => 7;
    is showkh(%h), 'a:1 b:3 c:-1 d:7', 'Inititalization worked';
    is %h.elems, 10, '.elems';
    is +%h, 10, 'prefix:<+> calls .elems, not .keys';

    lives_ok { %h = 0 }, 'Can set an item to 0';
    is +%h.keys, 3, '... and an item is gone';
    is showkh(%h), 'a:1 b:3 c:-1', '... and the right one is gone';
    nok %h:exists, '... also according to exists';

    %h++;
    is showkh(%h), 'a:1 b:3', '++ on an item with -1 deletes it';
    %h--;
    is showkh(%h), 'b:3', '-- also removes items when they go to zero';
    %h--;
    is showkh(%h), 'b:2', '... but only when they go to zero';

    %h = 'abc';
    is showkh(%h), 'b:2 c:abc', 'Can store a string as well';
    %h = '';
    is +%h.keys, 1, 'Setting a value to the null string also removes it';

    %h = Nil;
    is +%h.keys, 0, 'Setting a value to Nil also removes it';
    nok %h, 'An empty QuantHash is false';

    %h = "", 5, False;
    is showkh(%h), 'bar:5', 'Assignment to multiple keys';

    (%h = 0) = 7;
    is showkh(%h), 'bar:5 foo:7', '(%keyhash = 0) = 7';
    (%h = 15) = '';
    is showkh(%h), 'bar:5', '(%keyhash = 15) = \'\'';
}

{
    my %h is QuantHash = a => 5, b => 0, c => 1, d => '', e => Any;
    is showkh(%h), 'a:5 c:1', 'Pairs with false values are ignored in assignment';

    %h = foo => 1, bar => 2, foo => 1;
    is showkh(%h), 'bar:2 foo:1', "Duplicate keys aren't stored";

    %h = foo => 1, bar => 5, foo => 0,
         bar => '', bar => 3, baz => 0, baz => 'narwhal';
    is showkh(%h), 'bar:3 baz:narwhal', 'When pairs conflict, the last is preferred';

    %h = 'foo', 2, 'bar', 6, 'foo', 0,
         'bar', '', 'bar', 4, 'baz', 0, 'baz', 'unicorn';
    is showkh(%h), 'bar:4 baz:unicorn', 'Assignment of a flat list';
}

#?rakudo skip 'Non-string QuantHash keys NYI'
{
    my %h is QuantHash = 2 => 1, a => 2, (False) => 3;

    my @ks = %h.keys;
    is @ks.grep(Int)[0], 2, 'Int keys are left as Ints';
    is @ks.grep(* eqv False).elems, 1, 'Bool keys are left as Bools';
    is @ks.grep(Str)[0], 'a', 'And Str keys are permitted in the same set';
    is %h{2, 'a', False}.sort.join(' '), '1 2 3', 'All keys have the right values';
}

# QuantHash of Ints
{
    #?rakudo emit   role R1284381704 does QuantHash[Int] {}; my %h is R1284381704; # 'my SomeType %h' NYI
    my Int %h is QuantHash;
    %h = a => 1, b => 3, c => -1, d => 7, e => 0;
    is +%h.keys, 4, 'Initializing QuantHash of Ints worked';

    is %h, 0, 'Correct default value';
    is %h.elems, 10, '.elems';

    lives_ok { %h = 0 }, 'Can set an item to 0';
    is +%h.keys, 3, '... and an item is gone';
    is showkh(%h), 'a:1 b:3 c:-1', '... and the right one is gone';

    %h++;
    is showkh(%h), 'a:1 b:3', '++ on an item with -1 deletes it';

    %h--;
    is showkh(%h), 'b:3', '-- also removes items when they go to zero';
    %h--;
    is showkh(%h), 'b:2', '... but only when they go to zero';
}

# QuantHash of Strs
{
    #?rakudo emit   role R1284382935 does QuantHash[Str] {}; my %h is R1284382935; # 'my SomeType %h' NYI
    my Str %h is QuantHash;
    %h = a => 'foo', b => 'bar', c => 'baz', d => 'boor', e => '';
    is +%h.keys, 4, 'Initializing QuantHash of Strs works';

    is %h, '', 'Correct default value';

    lives_ok { %h = '' }, 'Can set an item to the null string';
    is +%h.keys, 3, '... and an item is gone';
    is showkh(%h), 'a:foo b:bar c:baz', '... and the right one is gone';

    %h ~~ s/baz//;
    is showkh(%h), 'a:foo b:bar', 'Changing a value to the null string deletes it';
    %h ~~ s/bar/b/;
    is showkh(%h), 'a:foo b:b', '... but not changing it to a one-character string';
}

# QuantHash with a custom default value
{
    #?rakudo emit   role R1284381677 does QuantHash[Any, 42] {}; my %h is R1284381677; # 'my %h is SomeType[WithParams]' NYI
    my %h is QuantHash[Any, 42];
    %h = a => 1, b => 2, c => 0, x1 => 42;
    is showkh(%h), 'a:1 b:2 c:0', 'Initializing a QuantHash with a custom default';

    is %h, 42, 'QuantHash with custom default returns the default for an unassigned key';
    is showkh(%h), 'a:1 b:2 c:0', '...without changing the QuantHash';

    %h = '';
    is showkh(%h), 'a: b:2 c:0', "Setting a key to the empty string doesn't remove it";
    %h = 42;
    is showkh(%h), 'b:2 c:0', 'But setting a key to the default does remove it';
}

# L

# Weighted .pick
{
    my %h is QuantHash = a => 1, b => 1, c => 1, d => 20;

    my @a = %h.pick: *;
    is +@a, 23, '.pick(*) returns the right number of items';
    is @a.grep(* eq 'a').elems, 1, '.pick (1)';
    is @a.grep(* eq 'b').elems, 1, '.pick (2)';
    is @a.grep(* eq 'c').elems, 1, '.pick (3)';
    is @a.grep(* eq 'd').elems, 20, '.pick (4)';
    isnt @a[^3].join, 'abc', '.pick (5)';
}

# Weighted .roll
{
    my %h is QuantHash = a => 1, b => 2;

    my @a = %h.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok 2 < @a.grep(* eq 'a') < 75, '.roll (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll (2)';
}

# .grab
{
    my %h is QuantHash = a => 40, b => 80;

    my @a = %h.grab: 30;
    is +%h, 90, '.grab(30) removes 30 elements';
    is +@a, 30, '.grab(30) yields 30 items';
    ok 1 < @a.grep(* eq 'a') < 30, '.grab (1)';
    ok @a.grep(* eq 'a') < @a.grep(* eq 'b'), '.grab (2)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/keyweight.t0000664000175000017500000000212612224265625017702 0ustar  moritzmoritzuse v6;
use Test;
plan 8;

#?rakudo emit class FatRat { method new($x, $y) { Rat.new($x, $y) } }; # FatRat NYI, so we fake it with Rat

# the below smartlink is broken; KeyWeight apparently is no longer specced
# L

{
    my %h is KeyWeight = a => FatRat.new(1,2), b => FatRat.new(3,4);
    is +%h.keys, 2, 'Inititalization worked';

    is +%h, (FatRat.new(1,2) + FatRat.new(3,4)), '+%h works';

    %h = FatRat.new(0, 1);
    is +%h.keys, 1, 'After setting an item to FatRat.new(0, 1), an item is gone';
    is ~%h.keys, 'b', '... and the right one is gone';
    is +%h, FatRat.new(3,4), '... and +%h has changed appropriately';
}

# L

{
    my %h is KeyWeight = a => FatRat.new(1,2), b => FatRat.new(3,4);
    %h = FatRat.new(-1,1); # negative key
    is +%h.keys, 2, 'No deletion of negative keys'; # may warn

    %h = x => FatRat.new(2,3), y => FatRat.new(1,3);
    my @a = %h.roll: 25;
    ok 2 < @a.grep(* eq 'y') < 25, 'KeyWeight.roll(25) (1)';
    ok @a.grep(* eq 'y') < @a.grep({* eq 'x'}), 'KeyWeight.roll(25) (2)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/lazy-lists.t0000664000175000017500000000615712224265625020025 0ustar  moritzmoritzuse v6;

# L

# Tests for lazy lists
#
# TODO - add timeout control, in tests that may loop forever
# TODO - the backends that don't have infinite lists implemented
#        should warn of this, instead of entering an infinite loop.
# TODO - add test for 2D array

# TODO - there used to be tests here (that were never run) for deleting
#        elements from a lazy list. Can't seem to reproduce them with
#        current spec.

use Test;

plan 19;


#?pugs emit unless $?PUGS_BACKEND eq "BACKEND_PERL5" {
#?pugs emit    skip_rest ("$?PUGS_BACKEND does not support lazy lists yet.",
#?pugs emit				:depends("lazy lists") );
#?pugs emit    exit;
#?pugs emit }


{
    my @a = (1..Inf);
    is( @a.splice( 2, 3 ),
        (3, 4, 5),
        "splice" );
}

# basic list operations

is( (1...Inf).elems,
    Inf,
    "elems" );

is( (1...Inf).shift,
    1,
    "shift" );

is( (1...Inf)[2..5],
    [3, 4, 5, 6],
    "simple slice" );

{
    my @a = (1..Inf);
    is( @a[2..5],
        [3, 4, 5, 6],
        "simple slice" );
}


#?pugs emit	if $?PUGS_BACKEND eq "BACKEND_PERL5" {
#?pugs emit    	skip ( 1, "countable lazy slice not fully implemented in $?PUGS_BACKEND yet",
#?pugs emit    	:depends("lazy slices") );
#?pugs emit    	is( (1..Inf)[2..100000].perl,
#?pugs emit        	"(3, 4, 5, ..., 100001, 100002, 100003)",
#?pugs emit        	"countable lazy slice" );
#?pugs emit	}

# array assignment

{
    my @a = (1..Inf);
    @a[1] = 99;
    is @a[0, 1, 2].join(' '), '1 99 3', 'assignment to infinite list';
}

{
    my @a = (1..Inf);
    @a[0,1] = (98, 99);
    is( ~@a[0..2],
        "98 99 3",
        "array slice assignment" );
}

{
    my @a = (1..Inf);
    @a[1..10002] = @a[9..10010];
    is( ~@a[0, 1, 2],
        '1 10 11',
        "big slice assignment" );
}

my $was-lazy = 1;
sub make-lazy-list($num) { gather { take $_ for 0..^$num; $was-lazy = 0 } };

{
    $was-lazy = 1;
    my @a = make-lazy-list(4);
    nok $was-lazy, "sanity: make-lazy-list sets $was-lazy.";
    $was-lazy = 1;
    my @b := make-lazy-list(4);
    ok $was-lazy, "sanity: binding won't slurp up the lazy list";
}

{
    $was-lazy = 1;
    my @one := make-lazy-list(10);
    is @one.first(*.is-prime), 2, "sanity: first is-prime is 2";
    ok $was-lazy, "first is lazy";
}

{
    $was-lazy = 1;
    my @one := make-lazy-list(10);
    is @one.grep(*.is-prime)[^3], (2, 3, 5), "sanity: first three primes are 2, 3 and 5";
    ok $was-lazy, "grep is lazy";
}

{
    $was-lazy = 1;
    my @one := make-lazy-list(10);
    is @one.map({ $^num * 2 })[^3], (0, 2, 4), "sanity: first three numbers doubled are 0, 2, 4";
    ok $was-lazy, "map is lazy";
}

{
    $was-lazy = 1;
    my @one := make-lazy-list(10);
    my @two = ;
    my @res = (@one Z @two)[^3];
    ok $was-lazy, "first argument of Z is lazy";
}

{
    $was-lazy = 1;
    my @two := make-lazy-list(10);
    my @one = ;
    my @res = (@one Z @two)[^3];
    ok $was-lazy, "second argument of Z is lazy";
}

{
    $was-lazy = 1;
    my @one := make-lazy-list(10);
    my @two = ;
    my @res = (@one X @two)[^20];
    ok $was-lazy, "first argument of X is lazy";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/lists.t0000664000175000017500000001060412224265625017040 0ustar  moritzmoritzuse v6;

#?pugs emit #
use MONKEY_TYPING;

use Test;

# L
# XXX -- Lists are not real datatypes, but I haven't found a better location
# for this test. See
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22924">

plan 28;

# Indexing lists

# RT #105368
#?pugs todo
{
  my $foo = 42;

  try { ($foo, "does_not_matter")[0] = 23 };
  is $foo, 23, "assigning a list element changed the original variable";
}

{
  my $foo = 42;

  is ($foo, "does_not_matter")[*-2], 42,
    "indexing lists by a negative index works correctly";
  #?pugs todo
  eval_dies_ok(q/my @a = ; @a[-1] = 'zero'; @a.perl/,
 	"indexing lists by a negative index without the * dies");
}

# List construction does not create new containers
#?pugs todo
{
  my $foo = 42;

  ok ($foo, "does_not_matter")[0] =:= $foo,
    "list construction should not create new containers";
}

#?pugs todo
{
  my $foo = 42;
  ok ($foo, "does_not_matter", 17)[0,1][0] =:= $foo,
    "list construction and list slicing should not create new containers";
}

# Lists as lvalues
{
  my $foo = 42;
  my $bar = 43;

  ($foo, $bar) = (23, 24);
  ok $foo == 23 && $bar eq 24,
    "using lists as lvalues works";
}

{
  my $foo = 42;
  
  #?pugs todo
  lives_ok { ($foo, *) = (23, 24) },
    "using lists with embedded Whatevers as lvalues works (1)";
  ok $foo == 23,
    "using lists with embedded Whatevers as lvalues works (2)";
}

# List slices as lvalues
{
  my $foo = 42;
  my $bar = 43;

  try { ($foo, 42, $bar, 19)[0, 2] = (23, 24) };
  #?pugs todo
  ok $foo == 23 && $bar == 24,
    "using list slices as lvalues works (1)";

  dies_ok { ($foo, 42, $bar, 19)[1, 3] = (23, 24) },
    "using list slices as lvalues works (2)";
}

# Lists as lvalues used to swap variables
{
  my $foo = 42;
  my $bar = 23;

  ($foo, $bar) = ($bar, $foo);
  ok $foo == 23 && $bar == 42,
    "using lists as lvalues to swap two variables works";
}

{
  my $foo = 1;
  my $bar = 2;
  my $baz = 3;

  ($foo, $bar, $baz) = ($baz, $foo, $bar);
  ok $foo == 3 && $bar == 1 && $baz == 2,
    "using lists as lvalues to swap three variables works";
}

# Lists as lvalues to swap, this time we use binding instead of assignment
#?rakudo skip 'list binding'
#?niecza skip 'Cannot use bind operator with this LHS'
{
  my $foo = 42;
  my $bar = 23;

  ($foo, $bar) := ($bar, $foo);
  ok $foo == 23 && $bar == 42,
    "using lists as lvalues in a binding operation to swap two variables works";

  $foo = "some_new_value";
  is $foo, "some_new_value",
    "the vars didn't lose the readwrite-ness";
}

#?rakudo skip 'list binding'
#?niecza skip 'Cannot use bind operator with this LHS'
{
  my $foo = 1;
  my $bar = 2;
  my $baz = 3;

  ($foo, $bar, $baz) := ($baz, $foo, $bar);
  ok $foo == 3 && $bar == 1 && $baz == 2,
    "using lists as lvalues in a binding operation to swap three variables works";
}

#?niecza skip 'Cannot use value like Capture as a number'
#?pugs todo
{
  my @array    = (1,2,3);
  my $capture = \@array;

  is +$capture,    1, '\@array creates a capture (1)';
  is +$capture[0], 3, '\@array creates a capture (2)';
}

{
    sub Parcel::rt62836 { 62836 }

    dies_ok { <1 2 3>.rt62836 },
            'call to user-declared sub in Parcel:: class dies';
    try { eval '<1 2 3>.rt62836' };
    #?pugs 2 todo
    ok "$!" ~~ /rt62836/,       'error message contains name of sub';
    ok "$!" ~~ /Parcel/,    'error message contains name of class';

    #?pugs emit #
    augment class Parcel { method rt62836_x { 62836 } };
    #?pugs skip "augment"
    is <1 2 3>.rt62836_x, 62836, 'call user-declared method in Parcel:: class';
}

# RT #66304
#?pugs skip 'Parcel'
{
    my $rt66304 = (1, 2, 4);
    isa_ok $rt66304, Parcel, 'List assigned to scalar is-a Parcel';
    is( $rt66304.WHAT, (1, 2, 4).WHAT,
        'List.WHAT is the same as .WHAT of list assigned to scalar' );
    dies_ok { $rt66304[1] = 'ro' }, 'literal List element is immutable';
    is $rt66304, (1, 2, 4), 'List is not changed by attempted assignment';
}

# nom regression bug
#?niecza skip 'Excess arguments to CORE List.new'
#?pugs skip 'Must only use named arguments to new() constructor'
{
    my $x = List.new('bacon');
    my $y = $x.Str;
    my $z = $x.Str;
    is $y, 'bacon', "3rd-party reification of List doesn't duplicate rest";
    is $z, 'bacon', "3rd-party reification of List doesn't duplicate rest";
}

# RT #112216
#?niecza skip 'loops'
is 'foo'[2..*].elems, 0, 'can range-index a Str with infinite range';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/mixed_multi_dimensional.t0000664000175000017500000001347012224265625022610 0ustar  moritzmoritzuse v6;

use Test;

plan 80;


=begin description

This tests some mixed multi-dimensional structures.

NOTE:
These tests don't go any more than two levels deep
(AoH, AoP) in most cases because I know these won't
work yet in Pugs. When we have this support, then
this test should be added too more.

Some deeper tests were already added.

=end description

# UNSPECCED
#?niecza skip 'Cannot use hash access on an object of type Pair'
{ # Array of Pairs
    my @array;
    isa_ok(@array, Array);

    my $pair = ('key' => 'value');
    isa_ok($pair, Pair);

    @array[0] = $pair; # assign a variable
    is(+@array, 1, 'the array has one value in it');

    isa_ok(@array[0], Pair);
    is(@array[0], 'value', 'got the right pair value');

    @array[1] = ('key1' => 'value1'); # assign it inline
    is(+@array, 2, 'the array has two values in it');
    isa_ok(@array[1], Pair);

    is(@array[1], 'value1', 'got the right pair value');
}

# UNSPECCED
{ # Array of Hashes
    my @array;
    isa_ok(@array, Array);

    my %hash = ('key', 'value', 'key1', 'value1');
    isa_ok(%hash, Hash);
    is(+%hash.keys, 2, 'our hash has two keys');

    @array[0] = %hash;
    is(+@array, 1, 'the array has one value in it');
    #?pugs todo
    isa_ok(@array[0], Hash);
    #?pugs 2 skip 'Cannot cast into a Hash'
    is(@array[0]{"key"}, 'value', 'got the right value for key');
    is(@array[0], 'value1', 'got the right value1 for key1');
}

{ # Array of Arrays
    # L
    my @array = (1, [2, 3], [4, 5], 6);
    isa_ok(@array, Array);

    is(+@array, 4, 'got 4 elements in the Array of Arrays');
    is(@array[0], 1, 'got the right first element');
    isa_ok(@array[1], Array);
    is(@array[1][0], 2, 'got the right second/first element');
    is(@array[1][1], 3, 'got the right second/second element');
    isa_ok(@array[2], Array);
    is(@array[2][0], 4, 'got the right third/first element');
    is(@array[2][1], 5, 'got the right third/second element');
    is(@array[3], 6, 'got the right fourth element');
}

# UNSPECCED
{ # Array of Subs
    my @array;
    isa_ok(@array, Array);

    @array[0] = sub { 1 };
    @array[1] = { 2 };
    @array[2] = -> { 3 };

    is(+@array, 3, 'got three elements in the Array');
    isa_ok(@array[0], Sub);
    isa_ok(@array[1], Block);
    isa_ok(@array[2], Block);

    is(@array[0](), 1, 'the first element (when executed) is 1');
    is(@array[1](), 2, 'the second element (when executed) is 2');
    is(@array[2](), 3, 'the third element (when executed) is 3');
}

# UNSPECCED
{ # Hash of Arrays
    my %hash;
    isa_ok(%hash, Hash);

    %hash = [ 1, 2, 3 ];
    isa_ok(%hash, Array);

    is(+%hash, 3, 'it should have 3 values in it');
    is(%hash[0], 1, 'got the right value');
    is(%hash[1], 2, 'got the right value');
    is(%hash[2], 3, 'got the right value');

    {
        my $array = %hash;
        is(+$array, 3, 'it should have 3 values in it');
        is($array[0], 1, 'got the right value (when I pull the array out)');
        is($array[1], 2, 'got the right value (when I pull the array out)');
        is($array[2], 3, 'got the right value (when I pull the array out)');
    }

{
    %hash.push(4);
    is(+%hash, 4, 'it should now have 4 values in it');
    is(%hash[3], 4, 'got the right value (which we just pushed onto the list)');
}

}


{ # Hash of Array-refs
  # UNSPECCED
    my %hash;
    isa_ok(%hash, Hash);

    my @array = ( 1, 2, 3 );
    isa_ok(@array, Array);

    %hash = @array;
    isa_ok(%hash, Array);

    is(+%hash, 3, 'it should have 3 values in it');
    is(%hash[0], 1, 'got the right value');
    is(%hash[1], 2, 'got the right value');
    is(%hash[2], 3, 'got the right value');

    {
        my @array = @( %hash );
        is(+@array, 3, 'it should have 3 values in it');
        is(@array[0], 1, 'got the right value (when I pull the array out)');
        is(@array[1], 2, 'got the right value (when I pull the array out)');
        is(@array[2], 3, 'got the right value (when I pull the array out)');
    }

{
    %hash.push(4);

    is(+%hash, 4, 'it should now have 4 values in it');
    is(%hash[3], 4, 'got the right value (which we just pushed onto the array)');
}

}

{ # Hashref survive addition to an array.
  my %h = ;
  my $hr = \%h;
  my $a0 = [ \%h ,'extra' ];
  my $a1 = [ \%h ];
  my $a2 = [ $hr ];
  is($a0.elems,2,'hash references should not get decomposed');
  is($a1.elems,1,'hash references should not get decomposed');
  is($a2.elems,1,'hash references should not get decomposed');
}

{ # nested, declared in one statement
    my $h = { a => [ 1,2,3 ] };
    isa_ok($h.WHAT, Array, "array nested in hashref in one declaration");
}

{ # structures deeper than 2 levels
    my @array;
    @array[0][0][0][0][0] = 5;
    isa_ok(@array, Array);
    isa_ok(@array[0], Array);
    isa_ok(@array[0][0], Array);
    isa_ok(@array[0][0][0], Array);
    isa_ok(@array[0][0][0][0], Array);
    is(@array[0][0][0][0][0], 5, "5 level deep arrays only structure");

    @array[1][0][0] = 6;
    isa_ok(@array, Array);
    isa_ok(@array[1], Hash);
    isa_ok(@array[1], Array);
    isa_ok(@array[1][0], Hash);
    is(+@array[1][0], 1, "one key at level 4");
    isa_ok(@array[1][0], Array);
    isa_ok(@array[1][0][0], Hash);
    is(@array[1][0][0], 6, "6 level deep mixed structure");


    @array[2][0] = 5;
    isa_ok(@array[1][0], Hash);
    #?rakudo todo 'isa hash'
    #?niecza todo
    #?pugs todo
    isa_ok(@array[1][0], Hash);
    #?rakudo 2 todo 'unknown'
    #?niecza todo
    is(+@array[1][0], 2, "two keys at level 4");
    #?niecza todo 'more keys at level 4'
    #?pugs todo
    is(@array[1][0], 5, "more keys at level 4");
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/mixhash.t0000664000175000017500000004120412243415234017335 0ustar  moritzmoritzuse v6;
use Test;

plan 190;

# L

# A MixHash is a QuantHash of UInt, i.e. the values are positive Int

sub showkv($x) {
    $x.keys.sort.map({"$_:{$x{$_}}"}).join(' ')
}

# L

{
    say "We do get here, right?";
    my $m = MixHash.new("a", "foo", "a", "a", "a", "a", "b", "foo");
    isa_ok $m, MixHash, 'we got a MixHash';
    is showkv($m), 'a:5 b:1 foo:2', '...with the right elements';

    is $m.default, 0, "Defaults to 0";
    is $m, 5, 'Single-key subscript (existing element)';
    isa_ok $m, Int, 'Single-key subscript yields an Int';
    is $m, 0, 'Single-key subscript (nonexistent element)';
    isa_ok $m, Int, 'Single-key subscript yields an Int (nonexistent element)';
    ok $m:exists, 'exists with existing element';
    nok $m:exists, 'exists with nonexistent element';

    is $m.values.elems, 3, "Values returns the correct number of values";
    is ([+] $m.values), 8, "Values returns the correct sum";
    ok ?$m, "Bool returns True if there is something in the MixHash";
    nok ?MixHash.new(), "Bool returns False if there is nothing in the MixHash";
    
    my $hash;
    lives_ok { $hash = $m.hash }, ".hash doesn't die";
    isa_ok $hash, Hash, "...and it returned a Hash";
    is showkv($hash), 'a:5 b:1 foo:2', '...with the right elements';

    dies_ok { $m.keys =  }, "Can't assign to .keys";
    dies_ok { $m.values = 3, 4 }, "Can't assign to .values";

    is ~$m, "5 1", 'Multiple-element access';
    is ~$m, "5 0 1 0", 'Multiple-element access (with nonexistent elements)';

    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $m.total, 8, '.total gives sum of values';
    is $m.elems, 3, '.total gives sum of values';
    is +$m, 8, '+$mix gives sum of values';

    lives_ok { $m = 42 }, "Can assign to an existing element";
    is $m, 42, "... and assignment takes effect";
    lives_ok { $m = 12 }, "Can assign to a new element";
    is $m, 12, "... and assignment takes effect";
    lives_ok { $m = 0 }, "Can assign zero to a nonexistent element";
    nok $m:exists, "... and that didn't create the element";
    lives_ok { $m = 0 }, "Can assign zero to a existing element";
    nok $m:exists, "... and it goes away";
    
    lives_ok { $m++ }, "Can ++ an existing element";
    is $m, 43, "... and the increment happens";
    lives_ok { $m++ }, "Can ++ a new element";
    is $m, 1, "... and the element is created";
    lives_ok { $m-- }, "Can -- an existing element";
    is $m, 42, "... and the decrement happens";
    lives_ok { $m-- }, "Can -- an element with value 1";
    nok $m:exists, "... and it goes away";
    #?niecza todo
    lives_ok { $m-- }, "Can -- an element that doesn't exist";
    ok $m:exists, "... and everything is still okay";
}

{
    ok (MixHash.new: ) ~~ (MixHash.new: ), "Identical mixs smartmatch with each other";
    ok (MixHash.new: ) ~~ (MixHash.new: ), "Identical mixs smartmatch with each other";
    nok (MixHash.new: ) ~~ (MixHash.new: ), "Subset does not smartmatch";
    nok (MixHash.new: ) ~~ (MixHash.new: ), "Subset (only quantity different) does not smartmatch";
    nok (MixHash.new: ) ~~ (MixHash.new: ), "Superset does not smartmatch";
    nok (MixHash.new: ) ~~ (MixHash.new: ), "Superset (only quantity different) does not smartmatch";
    nok "a" ~~ (MixHash.new: ), "Smartmatch is not element of";
    ok (MixHash.new: ) ~~ MixHash, "Type-checking smartmatch works";

    ok (set ) ~~ (MixHash.new: ), "Set smartmatches with equivalent MixHash.new:";
    nok (set ) ~~ (MixHash.new: ), "... but not if the Mix has greater quantities";
    nok (set ) ~~ MixHash, "Type-checking smartmatch works";
}

{
    isa_ok "a".MixHash, MixHash, "Str.MixHash makes a MixHash";
    is showkv("a".MixHash), 'a:1', "'a'.MixHash is mix a";

    isa_ok (a => 100000).MixHash, MixHash, "Pair.MixHash makes a MixHash";
    is showkv((a => 100000).MixHash), 'a:100000', "(a => 100000).MixHash is mix a:100000";
    is showkv((a => 0).MixHash), '', "(a => 0).MixHash is the empty mix";

    isa_ok .MixHash, MixHash, ".MixHash makes a MixHash";
    is showkv(.MixHash), 'a:2 b:1 c:1', ".MixHash makes the mix a:2 b:1 c:1";
    is showkv(["a", "b", "c", "a"].MixHash), 'a:2 b:1 c:1', "[a b c a].MixHash makes the mix a:2 b:1 c:1";
    is showkv([a => 3, b => 0, 'c', 'a'].MixHash), 'a:4 c:1', "[a => 3, b => 0, 'c', 'a'].MixHash makes the mix a:4 c:1";

    isa_ok {a => 2, b => 4, c => 0}.MixHash, MixHash, "{a => 2, b => 4, c => 0}.MixHash makes a MixHash";
    is showkv({a => 2, b => 4, c => 0}.MixHash), 'a:2 b:4', "{a => 2, b => 4, c => 0}.MixHash makes the mix a:2 b:4";
}

{
    my $m = MixHash.new();
    is $m:exists, True, ':exists with existing element';
    is $m:exists, False, ':exists with nonexistent element';
    is $m:delete, 2, ':delete works on MixHash';
    is showkv($m), 'b:1 foo:1', '...and actually deletes';
}

{
    my $m = MixHash.new('a', False, 2, 'a', False, False);
    my @ks = $m.keys;
    #?niecza 3 skip "Non-Str keys NYI"
    is @ks.grep(Int)[0], 2, 'Int keys are left as Ints';
    is @ks.grep(* eqv False).elems, 1, 'Bool keys are left as Bools';
    is @ks.grep(Str)[0], 'a', 'And Str keys are permitted in the same set';
    is $m{2, 'a', False}.join(' '), '1 2 3', 'All keys have the right values';
}

#?rakudo skip "Odd number of elements"
#?niecza skip "Unmatched key in Hash.LISTSTORE"
{
    my %h = mix ;
    ok %h ~~ Hash, 'A hash to which a Mix has been assigned remains a hash';
    is showkv(%h), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $m = MixHash.new();
    isa_ok $m, MixHash, '&MixHash.new given an array of strings produces a MixHash';
    is showkv($m), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $m = MixHash.new([ foo => 10.1, bar => 17.2, baz => 42.3, santa => 0 ]);
    is $m.total, 1, 'make sure .total is ok';
    is $m.elems, 1, 'make sure .elems is ok';
    isa_ok $m, MixHash, '&MixHash.new given an array of pairs produces a MixHash';
    is +$m, 1, "... with one element";
}

{
    my $m = MixHash.new({ foo => 10, bar => 17, baz => 42, santa => 0 }.hash);
    isa_ok $m, MixHash, '&MixHash.new given a Hash produces a MixHash';
    #?rakudo todo "Needs to catch up with spec"
    is +$m, 4, "... with four elements";
    #?niecza todo "Non-string mix elements NYI"
    #?rakudo todo "Needs to catch up with spec"
    is +$m.grep(Pair), 4, "... which are all Pairs";
}

{
    my $m = MixHash.new({ foo => 10, bar => 17, baz => 42, santa => 0 });
    isa_ok $m, MixHash, '&MixHash.new given a Hash produces a MixHash';
    is +$m, 1, "... with one element";
}

{
    my $m = MixHash.new(set );
    isa_ok $m, MixHash, '&MixHash.new given a Set produces a MixHash';
    is +$m, 1, "... with one element";
}

{
    my $m = MixHash.new(MixHash.new());
    isa_ok $m, MixHash, '&MixHash.new given a MixHash produces a MixHash';
    is +$m, 1, "... with one element";
}

{
    my $m = MixHash.new(mix );
    isa_ok $m, MixHash, '&MixHash.new given a Mix produces a MixHash';
    is +$m, 1, "... with one element";
}

# Not sure how one should do this with the new MixHash constructor
# {
#     my $m = MixHash.new(set );
#     $m += 2;
#     my $c = MixHash.new($m);
#     isa_ok $c, MixHash, '&MixHash.new given a MixHash produces a MixHash';
#     is showkv($c), 'bar:3 baz:1 foo:1', '... with the right elements';
#     $c = 10;
#     is showkv($c), 'bar:3 baz:1 foo:1 manning:10', 'Creating a new element works';
#     is showkv($m), 'bar:3 baz:1 foo:1', '... and does not affect the original MixHash';
# }

{
    my $m = { foo => 10.1, bar => 1.2, baz => 2.3}.MixHash;
    is $m.total, 13.6, 'make sure .total is ok';
    is $m.elems, 3, 'make sure .elems is ok';

    # .list is just the keys, as per TimToady: 
    # http://irclog.perlgeek.de/perl6/2012-02-07#i_5112706
    isa_ok $m.list.elems, 3, ".list returns 3 things";
    is $m.list.grep(Str).elems, 3, "... all of which are Str";

    isa_ok $m.pairs.elems, 3, ".pairs returns 3 things";
    is $m.pairs.grep(Pair).elems, 3, "... all of which are Pairs";
    is $m.pairs.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $m.pairs.grep({ .value ~~ Real }).elems, 3, "... and the values of which are Ints";

    #?rakudo 3 skip 'No longer Iterable'
    is $m.iterator.grep(Pair).elems, 3, ".iterator yields three Pairs";
    is $m.iterator.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $m.iterator.grep({True}).elems, 3, "... and nothing else";
}

{
    my $m = { foo => 10000000000, bar => 17, baz => 42 }.MixHash;
    my $s;
    my $c;
    lives_ok { $s = $m.perl }, ".perl lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    lives_ok { $c = eval $s }, ".perl.eval lives";
    isa_ok $c, MixHash, "... and produces a MixHash";
    is showkv($c), showkv($m), "... and it has the correct values";
}

{
    my $m = { foo => 2, bar => 3, baz => 1 }.MixHash;
    my $s;
    lives_ok { $s = $m.Str }, ".Str lives";
    isa_ok $s, Str, "... and produces a string";
    is $s.split(" ").sort.join(" "), "bar(3) baz foo(2)", "... which only contains bar baz and foo with the proper counts and separated by spaces";
}

{
    my $m = { foo => 10000000000, bar => 17, baz => 42 }.MixHash;
    my $s;
    lives_ok { $s = $m.gist }, ".gist lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    ok $s ~~ /foo/, "... which mentions foo";
    ok $s ~~ /bar/, "... which mentions bar";
    ok $s ~~ /baz/, "... which mentions baz";
}

# L may be bound to'>

{
    my %b := MixHash.new("a", "b", "c", "b");
    isa_ok %b, MixHash, 'A MixHash bound to a %var is a MixHash';
    is showkv(%b), 'a:1 b:2 c:1', '...with the right elements';

    is %b, 2, 'Single-key subscript (existing element)';
    is %b, 0, 'Single-key subscript (nonexistent element)';

    lives_ok { %b = 4 }, "Assign to an element";
    is %b, 4, "... and gets the correct value";
}

# L

{
    my $m = MixHash.new("a", "b", "b");

    my $a = $m.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $m.roll(2);
    is +@a, 2, '.roll(2) returns the right number of items';
    is @a.grep(* eq 'a').elems + @a.grep(* eq 'b').elems, 2, '.roll(2) returned "a"s and "b"s';

    @a = $m.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(100) (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(100) (2)';

    @a = $m.roll(*)[^100];
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(*)[^100] (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(*)[^100] (2)';

    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $m.total, 3, '.roll should not change MixHash';
    is $m.elems, 2, '.roll should not change MixHash';
}

{
    my $m = {a => 100000000000, b => 1, c => -100000000000}.MixHash;
    is $m.total, 1, 'make sure total is ok';
    is $m.elems, 3, '.roll should not change MixHash';

    my $a = $m.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $m.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok @a.grep(* eq 'a') > 97, '.roll(100) (1)';
    ok @a.grep(* eq 'b') < 3, '.roll(100) (2)';
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $m.total, 1, '.roll should not change MixHash';
    is $m.elems, 3, '.roll should not change MixHash';
}

# L

{
    my $m = MixHash.new("a", "b", "b");
    dies_ok { $m.pick }, '.pick does not work on MixHash';
}

# L

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $m = .MixHash;
    dies_ok { $m.grab }, 'cannot call .grab on a MixHash';
}


# L

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $m = MixHash.new("a", "b", "b");

    my $a = $m.grabpairs[0];
    isa_ok $a, Pair, 'did we get a Pair';
    ok $a.key eq "a" || $a.key eq "b", "We got one of the two choices";

    my @a = $m.grabpairs(2);
    is +@a, 1, '.grabpairs(2) returns the right number of items';
    is @a.grep( {.isa(Pair)} ).Num, 1, 'are they all Pairs';
    ok @a[0].key eq "a" || @a[0].key eq "b", "We got one of the two choices";
    is $m.total, 0, '.grabpairs *should* change MixHash';
    is $m.elems, 0, '.grabpairs *should* change MixHash';
}

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $m = (a=>1.1,b=>2.2,c=>3.3,d=>4.4,e=>5.5,f=>6.6,g=>7.7,h=>8.8).MixHash;
    my @a = $m.grabpairs: *;
    is +@a, 8, '.grabpairs(*) returns the right number of items';
    is @a.grep( {.isa(Pair)} ).Num, 8, 'are they all Pairs';
    is @a.grep( {1.1 <= .value <= 8.8} ).Num, 8, 'and they all have an expected value';
    is @a.sort.map({.key}).join, "abcdefgh", 'MixHash.grabpairs(*) gets all elements';
    isnt @a.map({.key}).join, "abcdefgh", 'MixHash.grabpairs(*) returns elements in a random order';
    is $m.total, 0, '.grabpairs *should* change MixHash';
    is $m.elems, 0, '.grabpairs *should* change MixHash';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "Trait name not available on variables"
{
    my %h is MixHash = a => 1, b => 0, c => 2;
    #?rakudo todo 'todo'
    nok %h:exists, '"b", initialized to zero, does not exist';
    #?rakudo todo 'todo'
    is +%h.keys, 2, 'Inititalization worked';
    is %h.elems, 3, '.elems works';
    #?rakudo todo 'todo'
    isa_ok %h, Int, '%h is an Int';
    #?rakudo todo 'todo'
    is %h, 0, '%h is 0';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "Trait name not available on variables"
{
    my %h is MixHash = a => 1, b => 0, c => 2;

    lives_ok { %h = 0 }, 'can set an item to 0';
    #?rakudo todo 'todo'
    nok %h:exists, '"c", set to zero, does not exist';
    #?rakudo todo 'todo'
    is %h.elems, 1, 'one item left';
    #?rakudo todo 'todo'
    is %h.keys, ('a'), '... and the right one is gone';

    lives_ok { %h++ }, 'can add (++) an item that was removed';
    #?rakudo todo 'todo'
    is %h.keys.sort, , '++ on an item reinstates it';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "Trait name not available on variables"
{
    my %h is MixHash = a => 1, c => 1;

    lives_ok { %h++ }, 'can "add" (++) an existing item';
    is %h, 2, '++ on an existing item increments the counter';
    is %h.keys.sort, , '++ on an existing item does not add a key';

    lives_ok { %h-- }, 'can remove an item with decrement (--)';
    #?rakudo todo 'todo'
    is %h.keys, ('c'), 'decrement (--) removes items';
    #?rakudo todo 'todo'
    nok %h:exists, 'item is gone according to exists too';
    is %h, 0, 'removed item is zero';

    lives_ok { %h-- }, 'remove a missing item lives';
    #?rakudo todo 'todo'
    is %h.keys, ('c'), 'removing missing item does not change contents';
    #?rakudo todo 'todo'
    is %h, 0, 'item removed again is still zero';
}

#?niecza skip "Trait name not available on variables"
{
    my %h of MixHash;
    ok %h.of.perl eq 'MixHash', 'is the hash really a MixHash';
    #?rakudo 2 todo 'in flux'
    lives_ok { %h = mix  }, 'Assigning a Mix to a MixHash';
    is %h.keys.sort.map({ $^k ~ ':' ~ %h{$k} }).join(' '),
        'a:1 b:2 c:2 d:1', '... works as expected';
}

{
    isa_ok 42.MixHash, MixHash, "Method .MixHash works on Int-1";
    is showkv(42.MixHash), "42:1", "Method .MixHash works on Int-2";
    isa_ok "blue".MixHash, MixHash, "Method .MixHash works on Str-1";
    is showkv("blue".MixHash), "blue:1", "Method .MixHash works on Str-2";
    my @a = ;
    isa_ok @a.MixHash, MixHash, "Method .MixHash works on Array-1";
    is showkv(@a.MixHash), "Now:1 Paradise:1 cross-handed:1 set:1 the:2 was:1 way:1", "Method .MixHash works on Array-2";
    my %x = "a" => 1, "b" => 2;
    isa_ok %x.MixHash, MixHash, "Method .MixHash works on Hash-1";
    is showkv(%x.MixHash), "a:1 b:2", "Method .MixHash works on Hash-2";
    isa_ok (@a, %x).MixHash, MixHash, "Method .MixHash works on Parcel-1";
    is showkv((@a, %x).MixHash), "Now:1 Paradise:1 a:1 b:2 cross-handed:1 set:1 the:2 was:1 way:1",
       "Method .MixHash works on Parcel-2";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/mix.t0000664000175000017500000003137712243415234016503 0ustar  moritzmoritzuse v6;
use Test;

plan 153;

sub showkv($x) {
    $x.keys.sort.map({ $^k ~ ':' ~ $x{$k} }).join(' ')
}

# L

{
    my $m = mix ;
    isa_ok $m, Mix, '&mix produces a Mix';
    is showkv($m), 'a:5 b:1 foo:2', '...with the right elements';

    is $m.default, 0, "Defaults to 0";
    is $m, 5, 'Single-key subscript (existing element)';
    isa_ok $m, Int, 'Single-key subscript yields an Int';
    is $m, 0, 'Single-key subscript (nonexistent element)';
    isa_ok $m, Int, 'Single-key subscript yields an Int (nonexistent element)';
    ok $m:exists, 'exists with existing element';
    nok $m:exists, 'exists with nonexistent element';

    is $m.values.elems, 3, "Values returns the correct number of values";
    is ([+] $m.values), 8, "Values returns the correct sum";
    ok ?$m, "Bool returns True if there is something in the Mix";
    nok ?Mix.new(), "Bool returns False if there is nothing in the Mix";

    my $hash;
    lives_ok { $hash = $m.hash }, ".hash doesn't die";
    isa_ok $hash, Hash, "...and it returned a Hash";
    is showkv($hash), 'a:5 b:1 foo:2', '...with the right elements';

    dies_ok { $m = 5 }, "Can't assign to an element (Mixs are immutable)";
    dies_ok { $m++ }, "Can't increment an element (Mixs are immutable)";
    dies_ok { $m.keys =  }, "Can't assign to .keys";
    dies_ok { $m.values = 3, 4 }, "Can't assign to .values";
    dies_ok { $m:delete }, "Can't :delete from Mix";
    dies_ok { $m.delete_key("a") }, "Can't .delete_key from Mix";

    is ~$m, "5 1", 'Multiple-element access';
    is ~$m, "5 0 1 0", 'Multiple-element access (with nonexistent elements)';

    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $m.total, 8, '.total gives sum of values';
    is +$m, 8, '+$mix gives sum of values';
}

{
    ok (mix ) ~~ (mix ), "Identical mixs smartmatch with each other";
    ok (mix ) ~~ (mix ), "Identical mixs smartmatch with each other";
    nok (mix ) ~~ (mix ), "Subset does not smartmatch";
    nok (mix ) ~~ (mix ), "Subset (only quantity different) does not smartmatch";
    nok (mix ) ~~ (mix ), "Superset does not smartmatch";
    nok (mix ) ~~ (mix ), "Superset (only quantity different) does not smartmatch";
    nok "a" ~~ (mix ), "Smartmatch is not element of";
    ok (mix ) ~~ Mix, "Type-checking smartmatch works";

    ok (set ) ~~ (mix ), "Set smartmatches with equivalent mix";
    nok (set ) ~~ (mix ), "... but not if the Mix has greater quantities";
    nok (set ) ~~ Mix, "Type-checking smartmatch works";
}

{
    isa_ok "a".Mix, Mix, "Str.Mix makes a Mix";
    is showkv("a".Mix), 'a:1', "'a'.Mix is mix a";

    isa_ok (a => 100000).Mix, Mix, "Pair.Mix makes a Mix";
    is showkv((a => 100000).Mix), 'a:100000', "(a => 100000).Mix is mix a:100000";
    is showkv((a => 0).Mix), '', "(a => 0).Mix is the empty mix";

    isa_ok .Mix, Mix, ".Mix makes a Mix";
    is showkv(.Mix), 'a:2 b:1 c:1', ".Mix makes the mix a:2 b:1 c:1";
    is showkv(["a", "b", "c", "a"].Mix), 'a:2 b:1 c:1', "[a b c a].Mix makes the mix a:2 b:1 c:1";
    is showkv([a => 3, b => 0, 'c', 'a'].Mix), 'a:4 c:1', "[a => 3, b => 0, 'c', 'a'].Mix makes the mix a:4 c:1";

    isa_ok {a => 2, b => 4, c => 0}.Mix, Mix, "{a => 2, b => 4, c => 0}.Mix makes a Mix";
    is showkv({a => 2, b => 4, c => 0}.Mix), 'a:2 b:4', "{a => 2, b => 4, c => 0}.Mix makes the mix a:2 b:4";
}

{
    my $m = mix ;
    is $m:exists, True, ':exists with existing element';
    is $m:exists, False, ':exists with nonexistent element';
    dies_ok { $m:delete }, ':delete does not work on mix';
    dies_ok { $m.delete_key("a") }, '.delete_key does not work on mix';
}

{
    my $m = mix 'a', False, 2, 'a', False, False;
    my @ks = $m.keys;
    #?niecza 3 skip "Non-Str keys NYI"
    is @ks.grep(Int)[0], 2, 'Int keys are left as Ints';
    is @ks.grep(* eqv False).elems, 1, 'Bool keys are left as Bools';
    is @ks.grep(Str)[0], 'a', 'And Str keys are permitted in the same set';
    is $m{2, 'a', False}.join(' '), '1 2 3', 'All keys have the right values';
}

#?rakudo skip "Odd number of elements"
#?niecza skip "Unmatched key in Hash.LISTSTORE"
{
    my %h = mix ;
    ok %h ~~ Hash, 'A hash to which a Mix has been assigned remains a hash';
    is showkv(%h), 'a:2 b:1 o:3 p:2', '...with the right elements';
}
{
    my %h := mix ;
    ok %h ~~ Mix, 'A hash to which a Mix has been bound becomes a Mix';
    is showkv(%h), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $m = mix ;
    isa_ok $m, Mix, '&Mix.new given an array of strings produces a Mix';
    is showkv($m), 'a:2 b:1 o:3 p:2', '...with the right elements';
}

{
    my $m = mix [ foo => 10, bar => 17, baz => 42, santa => 0 ];
    isa_ok $m, Mix, '&Mix.new given an array of pairs produces a Mix';
    is +$m, 1, "... with one element";
}

{
    # {}.hash interpolates in list context
    my $m = mix { foo => 10, bar => 17, baz => 42, santa => 0 }.hash;
    isa_ok $m, Mix, '&Mix.new given a Hash produces a Mix';
    #?rakudo todo "Not properly interpolating"
    is +$m, 4, "... with four elements";
    #?niecza todo "Non-string mix elements NYI"
    #?rakudo todo "Not properly interpolating"
    is +$m.grep(Pair), 4, "... which are all Pairs";
}

{
    # plain {} does not interpolate in list context
    my $m = mix { foo => 10, bar => 17, baz => 42, santa => 0 };
    isa_ok $m, Mix, '&Mix.new given a Hash produces a Mix';
    is +$m, 1, "... with one element";
}

{
    my $m = mix set ;
    isa_ok $m, Mix, '&Mix.new given a Set produces a Mix';
    is +$m, 1, "... with one element";
}

{
    my $m = mix SetHash.new();
    isa_ok $m, Mix, '&Mix.new given a SetHash produces a Mix';
    is +$m, 1, "... with one element";
}

{
    my $m = mix MixHash.new();
    isa_ok $m, Mix, '&Mix.new given a MixHash produces a Mix';
    is +$m, 1, "... with one element";
}

{
    my $m = mix set ;
    isa_ok $m, Mix, '&mix given a Set produces a Mix';
    is +$m, 1, "... with one element";
}

# L may be bound to'>

{
    my %m := mix ;
    isa_ok %m, Mix, 'A Mix bound to a %var is a Mix';
    is showkv(%m), 'a:1 b:2 c:1', '...with the right elements';

    is %m, 2, 'Single-key subscript (existing element)';
    is %m, 0, 'Single-key subscript (nonexistent element)';

    dies_ok { %m = 1 }, "Can't assign to an element (Mixs are immutable)";
    dies_ok { %m = mix  }, "Can't assign to a %var implemented by Mix";
    dies_ok { %m:delete }, "Can't :delete from a Mix";
    dies_ok { %m.delete_key("a") }, "Can't .delete_key from a Mix";
}

{
    my $m = { foo => 10.1, bar => 1.2, baz => 2.3}.Mix;
    is $m.total, 13.6, 'is the total calculated correctly';

    # .list is just the keys, as per TimToady: 
    # http://irclog.perlgeek.de/perl6/2012-02-07#i_5112706
    isa_ok $m.list.elems, 3, ".list returns 3 things";
    is $m.list.grep(Str).elems, 3, "... all of which are Str";

    isa_ok $m.pairs.elems, 3, ".pairs returns 3 things";
    is $m.pairs.grep(Pair).elems, 3, "... all of which are Pairs";
    is $m.pairs.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $m.pairs.grep({ .value ~~ Real }).elems, 3, "... and the values of which are Reals";

    #?rakudo 3 skip 'No longer Iterable'
    is $m.iterator.grep(Pair).elems, 3, ".iterator yields three Pairs";
    is $m.iterator.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $m.iterator.grep({True}).elems, 3, "... and nothing else";
}

{
    my $m = { foo => 10000000000.1, bar => 17.2, baz => 42.3 }.Mix;
    is $m.total, 10000000059.6, 'is the total calculated correctly';
    my $s;
    my $c;
    lives_ok { $s = $m.perl }, ".perl lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    lives_ok { $c = eval $s }, ".perl.eval lives";
    isa_ok $c, Mix, "... and produces a Mix";
    is showkv($c), showkv($m), "... and it has the correct values";
}

{
    my $m = { foo => 3.1, bar => -2.2, baz => 1 }.Mix;
    is $m.total, 1.9, 'is the total calculated correctly';
    my $s;
    lives_ok { $s = $m.Str }, ".Str lives";
    isa_ok $s, Str, "... and produces a string";
    is $s.split(" ").sort.join(" "), "bar(-2.2) baz foo(3.1)", "... which only contains bar baz and foo with the proper counts and separated by spaces";
}

{
    my $m = { foo => 10000000000, bar => 17, baz => 42 }.Mix;
    my $s;
    lives_ok { $s = $m.gist }, ".gist lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s.chars < 1000, "... of reasonable length";
    ok $s ~~ /foo/, "... which mentions foo";
    ok $s ~~ /bar/, "... which mentions bar";
    ok $s ~~ /baz/, "... which mentions baz";
}

# L may be bound to'>

{
    my %b := mix "a", "b", "c", "b";
    isa_ok %b, Mix, 'A Mix bound to a %var is a Mix';
    is showkv(%b), 'a:1 b:2 c:1', '...with the right elements';

    is %b, 2, 'Single-key subscript (existing element)';
    is %b, 0, 'Single-key subscript (nonexistent element)';
}

# L

{
    my $m = Mix.new("a", "b", "b");

    my $a = $m.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices";

    my @a = $m.roll(2);
    is +@a, 2, '.roll(2) returns the right number of items';
    is @a.grep(* eq 'a').elems + @a.grep(* eq 'b').elems, 2, '.roll(2) returned "a"s and "b"s';

    @a = $m.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(100) (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(100) (2)';

    @a = $m.roll(*)[^100];
    ok 2 < @a.grep(* eq 'a') < 75, '.roll(*)[^100] (1)';
    ok @a.grep(* eq 'a') + 2 < @a.grep(* eq 'b'), '.roll(*)[^100] (2)';

    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $m.total, 3, '.roll should not change Mix';
}

{
    my $m = {b => 1, a => 100000000000, c => -100000000000}.Mix;

    my $a = $m.roll;
    ok $a eq "a" || $a eq "b", "We got one of the two choices (and this was pretty quick, we hope!)";

    my @a = $m.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    diag "Found {+@a.grep(* eq 'a')} a's"
      if !ok @a.grep(* eq 'a') > 97, '.roll(100) (1)';
    diag "Found {+@a.grep(* eq 'b')} b's"
      if !ok @a.grep(* eq 'b') < 3, '.roll(100) (2)';
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $m.total, 1, '.roll should not change Mix';
}

# L

{
    my $m = Mix.new("a", "b", "b");
    dies_ok { $m.pick }, '.pick does not work on Mix';
}

# L

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $m = mix ;
    dies_ok { $m.grab }, 'cannot call .grab on a Mix';
}

# L

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $m = mix ;
    dies_ok { $m.grabpairs }, 'cannot call .grabpairs on a Mix';
}

{
    my $m1 = mix ( mix  ), ;
    is +$m1, 8, "Three elements";
    is $m1, 3, "One of them is 'c'";
    is $m1, 4, "One of them is 'd'";
    my $inner-mix = $m1.list.first(Mix);
    #?niecza 2 todo 'Mix in Mix does not work correctly yet'
    isa_ok $inner-mix, Mix, "One of the mix's elements is indeed a mix!";
    is showkv($inner-mix), "a:1 b:1 c:1", "With the proper elements";

    my $m = mix ;
    $m1 = mix $m, ;
    is +$m1, 3, "Three elements";
    is $m1, 1, "One of them is 'c'";
    is $m1, 1, "One of them is 'd'";
    $inner-mix = $m1.list.first(Mix);
    #?niecza 2 todo 'Mix in Mix does not work correctly yet'
    isa_ok $inner-mix, Mix, "One of the mix's elements is indeed a mix!";
    is showkv($inner-mix), "a:1 b:1 c:1", "With the proper elements";
}

{
    isa_ok 42.Mix, Mix, "Method .Mix works on Int-1";
    is showkv(42.Mix), "42:1", "Method .Mix works on Int-2";
    isa_ok "blue".Mix, Mix, "Method .Mix works on Str-1";
    is showkv("blue".Mix), "blue:1", "Method .Mix works on Str-2";
    my @a = ;
    isa_ok @a.Mix, Mix, "Method .Mix works on Array-1";
    is showkv(@a.Mix), "Now:1 Paradise:1 cross-handed:1 set:1 the:2 was:1 way:1", "Method .Mix works on Array-2";
    my %x = "a" => 1, "b" => 2;
    isa_ok %x.Mix, Mix, "Method .Mix works on Hash-1";
    is showkv(%x.Mix), "a:1 b:2", "Method .Mix works on Hash-2";
    isa_ok (@a, %x).Mix, Mix, "Method .Mix works on Parcel-1";
    is showkv((@a, %x).Mix), "Now:1 Paradise:1 a:1 b:2 cross-handed:1 set:1 the:2 was:1 way:1",
       "Method .Mix works on Parcel-2";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/multi_dimensional_array.t0000664000175000017500000000734612224265625022625 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

Multi-Dimensional Arrays

=end pod

plan 41;

# multi-dimensional array
# L

# real multi-dimensional arrays
#?rakudo skip 'Parse Error: Statement not terminated properly'
{
    my @md[2;2];
    @md[0;0] = 0;
    @md[0;1] = 2;
    @md[1;0] = 4;
    @md[1;1] = 6;
    is(@md[0;0], 0, 'accessing an array as [0;0] works (1)');
    is(@md[0;1], 2, 'accessing an array as [0;0] works (2)');
    is(@md[1;0], 4, 'accessing an array as [0;0] works (3)');
    is(@md[1;1], 6, 'accessing an array as [0;0] works (4)');
    dies_ok({@md[1;2] = 5}, 'setting a multi-d array beyond boundaries fails');

    is(@md.elems, 4, '.elems works on multidimensional array');
}

#?rakudo skip 'Parse Error: Statement not terminated properly'
{
    my @md[*;*;2];
    @md[0;0;0] = 'foo';
    @md[9;9;1] = 'bar';
    is(@md[0;0;0], 'foo', 'accessing a partially bounded array works (1)');
    is(@md[9;9;1], 'bar', 'accessing a partially bounded array works (2)');
    dies_ok({@md[0;0;2] = 9}, 'setting a partially bounded multi-d array beyond boundaries fails');

    is(@md.elems, 2, '.elems works on partially bounded multi-d array');
}

my $multi1 = [1, ['foo', 'bar', 'baz'], 5];
is(+$multi1, 3, 'the multi1 has 3 elements');
is($multi1[0], 1, 'got the right value at multi1 index 0');

{
    my $array = $multi1[1];
    is(+$array, 3, 'multi1[1] has 3 elements');
    is(+$multi1[1], 3, '+$multi1[1] works')
}

isa_ok($multi1[1], List);

# multi-dimensional array slices
# L

#?rakudo 3 todo 'Null PMC access in find_method()'
#?pugs 3 todo 'multi-dimensional indexing'
is(eval('$multi1[1;0]'), 'foo', 'got the right value at multi1 index 1,0');
is(eval('$multi1[1;1]'), 'bar', 'got the right value at multi1 index 1,1');
is(eval('$multi1[1;2]'), 'baz', 'got the right value at multi1 index 1,2');

# and the normal syntax

is($multi1[1][0], 'foo', 'got the right value at multi1 index 1,0');
is($multi1[1][1], 'bar', 'got the right value at multi1 index 1,1');
is($multi1[1][2], 'baz', 'got the right value at multi1 index 1,2');

is($multi1[2], 5, 'got the right value at multi1 index 2');

# multi-dimensional array constructed from 2 array refs

my $array_ref1 = (1, 2, 3);
my $array_ref2 = [4, 5, 6];

my $multi2 = [ $array_ref1, $array_ref2 ];
is(+$multi2, 2, 'the multi2 has 2 elements');

{
    my $array = $multi2[0];
    is(+$array, 3, 'multi2[0] has 3 elements');
    is(+$multi2[0], 3, '+$multi2[0] works');
}
#?rakudo todo 'nom regression'
isa_ok($multi2[0], List);

# slice

#?rakudo 3 todo 'Null PMC access in find_method()'
#?pugs 3 todo ''
is(eval('$multi2[0;0]'), 1, 'got the right value at multi2 index 0,0');
is(eval('$multi2[0;1]'), 2, 'got the right value at multi2 index 0,1');
is(eval('$multi2[0;2]'), 3, 'got the right value at multi2 index 0,2');

# normal

is($multi2[0][0], 1, 'got the right value at multi2 index 0,0');
is($multi2[0][1], 2, 'got the right value at multi2 index 0,1');
is($multi2[0][2], 3, 'got the right value at multi2 index 0,2');


{
    my $array = $multi2[1];
    is(+$array, 3, 'multi2[1] has 3 elements');
    is(+$multi2[1], 3, '+$multi2[1] works');
}
isa_ok($multi2[1], List);

# slice

#?rakudo 3 todo 'Null PMC access in find_method()'
#?pugs 3 todo ''
is(eval('$multi2[1;0]'), 4, 'got the right value at multi2 index 1,0');
is(eval('$multi2[1;1]'), 5, 'got the right value at multi2 index 1,1');
is(eval('$multi2[1;2]'), 6, 'got the right value at multi2 index 1,2');

# normal

is($multi2[1][0], 4, 'got the right value at multi2 index 1,0');
is($multi2[1][1], 5, 'got the right value at multi2 index 1,1');
is($multi2[1][2], 6, 'got the right value at multi2 index 1,2');

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/nan.t0000664000175000017500000000303512224265625016456 0ustar  moritzmoritzuse v6;

use Test;

plan 21;

# Undeterminate Math results
# see L<"http://mathworld.wolfram.com/Indeterminate.html">
# L" /Perl 6 by default makes standard IEEE floating point concepts visible>

is 0 * Inf  , NaN, "0 * Inf";
is Inf / Inf, NaN, "Inf / Inf";
is Inf - Inf, NaN, "Inf - Inf";
# if we say that 0**0 and Inf**0 both give 1 (sse below), then for which
# number or limit whould $number ** 0 be different from 1? so maybe just say
# that NaN ** 0 == 1?
#?rakudo skip 'unspecced and inconsistent'
is NaN ** 0,  NaN, "NaN ** 0";

is 0**0     , 1, "0**0 is 1, _not_ NaN";
is Inf**0   , 1, "Inf**0 is 1, _not_ NaN";

ok NaN ~~ NaN, 'NaN is a NaN';
nok 4 ~~ NaN, '4 is not a NaN';
nok 4.Num ~~ NaN, "4.Num is not a NaN";

isa_ok NaN + 1i, Complex, "NaN + 1i is a Complex number";
#?pugs todo
ok NaN + 1i ~~ NaN, "NaN + 1i ~~ NaN";
#?pugs todo
ok NaN ~~ NaN + 1i, "NaN ~~ NaN + 1i";

isa_ok (NaN)i, Complex, "(NaN)i is a Complex number";
#?pugs todo
ok (NaN)i ~~ NaN, "(NaN)i ~~ NaN";
#?pugs todo
ok NaN ~~ (NaN)i, "NaN ~~ (NaN)i";

#?pugs todo
ok (NaN)i ~~ NaN + 1i, "(NaN)i ~~ NaN + 1i";
#?pugs todo
ok NaN + 1i ~~ (NaN)i, "NaN + 1i ~~ (NaN)i";

#?pugs todo
ok truncate(NaN) ~~ NaN, 'truncate(NaN) ~~ NaN';

#?rakudo skip 'RT 83446'
#?niecza skip 'Nominal type check failed for scalar store; got Num, needed Int or subtype'
ok (my Int $rt83446 = NaN) ~~ NaN, 'NaN fits in Int';

#RT 103500
is NaN.perl, 'NaN', 'NaN perlification ok';

#RT 83622
#?rakudo todo 'RT 83622'
#?pugs todo
ok NaN===NaN, "NaN value identity";

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/native.t0000664000175000017500000000513112237474612017171 0ustar  moritzmoritzuse v6;
use Test;

plan 27;

{
    my int $x;
    is $x, 0, 'int default value';
    is $x + 1, 1, 'can do basic math with int';
}

{
    my num $num;
    is $num, NaN, 'num default value';
    $num = 3e0;
    ok $num * 2e0 == 6e0, 'can do basic math with num';
}

{
    my str $str;
    is $str, '', 'str default value';
    my str $s2 = 'foo';
    is $s2 ~ $s2, 'foofoo', 'string concatentation with native strings';
}

{
    multi f(int $x) { 'int' }
    multi f(Int $x) { 'Int' }
    multi f(num $x) { 'num' }
    multi f(Num $x) { 'Num' }
    multi f(str $x) { 'str' }
    multi f(Str $x) { 'Str' }
    my int $int = 3;
    my Int $Int = 4;
    my num $num = 5e0;
    my Num $Num = 6e0;
    my str $str = '7';
    my Str $Str = '8';
    is f($int), 'int', 'can identify native type with multi dispatch (int)';
    is f($Int), 'Int', 'can identify non-native type with multi dispatch (Int)';
    is f($num), 'num', 'can identify native type with multi dispatch (num)';
    is f($Num), 'Num', 'can identify non-native type with multi dispatch (Num)';
    is f($str), 'str', 'can identify native type with multi dispatch (str)';
    is f($Str), 'Str', 'can identify non-native type with multi dispatch (Str)';

    is $int * $Int, 12, 'can do math with mixed native/boxed ints';
    is_approx $num * $Num, 30e0, 'can do math with mixed native/boxed nums';
    is $str ~ $Str, '78', 'can concatenate native and boxed strings';
}

{
    # these tests are a bit pointless, since is() already shows that boxing
    # works. Still doesn't hurt to test it with explicit type constraints
    sub g(Int $x) { $x * 2 }
    my int $i = 21;
    is g($i), 42, 'routine-entry int autoboxing';

    sub h(int $x) { $x div 2 }
    my Int $I = 84;
    is h($I), 42, 'routine-entry Int autounboxing';
}

{
    my int $x = 2;
    is $x.gist, 2, 'can call method on a native int';
    my $gist = ($x = 3).gist;
    is $gist, 3, 'Can call a method on the result of assignment to int-typed var';
}

# methods on native type objects
# RT #102256
{
    isa_ok int, Mu, 'int ~~ Mu';
    is num.gist, '(num)', 'num.gist';
    nok str.defined, 'str.defined';
}

{
    sub slurpy(*@a) {
        @a.join(' ');
    }
    my int $i = 42;
    my str $s = 'roads';
    is slurpy($i, $s), '42 roads', 'can bind native vars to slurpy arrays';
}

# RT #101450
{
    my int $x;
    my num $y;
    is $x, 0, '#101450';
    is $y, NaN, '#101450';
}

# RT #102416
#?niecza skip 'Malformed my'
#?rakudo skip 'RT 102416'
{
    my int $x;
    ($x) = (5);
    is $x, 5, 'did we assign $x';
    #pugs todo 'no native support'
    is $x.WHAT, int, 'is it really a native';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/nested_arrays.t0000664000175000017500000000153012224265625020543 0ustar  moritzmoritzuse v6;

use Test;

# L

=begin description

Nested array tests; various interactions of arrayrefs, arrays, flattening and nesting.

=end description

plan 8;

{   # UNSPECCED
    my @a = (1,2,[3,4]);
    my $a = (1,2,[3,4]);
    my @b = [1,2,[3,4]];
    my $b = [1,2,[3,4]];
    my @c = (1,2,(3,4));
    my $c = (1,2,(3,4));
    my @d = [1,2,(3,4)];
    my $d = [1,2,(3,4)];

    is(+@a, 3, 'Array length, nested []');
    is(+$a, 3, 'Array object length, nested []');
    is(+@b, 1, 'Array length, nested [], outer []s');
    is(+$b, 3, 'Array object length, nested [], outer []s');

    is(+@c, 4, 'Array length, nested ()');
    #?niecza todo
    is(+$c, 4, 'Array object length, nested ()');
    is(+@d, 1, 'Array length, nested (), outer []s');
    is(+$d, 4, 'Array object length, nested (), outer []s');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/nested_pairs.t0000664000175000017500000000213412224265625020361 0ustar  moritzmoritzuse v6;

use Test;

plan 14;

=begin desc

Pair list a la L<"http://www.nntp.perl.org/group/perl.perl6.language/19360">

=end desc

# L

my $list = (1 => (2 => (3 => 4)));
isa_ok($list, Pair);

is($list.key, 1, 'the key is 1');
isa_ok($list.value, Pair, '$list.value is-a Pair');
is($list.value.key, 2, 'the list.value.key is 2');
isa_ok($list.value.value, Pair, '$list.value.value is-a Pair');
is($list.value.value.key, 3, 'the list.value.value.key is 3');
is($list.value.value.value, 4, 'the list.value.value.value is 4');

is($list, 1 => 2 => 3 => 4, 'pair operator nests right-associatively');

#?pugs todo
is($list.perl, '1 => 2 => 3 => 4', 'right-associative nested pairs .perl correctly');

my $r-list = (((1 => 2) => 3) => 4);

is($r-list.key, (1 => 2) => 3, 'the key is a nested pair');
is($r-list.key.key, 1 => 2, 'the key of the key is a nested pair');
is($r-list.value, 4, 'the value is a number');
is($r-list.key.value, 3, 'the value of the key is a number');

#?pugs todo
is($r-list.perl, '((1 => 2) => 3) => 4', 'key-nested pairs .perl correctly');

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/nil.t0000664000175000017500000000562712224265625016475 0ustar  moritzmoritzuse v6;
use Test;

# Nil may be a type now.  Required?

plan 37;

sub empty_sub {}
sub empty_do { do {} }
sub empty_branch_true { if 1 {} else { 1; } }
sub empty_branch_false { if 0 { 1; } else {} }
sub bare_return { return; }
sub rt74448 { eval '' }

ok empty_sub()          === Nil, 'empty sub returns Nil';
ok empty_do()           === Nil, 'do {} is Nil';
ok empty_branch_true()  === Nil, 'if 1 {} is Nil';
ok empty_branch_false() === Nil, 'else {} is Nil';
ok bare_return()        === Nil, 'bare return returns Nil';
ok rt74448()            === Nil, 'eval of empty string is Nil';

nok Nil.defined, 'Nil is not defined';
ok  ().defined,  '() is defined';
nok (my $x = Nil).defined, 'assigning Nil to scalar leaves it undefined'; #OK
ok (my $y = ()).defined, 'assigning () to scalar results in a defined parcel'; #OK

# RT #63894
{
    my $calls;
    sub return_nil { $calls++; return; }

    $calls = 0;
    ok return_nil() === Nil, 'return_nil() === Nil';
    is return_nil().perl, 'Nil', 'return_nil().perl says Nil';
    is $calls, 2, 'return_nil() called twice';

    my $n = return_nil();
    nok $n.defined, 'variable holding nil is not defined';
}

{
    my $x = 0;
    $x++ for Nil;
    is $x, 0, '$Statement for Nil; does zero iterations';
}

# RT 93980
ok (my $rt93980 = Nil) === Any, 'Nil assigned to scalar produces an Any'; #OK

ok (my Str $str93980 = Nil) === Str; #OK

is Nil.gist, 'Nil', 'Nil.gist eq "Nil"';
ok !Nil.new.defined, 'Nil.new is not defined';

{
    subset MyInt of Int where True;
    my MyInt $x = 5;

    lives_ok { $x = Nil }, 'can assign Nil to subsets';
    #?rakudo todo 'triage'
    ok $x === Int, 'assigns to base-type object';
}

{
    my $z := Nil;
    ok $z === Nil, 'can bind to Nil';
}

{
    sub f1($x) { } #OK
    #?rakudo todo 'triage'
    dies_ok { f1(Nil) }, 'param: dies for mandatory';

    sub f2(Int $x?) { $x }
    my $z;
    #?rakudo skip 'triage'
    lives_ok { $z = f2(Nil) }, 'param: lives for optional';
    #?rakudo todo 'triage'
    ok $z === Int, '... set to type object';
    my $z2 is default(Nil);
    #?rakudo todo 'triage'
    lives_ok { $z = f2($z2) }, 'param: lives for optional from var';
    #?rakudo todo 'triage'
    ok $z === Int, '... set to type object';

    sub f3($x = 123) { $x }
    lives_ok { $z = f3(Nil) }, 'param: lives for with-default';
    #?rakudo todo 'triage'
    is $z, 123, '... set to default';

    sub f4($x = Nil) { $x }
    ok f4() === Nil, 'can use Nil as a default (natural)';
    ok f4(Nil) === Nil, 'can use Nil as a default (nil-triggered)';
}

#?pugs   todo '$/!_ does not default to Nil'
#?niecza todo '$/!_ does not default to Nil'
{
    ok $/ === Nil, '$/ is by default Nil';
    ok $! === Nil, '$! is by default Nil';
    ok $_ === Nil, '$_ is by default Nil';

    ok $/.VAR.default === Nil, '$/ has Nil as default';
    ok $!.VAR.default === Nil, '$! has Nil as default';
    ok $_.VAR.default === Nil, '$_ has Nil as default';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/num.t0000664000175000017500000001021312224265625016475 0ustar  moritzmoritzuse v6;

use Test;

#L and C Types/Perl 6 intrinsically supports big integers>

plan 65;

isa_ok( eval(1.Num.perl), Num, 'eval 1.Num.perl is Num' );
is_approx( eval(1.Num.perl), 1, 'eval 1.Num.perl is 1' );
isa_ok( eval(0.Num.perl), Num, 'eval 0.Num.perl is Num' );
is_approx( eval(0.Num.perl), 0, 'eval 0.Num.perl is 0' );
isa_ok( eval((-1).Num.perl), Num, 'eval -1.Num.perl is Num' );
is_approx( eval((-1).Num.perl), -1, 'eval -1.Num.perl is -1' );
isa_ok( eval(1.1.Num.perl), Num, 'eval 1.1.Num.perl is Num' );
is_approx( eval(1.1.perl), 1.1, 'eval 1.1.Num.perl is 1.1' );
isa_ok( eval((-1.1).Num.perl), Num, 'eval -1.1.Num.perl is Num' );
is_approx( eval((-1.1).perl), -1.1, 'eval -1.1.Num.perl is -1.1' );
isa_ok( eval(1e100.Num.perl), Num, 'eval 1e100.Num.perl is Num' );
is_approx( eval(1e100.Num.perl), 1e100, 'eval 1e100.Num.perl is 1' );

{
    my $a = 1; "$a";
    isa_ok($a, Int);
    is($a, "1", '1 stringification works');
}

{
    my $a = -1; "$a";
    isa_ok($a, Int);
    is($a, "-1", '-1 stringification works');
}

#L and C Types/Rat supports extended precision rational arithmetic>
{
    my $a = 1 / 1;
    isa_ok($a, Rat);
    is(~$a, "1", '1/1 stringification works');
}

{
    my $a = -1.0;
    isa_ok($a, Rat);
    is($a, "-1", '-1 stringification works');
}

{
    my $a = 0.1;
    isa_ok($a, Rat);
    is($a, "0.1", '0.1 stringification works');
}

{
    my $a = -0.1; "$a";
    isa_ok($a, Rat);
    is($a, "-0.1", '-0.1 stringification works');
}

{
    my $a = 10.01; "$a";
    isa_ok($a, Rat);
    is($a, "10.01", '10.01 stringification works');
}

{
    my $a = -1.0e0;
    isa_ok($a, Num);
    is($a, "-1", '-1 stringification works');
}

{
    my $a = 0.1e0;
    isa_ok($a, Num);
    is($a, "0.1", '0.1 stringification works');
}

{
    my $a = -0.1e0; "$a";
    isa_ok($a, Num);
    is($a, "-0.1", '-0.1 stringification works');
}

{
    my $a = 10.01e0; "$a";
    isa_ok($a, Num);
    is($a, "10.01", '10.01 stringification works');
}

{
    my $a = 1e3; "$a";
    ok $a ~~ Num, '1e3 conforms to Num';
    is($a, "1000", '1e3 stringification works');
}

{
    my $a = 10.01e3; "$a";
    isa_ok($a, Num);
    is($a, "10010", '10.01e3 stringification works');
}

#L and C Types/Perl 6 intrinsically supports big integers>

{
    my $a = 0b100; "$a";
    isa_ok($a, Int);
    is($a, "4", '0b100 (binary) stringification works');
}

{
    my $a = 0x100; "$a";
    isa_ok($a, Int);
    is($a, "256", '0x100 (hex) stringification works');
}

{
    my $a = 0o100; "$a";
    isa_ok($a, Int);
    is($a, "64", '0o100 (octal) stringification works');
}

{
    my $a = 1; "$a";
    is($a + 1, 2, 'basic addition works');
}

{
    my $a = -1; "$a";
    ok($a + 1 == 0, 'basic addition with negative numbers works'); # parsing bug
}
#L and C Types/Rat supports extended precision rational arithmetic>

isa_ok(1 / 1, Rat);

{
    my $a = 80000.0000000000000000000000000;
    isa_ok($a, Rat);
    ok($a == 80000.0, 'trailing zeros compare correctly');
}

{
    my $a = 1.0000000000000000000000000000000000000000000000000000000000000000000e1;
    isa_ok($a, Num);
    ok($a == 10.0, 'trailing zeros compare correctly');
}

#L and C Types/Perl 6 intrinsically supports big integers>
{
    my $a = "1.01";
    isa_ok($a.Int, Int);
    is($a.Int, 1, "1.01 intifies to 1");
}

#L and C Types/may be bound to an arbitrary>
{
    my $a = "0d0101";
    #?pugs todo
    isa_ok(+$a, Int);
    is(+$a, 101, "0d0101 numifies to 101");
}

{
    my $a = 2 ** 65; # over the 64 bit limit too
    is($a, 36893488147419103232, "we have bignums, not weeny floats");
}

is(42_000,     42000,    'underscores allowed (and ignored) in numeric literals');
is(42_127_000, 42127000, 'multiple underscores ok');
is(42.0_1,     42.01,    'underscores in fraction ok');
is(4_2.01,     42.01,    'underscores in whole part ok');

eval_dies_ok('4_2._0_1', 'single underscores are not ok directly after the dot');
is(4_2.0_1, 42.01,  'single underscores are ok');

is 0_1, 1, "0_1 is parsed as 0d1";
is +^1, -2, '+^1 == -2 as promised';

# RT #73238
ok 0xFFFFFFFFFFFFFFFF > 1, '0xFFFFFFFFFFFFFFFF is not -1';

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/pair.t0000664000175000017500000002401012224265625016631 0ustar  moritzmoritzuse v6;

use Test;

plan 97;

# L
# basic Pair

my $pair = 'foo' => 'bar';
isa_ok($pair, Pair);

# get key and value from the pair as many ways as possible

#?rakudo 2 skip 'method($invocant:) syntax missing'
#?niecza 2 skip 'Invocant handling is NYI'
is(key($pair:), 'foo', 'got the right key($pair:)');
is(value($pair:), 'bar', 'got the right value($pair:)');

is($pair.key(), 'foo', 'got the right $pair.key()');
is($pair.value(), 'bar', 'got the right $pair.value()');

is($pair.key, 'foo', 'got the right $pair.key');
is($pair.value, 'bar', 'got the right $pair.value');

# get both (kv) as many ways as possible

my @pair1a = kv($pair);
is(+@pair1a, 2, 'got the right number of elements in the list');
is(@pair1a[0], 'foo', 'got the right key');
is(@pair1a[1], 'bar', 'got the right value');

my @pair1b = kv $pair;
is(+@pair1b, 2, 'got the right number of elements in the list');
is(@pair1b[0], 'foo', 'got the right key');
is(@pair1b[1], 'bar', 'got the right value');

my @pair1c = $pair.kv;
is(+@pair1c, 2, 'got the right number of elements in the list');
is(@pair1c[0], 'foo', 'got the right key');
is(@pair1c[1], 'bar', 'got the right value');

my @pair1d = $pair.kv();
is(+@pair1d, 2, 'got the right number of elements in the list');
is(@pair1d[0], 'foo', 'got the right key');
is(@pair1d[1], 'bar', 'got the right value');

# Pair with a numeric value

my $pair2 = 'foo' => 2;
isa_ok($pair2, Pair);

is($pair2.value, 2, 'got the right value');

# Pair with a Pair value

my $pair3 = "foo" => ("bar" => "baz");
isa_ok($pair3, Pair);

my $pair3a = $pair3.value;
isa_ok($pair3a, Pair);
is($pair3a.key, 'bar', 'got right nested pair key');
is($pair3a.value, 'baz', 'got right nested pair key');

is($pair3.value.key, 'bar', 'got right nested pair key (method chaining)');
is($pair3.value.value, 'baz', 'got right nested pair key (method chaining)');

# Pair with a Pair key

my $pair4 = ("foo" => "bar") => "baz";
isa_ok($pair4, Pair);

is($pair4.value, 'baz', 'got the right value');

isa_ok($pair4.key, Pair);
is($pair4.key.key, 'foo', 'got right nested key');
is($pair4.key.value, 'bar', 'got right nested value');

my $quux = (quux => "xyzzy");
is($quux.key, 'quux', "lhs quotes" );

{
    my $pair = :when;
    #?rakudo todo 'should it really have \n on the end?'
    #?pugs todo
    is ~(%($pair)), "when\tnow\n", 'hash stringification';
    # hold back this one according to audreyt
    #ok $pair.does(Hash), 'Pair does Hash';
    #?pugs todo
    ok (%($pair) ~~ Hash), '%() makes creates a real Hash';
}

# colonpair syntax
#?pugs skip 'colonpair'
{
    is(:foo.key, 'foo', 'got the right key :foo.key');
    isa_ok(:foo.value, Bool, ':foo.value isa Bool');
    ok( (:foo), ':foo is True');
    ok( :foo.value, ':foo.value is True');
    is(:!foo.key, 'foo', 'got the right key :!foo.key');
    isa_ok(:!foo.value, Bool, ':!foo.value isa Bool');
    nok( :!foo.value, ':!foo.value is False');
}

# illustrate a bug

{
    my $var   = 'foo' => 'bar';
    sub test1 (Pair $pair) {
        isa_ok($pair,Pair);
        my $testpair = $pair;
        isa_ok($testpair,Pair); # new lvalue variable is also a Pair
        my $boundpair := $pair;
        isa_ok($boundpair,Pair); # bound variable is also a Pair
        is($pair.key, 'foo', 'in sub test1 got the right $pair.key');
        is($pair.value, 'bar', 'in sub test1 got the right $pair.value');

    }
    test1 $var;
}

my %hash  = ('foo' => 'bar');

{
    for  %hash.pairs -> $pair {
        isa_ok($pair,Pair) ;
        my $testpair = $pair;
        isa_ok($testpair, Pair); # new lvalue variable is also a Pair
        my $boundpair := $pair;
        isa_ok($boundpair,Pair); # bound variable is also a Pair
        is($pair.key, 'foo', 'in for loop got the right $pair.key');
        is($pair.value, 'bar', 'in for loop got the right $pair.value');
    }
}

sub test2 (%h){
    for %h.pairs -> $pair {
        isa_ok($pair,Pair) ;
        is($pair.key, 'foo', 'in sub test2 got the right $pair.key');
        is($pair.value, 'bar', 'in sub test2 got the right $pair.value');
    }
}
test2 %hash;

# See thread "$pair[0]" on p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22593">

sub test3 (%h){
    for %h.pairs -> $pair {
        isa_ok($pair,Pair);
        #?pugs todo
        isa_ok($pair[0], Pair, 'sub test3: $pair[0] is $pair');
        #?niecza skip "Failure NYI"
        #?pugs   skip "Failure NYI"
        ok $pair[1] ~~ Failure, 'sub test3: $pair[1] is failure';
    }
}
test3 %hash;

=begin p6l

Hm, Hash::pair? Never heard of that.  --iblech

sub test4 (%h){
    for %h.pair -> $pair {
        isa_ok($pair,Pair);
        is($pair.key, 'foo', 'sub test4: access by unspecced "pair" got the right $pair.key');
        is($pair.value, 'bar', 'sub test4: access by unspecced "pair" got the right $pair.value');

    }
}
test4 %hash;

=end p6l

my $should_be_a_pair = (a => 25/1);
isa_ok $should_be_a_pair, Pair, "=> has correct precedence";

=begin discussion

Stated by Larry on p6l in:
L<"http://www.nntp.perl.org/group/perl.perl6.language/20122">

 "Oh, and we recently moved => to assignment precedence so it would
 more naturally be right associative, and to keep the non-chaining
 binaries consistently non-associative.  Also lets you say:

   key => $x ?? $y !! $z;

 plus it moves it closer to the comma that it used to be in Perl 5."

(iblech) XXX: this contradicts current S03 so I could be wrong.

Note, "non-chaining binary" was later renamed to "structural infix".

=end discussion

{
  # This should always work.
  my %x = ( "Zaphod" => (0 ?? 1 !! 2), "Ford" => 42 );
  is %x{"Zaphod"}, 2, "Zaphod is 2";
  is %x{"Ford"},  42, "Ford is 42";

  # This should work only if => is lower precedence than ?? !!
  my %z = ( "Zaphod" => 0 ?? 1 !! 2, "Ford" => 42 );
  is %z{"Zaphod"}, 2, "Zaphod is still 2";
  is %z{"Ford"},  42, "Ford is still 42";
}

# This is per the pairs-behave-like-one-element-hashes-rule.
# (I asked p6l once, but the "thread" got warnocked.  --iblech)
# (I asked p6l again, now the thread did definitely not get warnocked:
# L<"http://groups.google.de/group/perl.perl6.language/browse_thread/thread/e0e44be94bd31792/6de6667398a4d2c7?q=perl6.language+Stringification+pairs&">
# Also see L<"http://www.nntp.perl.org/group/perl.perl6.language/23224">
{
  my $pair = (a => 1);
  is ~$pair, "a\t1", "pairs stringify correctly (1)";
  is "$pair", "a\t1", "pairs stringify correctly (2)";
}

{
  my $pair = (a => [1,2,3]);
  is ~$pair, "a\t1 2 3", "pairs with arrayrefs as values stringify correctly (1)";
  is "$pair", "a\t1 2 3", "pairs with arrayrefs as values stringify correctly (2)";
}

# Per Larry L<"http://www.nntp.perl.org/group/perl.perl6.language/23525">:
#   Actually, it looks like the bug is probably that => is forcing
#   stringification on its left argument too agressively.  It should only do
#   that for an identifier.
{
  my $arrayref = [< a b c >];
  my $hashref  = { :d(1), :e(2) };

  my $pair = ($arrayref => $hashref);
  is ~$pair.key,   ~$arrayref, "=> should not stringify the key (1)";
  is ~$pair.value, ~$hashref,  "=> should not stringify the key (2)";

  push $pair.key, "d";
  $pair.value = 3;
  is ~$pair.key,   ~$arrayref, "=> should not stringify the key (3)";
  is ~$pair.value, ~$hashref,  "=> should not stringify the key (4)";
  is +$pair.key,            4, "=> should not stringify the key (5)";
  is +$pair.value,          3, "=> should not stringify the key (6)";
}

{
  my $arrayref = [< a b c >];
  my $hashref  = { :d(1), :e(2) };

  my $pair = ($arrayref => $hashref);
  sub pair_key (Pair $pair) { $pair.key }

  is ~pair_key($pair), ~$arrayref,
    "the keys of pairs should not get auto-stringified when passed to a sub (1)";

  push $pair.key, "d";
  is ~pair_key($pair), ~$arrayref,
    "the keys of pairs should not get auto-stringified when passed to a sub (2)";
  is +pair_key($pair),          4,
    "the keys of pairs should not get auto-stringified when passed to a sub (3)";
}

# Per Larry: http://www.nntp.perl.org/group/perl.perl6.language/23984
{
  my ($key, $val) = ;
  my $pair        = ($key => $val);

  #?pugs 2 todo 'bug'
  lives_ok { $pair.key = "KEY" }, "setting .key does not die";
  is $pair.key,          "KEY",   "setting .key actually changes the key";
  #?niecza todo "setting .key changes original val!"
  is $key,               "key",   "setting .key does not change the original var";

  #?pugs 2 todo 'bug'
  lives_ok { $pair.value = "VAL" }, "setting .value does not die";
  is $pair.value,          "VAL",   "setting .value actually changes the value";
  #?niecza todo "setting .key changes original val!"
  is $val,                 "val",   "setting .value does not change the original var";
}

##  These tests really belong in a different test file -- probably
##  something in S06.  --pmichaud
# L
#
{
    my $item = 'bar';
    my $pair = (:$item);
    ok($pair eqv (item => $item), ':$foo syntax works');

    my @arr  = ;
    $pair = (:@arr);
    ok($pair eqv (arr => @arr), ':@foo syntax works');

    my %hash = foo => 'bar', baz => 'qux';
    $pair = (:%hash);
    #?pugs todo
    ok($pair eqv (hash => %hash), ':%foo syntax works');
}

#?niecza skip "eqv NYI for Pair"
{
    my sub code {return 42}
    $pair = (:&code);
    ok($pair eqv (code => &code), ':&foo syntax works');
}

# RT #67218
{
    eval_lives_ok ':a()',    'can parse ":a()"';
    lives_ok     {; :a() }, 'can execute ":a()"';

    eval_lives_ok ':a[]',    'can parse ":a[]"';
    lives_ok     {; :a[] }, 'can execute ":a[]"';

    eval_lives_ok '(a => ())',    'can parse "(a => ())"';
    #?pugs skip 'Cannot cast from VList to VCode'
    lives_ok     { (a => ()) }, 'can execute "(a => ())"';

    eval_lives_ok '(a => [])',    'can parse "(a => [])"';
    #?pugs skip 'Cannot cast from VList to VCode'
    lives_ok     { (a => []) }, 'can execute "(a => [])"';
}

#?pugs skip ".invert"
{
    is (a => 3).invert.key, 3, 'Pair.invert.key';
    isa_ok (a => 3).invert.key, Int, 'Pair.invert.key type';
    is (a => 3).invert.value, 'a', 'Pair.invert.value';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/parcel.t0000664000175000017500000000536112250462647017156 0ustar  moritzmoritzuse v6;
use Test;

plan 44;

isa_ok (5, 7, 8), Parcel, '(5, 7, 8) is Parcel';
is +(5, 7, 8), 3, 'prefix:<+> on a Parcel';
is ~(5, 7, 8), '5 7 8', 'prefix:<~> on a Parcel';
is (5, 7, 8).Str, '5 7 8', '.Str on a Parcel';

# .perl
is ().perl, '()', '.perl on empty Parcel';
#?niecza todo '.item.perl on empty Parcel gives Match.ast shorthand'
is ().item.perl, '$( )', '.item.perl on empty Parcel';

# L

isa_ok <5 7 8>, Parcel, '<5 7 8> is Parcel';
is +<5 7 8>, 3, 'prefix:<+> on an angle bracket Parcel';
is ~<5 7 8>, '5 7 8', 'prefix:<~> on an angle bracket Parcel';
is <5 7 8>.Str, '5 7 8', '.Str on an angle bracket Parcel';

#?niecza 3 skip ".Parcel NYI"
isa_ok (5, 7, 8).Parcel, Parcel, '.Parcel returns an parcel';
is (5, 7, 8).Parcel, [5,7,8], '.Parcel contains the right items';
is (5, 7, 8).Parcel.elems, 3, '.Parcel contains the right number of elements';

is ?(), False, 'empty Parcel is False';
is ?(1,2,3), True, 'non-empty Parcel is True';

lives_ok { <5 7 8>[] }, 'can zen slice a Parcel';

# RT #115282
is (;).elems, 0, '(;) parses, and is empty';

# .rotate
{
    my $p = ;
    is ~$p.rotate, 'b c d e a', 'Parcel.rotate defaults to +1';
    is ~$p, 'a b c d e', 'original parcel unmodified';
    ok $p.rotate ~~ Parcel, 'Parcel.rotate returns a Parcel';

    is ~$p.rotate(2), 'c d e a b', '.rotate(2)';
    is ~$p, 'a b c d e', 'original parcel still unmodified';

    is ~$p.rotate(-2), 'd e a b c', '.rotate(-2)';
    is ~$p, 'a b c d e', 'original still unmodified (negative)';

    is ~$p.rotate(0), 'a b c d e', '.rotate(0)';
    is ~$p.rotate(5), 'a b c d e', '.rotate(5)';
    is ~$p.rotate(15), 'a b c d e', '.rotate(15)';

    is ~$p.rotate(7), 'c d e a b', '.rotate(7)';
    is ~$p, 'a b c d e', 'original still unmodified (negative)';

    is ~$p.rotate(-8), 'c d e a b', '.rotate(-8)';
    is ~$p, 'a b c d e', 'original still unmodified (negative)';
} #14

# all the same but rotate() sub
{
    my $p = ;
    is ~rotate($p), 'b c d e a', 'rotate(@a)';
    is ~$p, 'a b c d e', 'original parcel unmodified';

    is ~rotate($p, 2), 'c d e a b', 'rotate(@a, 2)';
    is ~$p, 'a b c d e', 'original parcel still unmodified';

    is ~rotate($p, -2), 'd e a b c', 'rotate(@a, -2)';
    is ~$p, 'a b c d e', 'original still unmodified (negative)';

    is ~rotate($p, 0), 'a b c d e', 'rotate(@a, 0)';
    is ~rotate($p, 5), 'a b c d e', 'rotate(@a, 5)';
    is ~rotate($p, 15), 'a b c d e', 'rotate(@a, 15)';

    is ~rotate($p, 7), 'c d e a b', 'rotate(@a, 7)';
    is ~$p, 'a b c d e', 'original still unmodified (negative)';

    is ~rotate($p, -8), 'c d e a b', 'rotate(@a, -8)';
    is ~$p, 'a b c d e', 'original still unmodified (negative)';
} #13

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/parsing-bool.t0000664000175000017500000000060412224265625020275 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# L, short-circuit inclusive or">
# L

is (try { 42 or Bool::False }), 42, "Bool::False as RHS";
#?pugs todo 'parsing'
is (try { Bool::False or 42 }), 42, "Bool::False as LHS";

is (try { 42 or False }), 42, "False as RHS";
is (try { False or 42 }), 42, "False as LHS";

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/range.t0000664000175000017500000002367712241704255017010 0ustar  moritzmoritzuse v6;

use Test;

plan 129;

# basic Range
# L

my $r = 1..5;
#?pugs 2 skip 'Range'
isa_ok $r, Range, 'Type';
is $r.WHAT.gist, Range.gist, 'Type';
#?pugs todo
is $r.perl, '1..5', 'canonical representation';

# XXX unspecced: exact value of Range.perl
#?pugs todo
is (1..5).perl, '1..5', ".perl ..";
#?pugs todo
is (1^..5).perl, '1^..5', ".perl ^..";
#?pugs todo
is (1..^5).perl, '1..^5', ".perl ..^";
#?pugs todo
is (1^..^5).perl, '1^..^5', ".perl ^..^";

my @r = $r;
is @r, [1, 2, 3, 4, 5], 'got the right array';

# Range of Str

$r = 'a'..'c';
#?pugs skip 'Range'
isa_ok $r, Range;
# XXX unspecced: exact value of Range.perl
#?pugs todo
is $r.perl, '"a".."c"', 'canonical representation';
@r = $r;
is @r, [< a b c >], 'got the right array';

# Stationary ranges
#?pugs todo
is (1..1).perl, '1..1', "stationary num .perl ..";
is (1..1), [1,], 'got the right array';
#?pugs todo
is ('a'..'a').perl, '"a".."a"', "stationary str .perl ..";
is ('a'..'a'), [< a >], 'got the right array';

#?niecza skip 'Unable to resolve method reverse in class Range'
{
    my $x = 0;
    $x++ for (1..4).reverse;
    is $x, 4, '(1..4).reverse still turns into a list of four items';
    my $y = 0;
    $y++ for @( eval((1..4).reverse.perl) );
    is $y, 4, '(1..4).reverse.perl returns something useful';
}

# ACCEPTS and equals tests
{
    my $r = 1..5;
    #?pugs 2 skip 'ACCEPTS'
    ok(($r).ACCEPTS($r), 'accepts self');
    ok(($r).ACCEPTS(1..5), 'accepts same');
    ok($r ~~ $r, 'accepts self');
    ok($r ~~ 1..5, 'accepts same');
    # TODO check how to avoid "eager is", test passes but why?
    is($r, $r, "equals to self");
    my $s = 1..5;
    is($r, $s, "equals");
}


# Range in comparisons
#?pugs skip 'ACCEPTS'
ok((1..5).ACCEPTS(3), 'int in range');
#?pugs todo
ok(3 ~~ 1..5, 'int in range');
ok(3 !~~ 6..8, 'int not in range');

#?pugs skip 'ACCEPTS'
ok(('a'..'z').ACCEPTS('x'), 'str in range');
#?pugs todo
ok('x' ~~ 'a'..'z', 'str in range');
ok('x' !~~ 'a'..'c', 'str not in range');
#?pugs 2 skip 'ACCEPTS'
ok(('aa'..'zz').ACCEPTS('ax'), 'str in range');
ok(('a'..'zz').ACCEPTS('ax'), 'str in range');

is(+(6..6), 1, 'numification');
is(+(6^..6), 0, 'numification');
is(+(6..^6), 0, 'numification');
is(+(6..^6.1), 1, 'numification');
is(+(6..8), 3, 'numification');
is(+(1^..10), 9, 'numification');
is(+(1..^10), 9, 'numification');
is(+(1^..^10), 8, 'numification');
is(+(10..9), 0, 'numification');
is(+(1.2..4), 3, 'numification');
is(+(1..^3.3), 3, 'numification');
is(+(2.3..3.1), 1, 'numification');
#?niecza skip 'Attempted to access slot $!min of type object for Range'
#?pugs skip 'Range'
is(+Range, 0, 'type numification');

# immutability
#?pugs todo
{
    my $r = 1..5;

    dies_ok { $r.shift       }, 'range is immutable (shift)';
    dies_ok { $r.pop         }, 'range is immutable (pop)';
    dies_ok { $r.push(10)    }, 'range is immutable (push)';
    dies_ok { $r.unshift(10) }, 'range is immutable (unshift)';

    my $s = 1..5;
    is $r, $s, 'range has not changed';
}

# simple range
{
    my $r = 1 .. 5;
    #?pugs 2 todo
    is($r.min, 1, 'range.min');
    is($r.max, 5, 'range.max');
    #?pugs skip '.bounds'
    is($r.bounds, (1,5), 'range.bounds');
}

# uneven ranges
{
    my $r = 1 .. 4.5;
    #?pugs 2 todo
    is($r.min, 1,   'range.min');
    is($r.max, 4.5, 'range.max');
    #?pugs skip '.bounds'
    is($r.bounds, (1, 4.5), 'range.bounds');
}

# infinite ranges
#?pugs skip 'hangs'
{
    my $inf = -Inf..Inf;

    ok(42  ~~ $inf, 'positive integer matches -Inf..Inf');
    ok(.2  ~~ $inf, 'positive non-int matches -Inf..Inf');
    ok(-2  ~~ $inf, 'negative integer matches -Inf..Inf');
    ok(-.2 ~~ $inf, 'negative non-int matches -Inf..Inf');
}

# infinite ranges using Whatever
#?niecza skip 'Undeclared name: "Failure"'
#?pugs skip 'hangs'
{
    my $inf = *..*;
    ok($inf ~~ Failure, "*..* is illegal");
}

# ranges constructed from parameters, from RT#63002.
{
    sub foo($a) { ~($a .. 5) };
    is(foo(5), '5', 'range constructed from parameter OK');
}

# ranges constructed from parameters, #2
{
    for 1 -> $i {
        for $i..5 -> $j { };
        is($i, 1, 'Iter range from param doesnt modify param (RT #66280)');
    }
}

{
    #?pugs todo
    is((1..8)[*-1], 8, 'postcircumfix:<[ ]> on range works');
    is((1..8)[1,3], [2,4], 'postcircumfix:<[ ]> on range works');
}

#?pugs skip "pick *"
{
    my @b = pick(*, 1..100);
    is @b.elems, 100, "pick(*, 1..100) returns the correct number of elements";
    is ~@b.sort, ~(1..100), "pick(*, 1..100) returns the correct elements";
    is ~@b.grep(Int).elems, 100, "pick(*, 1..100) returns Ints";

    @b = (1..100).pick(*);
    is @b.elems, 100, "pick(*, 1..100) returns the correct number of elements";
    is ~@b.sort, ~(1..100), "pick(*, 1..100) returns the correct elements";
    is ~@b.grep(Int).elems, 100, "pick(*, 1..100) returns Ints";

    isa_ok (1..100).pick, Int, "picking a single element from an range of Ints produces an Int";
    ok (1..100).pick ~~ 1..100, "picking a single element from an range of Ints produces one of them";

    isa_ok (1..100).pick(1), Int, "picking 1 from an range of Ints produces an Int";
    ok (1..100).pick(1) ~~ 1..100, "picking 1 from an range of Ints produces one of them";

    my @c = (1..100).pick(2);
    isa_ok @c[0], Int, "picking 2 from an range of Ints produces an Int...";
    isa_ok @c[1], Int, "... and an Int";
    ok (@c[0] ~~ 1..100) && (@c[1] ~~ 1..100), "picking 2 from an range of Ints produces two of them";
    ok @c[0] != @c[1], "picking 2 from an range of Ints produces two distinct results";

    is (1..100).pick("25").elems, 25, ".pick works Str arguments";
    is pick("25", 1..100).elems, 25, "pick works Str arguments";
}

#?pugs skip "pick *"
{
    my @b = pick(*, 'b' .. 'y');
    is @b.elems, 24, "pick(*, 'b' .. 'y') returns the correct number of elements";
    is ~@b.sort, ~('b' .. 'y'), "pick(*, 'b' .. 'y') returns the correct elements";
    is ~@b.grep(Str).elems, 24, "pick(*, 'b' .. 'y') returns Strs";

    @b = ('b' .. 'y').pick(*);
    is @b.elems, 24, "pick(*, 'b' .. 'y') returns the correct number of elements";
    is ~@b.sort, ~('b' .. 'y'), "pick(*, 'b' .. 'y') returns the correct elements";
    is ~@b.grep(Str).elems, 24, "pick(*, 'b' .. 'y') returns Strs";

    isa_ok ('b' .. 'y').pick, Str, "picking a single element from an range of Strs produces an Str";
    ok ('b' .. 'y').pick ~~ 'b' .. 'y', "picking a single element from an range of Strs produces one of them";

    isa_ok ('b' .. 'y').pick(1), Str, "picking 1 from an range of Strs produces an Str";
    ok ('b' .. 'y').pick(1) ~~ 'b' .. 'y', "picking 1 from an range of Strs produces one of them";

    my @c = ('b' .. 'y').pick(2);
    isa_ok @c[0], Str, "picking 2 from an range of Strs produces an Str...";
    isa_ok @c[1], Str, "... and an Str";
    ok (@c[0] ~~ 'b' .. 'y') && (@c[1] ~~ 'b' .. 'y'), "picking 2 from an range of Strs produces two of them";
    ok @c[0] ne @c[1], "picking 2 from an range of Strs produces two distinct results";

    is ('b' .. 'y').pick("10").elems, 10, ".pick works Str arguments";
    is pick("10", 'b' .. 'y').elems, 10, "pick works Str arguments";
}

#?pugs skip "roll"
{
    my @b = roll(100, 1..100);
    is @b.elems, 100, "roll(100, 1..100) returns the correct number of elements";
    is ~@b.grep(1..100).elems, 100, "roll(100, 1..100) returns elements from 1..100";
    is ~@b.grep(Int).elems, 100, "roll(100, 1..100) returns Ints";

    @b = (1..100).roll(100);
    is @b.elems, 100, "roll(100, 1..100) returns the correct number of elements";
    is ~@b.grep(1..100).elems, 100, "roll(100, 1..100) returns elements from 1..100";
    is ~@b.grep(Int).elems, 100, "roll(100, 1..100) returns Ints";

    isa_ok (1..100).roll, Int, "rolling a single element from an range of Ints produces an Int";
    ok (1..100).roll ~~ 1..100, "rolling a single element from an range of Ints produces one of them";

    isa_ok (1..100).roll(1), Int, "rolling 1 from an range of Ints produces an Int";
    ok (1..100).roll(1) ~~ 1..100, "rolling 1 from an range of Ints produces one of them";

    my @c = (1..100).roll(2);
    isa_ok @c[0], Int, "rolling 2 from an range of Ints produces an Int...";
    isa_ok @c[1], Int, "... and an Int";
    ok (@c[0] ~~ 1..100) && (@c[1] ~~ 1..100), "rolling 2 from an range of Ints produces two of them";

    is (1..100).roll("25").elems, 25, ".roll works Str arguments";
    is roll("25", 1..100).elems, 25, "roll works Str arguments";
}

#?pugs skip "roll"
{
    my @b = roll(100, 'b' .. 'y');
    is @b.elems, 100, "roll(100, 'b' .. 'y') returns the correct number of elements";
    is ~@b.grep('b' .. 'y').elems, 100, "roll(100, 'b' .. 'y') returns elements from b..y";
    is ~@b.grep(Str).elems, 100, "roll(100, 'b' .. 'y') returns Strs";

    @b = ('b' .. 'y').roll(100);
    is @b.elems, 100, "roll(100, 'b' .. 'y') returns the correct number of elements";
    is ~@b.grep('b' .. 'y').elems, 100, "roll(100, 'b' .. 'y') returns elements from b..y";
    is ~@b.grep(Str).elems, 100, "roll(100, 'b' .. 'y') returns Strs";

    isa_ok ('b' .. 'y').roll, Str, "rolling a single element from an range of Strs produces an Str";
    ok ('b' .. 'y').roll ~~ 'b' .. 'y', "rolling a single element from an range of Strs produces one of them";

    isa_ok ('b' .. 'y').roll(1), Str, "rolling 1 from an range of Strs produces an Str";
    ok ('b' .. 'y').roll(1) ~~ 'b' .. 'y', "rolling 1 from an range of Strs produces one of them";

    my @c = ('b' .. 'y').roll(2);
    isa_ok @c[0], Str, "rolling 2 from an range of Strs produces an Str...";
    isa_ok @c[1], Str, "... and an Str";
    ok (@c[0] ~~ 'b' .. 'y') && (@c[1] ~~ 'b' .. 'y'), "rolling 2 from an range of Strs produces two of them";

    is ('b' .. 'y').roll("10").elems, 10, ".roll works Str arguments";
    is roll("10", 'b' .. 'y').elems, 10, "roll works Str arguments";
}

#?pugs skip 'Cannot cast from VList to VCode'
is join(':',grep 1..3, 0..5), '1:2:3', "ranges itemize or flatten lazily";

lives_ok({'A'..'a'}, "A..a range completes");
lives_ok({"\0".."~"}, "low ascii range completes");

# vim:set ft=perl6
rakudo-2013.12/t/spec/S02-types/sethash.t0000664000175000017500000003655412225464703017354 0ustar  moritzmoritzuse v6;
use Test;

plan 182;

# L

# A SetHash is a QuantHash of Bool, i.e. the values are Bool

sub showset($s) { $s.keys.sort.join(' ') }

# L

{
    my $s = SetHash.new();
    isa_ok $s, SetHash, 'SetHash.new produces a SetHash';
    is showset($s), 'a b foo', '...with the right elements';

    is $s.default, False, "Default value is false";
    is $s, True, 'Single-key subscript (existing element)';
    isa_ok $s, Bool, 'Single-key subscript has correct type (existing element)';
    is $s, False, 'Single-key subscript (nonexistent element)';
    isa_ok $s, Bool, 'Single-key subscript has correct type (nonexistent element)';
    is $s:exists, True, 'exists with existing element';
    is $s:exists, False, 'exists with nonexistent element';

    ok ?$s, "Bool returns True if there is something in the SetHash";
    nok ?Set.new(), "Bool returns False if there is nothing in the SetHash";

    my $hash;
    lives_ok { $hash = $s.hash }, ".hash doesn't die";
    isa_ok $hash, Hash, "...and it returned a Hash";
    is showset($hash), 'a b foo', '...with the right elements';
    is $hash.values.grep({ ($_ ~~ Bool) && $_ }).elems, 3, "...and values";

    dies_ok { $s.keys =  }, "Can't assign to .keys";
    dies_ok { $s.values =  }, "Can't assign to .values";

    is ($s).grep(?*).elems, 2, 'Multiple-element access';
    is ($s).grep(?*).elems, 2, 'Multiple-element access (with nonexistent elements)';

    is $s.elems, 3, '.elems gives number of keys';
    is +$s, 3, '+$set gives number of keys';
    
    $s = True;
    lives_ok { $s = True }, 'can set an item to True';
    is showset($s), 'a b baz foo', '...and it adds it to the SetHash';
    lives_ok { $s = True }, 'can set the same item to True';
    is showset($s), 'a b baz foo', '...and it does nothing';

    lives_ok { $s = False }, 'can set an item to False';
    is showset($s), 'a b foo', 'and it removes it';
    lives_ok { $s = False }, 'can set an item which does not exist to False';
    is showset($s), 'a b foo', '... and it is not added to the set';
    
    lives_ok { $s = False }, 'can set an item to False';
    is $s.elems, 2, '... and an item is gone';
    is showset($s), 'a b', '... and the right one is gone';
    
    lives_ok { $s++ }, 'can ++ an item';
    is showset($s), 'a b foo', '++ on an item reinstates it';
    lives_ok { $s++ }, 'can ++ an item';
    is showset($s), 'a b foo', '++ on an existing item does nothing';

    lives_ok { $s-- }, 'can -- an item';
    is showset($s), 'a foo', '-- on an item removes it';
    lives_ok { $s-- }, 'can -- an item';
    is showset($s), 'a foo', '... but only if they were there to start with';
}

{
    ok (SetHash.new: ) ~~ (SetHash.new: ), "Identical sets smartmatch with each other";
    nok (SetHash.new: ) ~~ (SetHash.new: ), "Subset does not smartmatch";
    nok (SetHash.new: ) ~~ (SetHash.new: ), "Superset does not smartmatch";
    nok "a" ~~ (SetHash.new: ), "Smartmatch is not element of";
    ok (SetHash.new: ) ~~ SetHash, "Type-checking smartmatch works";
    ok (set ) ~~ (SetHash.new: ), "SetHash matches Set, too";

    ok (bag ) ~~ (SetHash.new: ), "Bag smartmatches with equivalent SetHash:";
    ok (bag ) ~~ (SetHash.new: ), "... even if the Bag has greater quantities";
    nok (bag ) ~~ (SetHash.new: ), "Subset does not smartmatch";
    nok (bag ) ~~ (SetHash.new: ), "Superset does not smartmatch";
    nok (bag ) ~~ SetHash, "Type-checking smartmatch works";
}

{
    isa_ok "a".SetHash, SetHash, "Str.SetHash makes a SetHash";
    is showset("a".SetHash), 'a', "'a'.SetHash is set a";

    isa_ok (a => 1).SetHash, SetHash, "Pair.SetHash makes a SetHash";
    is showset((a => 1).SetHash), 'a', "(a => 1).SetHash is set a";
    is showset((a => 0).SetHash), '', "(a => 0).SetHash is the empty set";

    isa_ok .SetHash, SetHash, ".SetHash makes a SetHash";
    is showset(.SetHash), 'a b c', ".SetHash makes the set a b c";
    is showset(["a", "b", "c", "a"].SetHash), 'a b c', "[a b c a].SetHash makes the set a b c";
    is showset([a => 3, b => 0, 'c', 'a'].SetHash), 'a c', "[a => 3, b => 0, 'c', 'a'].SetHash makes the set a c";

    isa_ok {a => 2, b => 4, c => 0}.SetHash, SetHash, "{a => 2, b => 4, c => 0}.SetHash makes a SetHash";
    is showset({a => 2, b => 4, c => 0}.SetHash), 'a b', "{a => 2, b => 4, c => 0}.SetHash makes the set a b";
}

{
    my $s = SetHash.new();
    is $s:exists, True, ':exists with existing element';
    is $s:exists, False, ':exists with nonexistent element';
    is $s:delete, True, ':delete returns current value on set';
    is showset($s), 'b foo', '...and actually deletes';
}

{
    my %h := SetHash.new();
    is +%h.elems, 2, 'Inititalization worked';

    lives_ok { %h = False }, 'can set an item to False';
    is %h.elems, 1, '... and an item is gone';
    is ~%h.keys, 'a', '... and the right one is gone';

    %h++;
    is %h.keys.sort.join, 'ac', '++ on an item reinstates it';
    %h++;
    is %h.keys.sort.join, 'ac', '++ on an existing item does nothing';

    %h--;
    is ~%h.keys, 'c', '-- removes items';
    %h--;
    is ~%h.keys, 'c', '... but only if they were there from the beginning';

    # lives_ok { %h = set  }, 'Assigning a Set to a SetHash';
    # is %h.keys.sort.join, 'PQR', '... works as expected';
}

{
    my $s = SetHash.new();
    is showset($s), 'bar baz foo', 'SetHash.new discards duplicates';
}

{
    my $b = SetHash.new([ foo => 10, bar => 17, baz => 42 ]);
    isa_ok $b, SetHash, 'SetHash.new given an array of pairs produces a SetHash';
    is +$b, 1, '... with one element';
}

{
    my $b = SetHash.new({ foo => 10, bar => 17, baz => 42 }.hash);
    isa_ok $b, SetHash, 'SetHash.new given a Hash produces a SetHash';
    #?rakudo todo "Not up to current spec"
    is +$b, 3, '... with three elements';
    #?niecza todo "Non-string keys NYI"
    #?rakudo todo "Not up to current spec"
    is +$b.grep(Pair), 3, '... which are all Pairs';
}

{
    my $b = SetHash.new({ foo => 10, bar => 17, baz => 42 });
    isa_ok $b, SetHash, 'SetHash.new given a Hash produces a SetHash';
    is +$b, 1, '... with one element';
}

{
    my $b = SetHash.new(set );
    isa_ok $b, SetHash, 'SetHash.new given a Set produces a SetHash';
    is +$b, 1, '... with one element';
}

{
    my $b = SetHash.new(SetHash.new());
    isa_ok $b, SetHash, 'SetHash.new given a SetHash produces a SetHash';
    is +$b, 1, '... with one element';
}

{
    my $b = SetHash.new(BagHash.new());
    isa_ok $b, SetHash, 'SetHash.new given a BagHash produces a SetHash';
    is +$b, 1, '... with one element';
}

{
    my $b = SetHash.new(bag );
    isa_ok $b, SetHash, 'SetHash given a Bag produces a SetHash';
    is +$b, 1, '... with one element';
}

{
    my $s = SetHash.new();
    isa_ok $s.list.elems, 3, ".list returns 3 things";
    is $s.list.grep(Str).elems, 3, "... all of which are Str";
    #?rakudo skip 'no longer Iterable'
    is $s.iterator.grep(Str).elems, 3, ".iterator yields three Strs";
}

{
    my $s = SetHash.new();
    my $str;
    my $c;
    lives_ok { $str = $s.perl }, ".perl lives";
    isa_ok $str, Str, "... and produces a string";
    lives_ok { $c = eval $str }, ".perl.eval lives";
    isa_ok $c, SetHash, "... and produces a SetHash";
    is showset($c), showset($s), "... and it has the correct values";
}

{
    my $s = SetHash.new();
    lives_ok { $s = $s.Str }, ".Str lives";
    isa_ok $s, Str, "... and produces a string";
    is $s.split(" ").sort.join(" "), "bar baz foo", "... which only contains bar baz and foo separated by spaces";
}

{
    my $s = SetHash.new();
    lives_ok { $s = $s.gist }, ".gist lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s ~~ /foo/, "... which mentions foo";
    ok $s ~~ /bar/, "... which mentions bar";
    ok $s ~~ /baz/, "... which mentions baz";
}

# L may be bound to'>

{
    my %s := SetHash.new();
    isa_ok %s, SetHash, 'A SetHash bound to a %var is a SetHash';
    is showset(%s), 'a b c', '...with the right elements';

    is %s, True, 'Single-key subscript (existing element)';
    is %s, False, 'Single-key subscript (nonexistent element)';

    lives_ok { %s = True }, "Can assign to an element (SetHash are immutable)";
}

# L

{
    my $s = SetHash.new();

    my $a = $s.roll;
    ok $a eq "a" || $a eq "b" || $a eq "c", "We got one of the three choices";

    my @a = $s.roll(2);
    is +@a, 2, '.roll(2) returns the right number of items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 2, '.roll(2) returned "a"s, "b"s, and "c"s';

    @a = $s.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 100, '.roll(100) returned "a"s, "b"s, and "c"s';
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $s.total, 3, '.roll should not change the SetHash';
    is $s.elems, 3, '.roll should not change the SetHash';
}

# L

{
    my $s = SetHash.new();
    my @a = $s.pick: *;
    is @a.sort.join, 'abcdefgh', 'SetHash.pick(*) gets all elements';
    isnt @a.join, 'abcdefgh', 'SetHash.pick(*) returns elements in a random order';
      # There's only a 1/40_320 chance of that test failing by chance alone.
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $s.total, 8, '.pick should not change the SetHash';
    is $s.elems, 8, '.pick should not change the SetHash';
}

{
    my $s = SetHash.new();

    my $a = $s.pick;
    ok $a eq "a" || $a eq "b" || $a eq "c", "We got one of the three choices";

    my @a = $s.pick(2);
    is +@a, 2, '.pick(2) returns the right number of items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 2, '.pick(2) returned "a"s, "b"s, and "c"s';
    ok @a.grep(* eq 'a').elems <= 1, '.pick(2) returned at most one "a"';
    ok @a.grep(* eq 'b').elems <= 1, '.pick(2) returned at most one "b"';
    ok @a.grep(* eq 'c').elems <= 1, '.pick(2) returned at most one "c"';
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $s.total, 3, '.pick should not change the SetHash';
    is $s.elems, 3, '.pick should not change the SetHash';
}

# L

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $s = SetHash.new();
    my @a = $s.grab: *;
    is @a.sort.join, 'abcdefgh', 'SetHash.grab(*) gets all elements';
    isnt @a.join, 'abcdefgh', 'SetHash.grab(*) returns elements in a random order';
      # There's only a 1/40_320 chance of that test failing by chance alone.
    is $s.total, 0, '.grab *should* change the SetHash';
    is $s.elems, 0, '.grab *should* change the SetHash';
}

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $s = SetHash.new();

    my $a = $s.grab;
    ok $a eq "a" || $a eq "b" || $a eq "c", "We got one of the three choices";
    is $s.total, 2, '.grab *should* change the SetHash';
    is $s.elems, 2, '.grab *should* change the SetHash';

    my @a = $s.grab(2);
    is +@a, 2, '.grab(2) returns the right number of items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 2, '.grab(2) returned "a"s, "b"s, and "c"s';
    ok @a.grep(* eq 'a').elems <= 1, '.grab(2) returned at most one "a"';
    ok @a.grep(* eq 'b').elems <= 1, '.grab(2) returned at most one "b"';
    ok @a.grep(* eq 'c').elems <= 1, '.grab(2) returned at most one "c"';
    is $s.total, 0, '.grab *should* change the SetHash';
    is $s.elems, 0, '.grab *should* change the SetHash';
}

# L

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $s = SetHash.new();
    my @a = $s.grabpairs: *;
    is @a.grep( {.isa(Pair)} ).Num, 8, 'are they all Pairs';
    is @a.grep( {.value === True} ).Num, 8, 'and they all have a True value';
    is @a.sort.map({.key}).join, "abcdefgh", 'SetHash.grabpairs(*) gets all elements';
    isnt @a.map({.key}).join, "abcdefgh", 'SetHash.grabpairs(*) returns elements in a random order';
      # There's only a 1/40_320 chance of that test failing by chance alone.
    is $s.total, 0, '.grabpairs *should* change the SetHash';
    is $s.elems, 0, '.grabpairs *should* change the SetHash';
}

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $s = SetHash.new();

    my $a = $s.grabpairs[0];
    isa_ok $a, Pair, 'and is it a Pair';
    ok $a.key eq "a" || $a.key eq "b" || $a.key eq "c", "We got one of the three choices";
    is $s.total, 2, '.grabpairs *should* change the SetHash';
    is $s.elems, 2, '.grabpairs *should* change the SetHash';

    my @a = $s.grabpairs(2);
    is @a.grep( {.isa(Pair)} ).Num, 2, 'are they all Pairs';
    is +@a, 2, '.grabpairs(2) returns the right number of items';
    is @a.grep(*.key eq 'a' | 'b' | 'c').elems, 2, '.grabpairs(2) returned "a"s, "b"s, and "c"s';
    ok @a.grep(*.key eq 'a').elems <= 1, '.grabpairs(2) returned at most one "a"';
    ok @a.grep(*.key eq 'b').elems <= 1, '.grabpairs(2) returned at most one "b"';
    ok @a.grep(*.key eq 'c').elems <= 1, '.grabpairs(2) returned at most one "c"';
    is $s.total, 0, '.grabpairs *should* change the SetHash';
    is $s.elems, 0, '.grabpairs *should* change the SetHash';
}

#?rakudo skip "'is ObjectType' NYI"
#?niecza skip "is SetHash doesn't work yet"
{
    my %h is SetHash = a => True, b => False, c => True;
    #?rakudo todo 'todo'
    is +%h.elems, 2, 'Inititalization worked';

    lives_ok { %h = False }, 'can set an item to False';
    #?rakudo todo 'todo'
    is %h.elems, 1, '... and an item is gone';
    #?rakudo todo 'todo'
    is ~%h.keys, 'a', '... and the right one is gone';

    %h++;
    #?rakudo todo 'todo'
    is %h.keys.sort.join, 'ac', '++ on an item reinstates it';
    %h++;
    #?rakudo todo 'todo'
    is %h.keys.sort.join, 'ac', '++ on an existing item does nothing';

    %h--;
    #?rakudo todo 'todo'
    is ~%h.keys, 'c', '-- removes items';
    %h--;
    #?rakudo todo 'todo'
    is ~%h.keys, 'c', '... but only if they were there from the beginning';

    #?rakudo todo 'todo'
    lives_ok { %h = set  }, 'Assigning a Set to a SetHash';
    #?rakudo todo 'todo'
    is %h.keys.sort.join, 'PQR', '... works as expected';
}

{
    isa_ok 42.SetHash, SetHash, "Method .SetHash works on Int-1";
    is showset(42.SetHash), "42", "Method .SetHash works on Int-2";
    isa_ok "blue".SetHash, SetHash, "Method .SetHash works on Str-1";
    is showset("blue".SetHash), "blue", "Method .SetHash works on Str-2";
    my @a = ;
    isa_ok @a.SetHash, SetHash, "Method .SetHash works on Array-1";
    is showset(@a.SetHash), "Now Paradise cross-handed set the was way", "Method .SetHash works on Array-2";
    my %x = "a" => 1, "b" => 2;
    isa_ok %x.SetHash, SetHash, "Method .SetHash works on Hash-1";
    is showset(%x.SetHash), "a b", "Method .SetHash works on Hash-2";
    isa_ok (@a, %x).SetHash, SetHash, "Method .SetHash works on Parcel-1";
    is showset((@a, %x).SetHash), "Now Paradise a b cross-handed set the was way", "Method .SetHash works on Parcel-2";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/set.t0000664000175000017500000003052512225464703016500 0ustar  moritzmoritzuse v6;
use Test;

plan 151;

sub showset($s) { $s.keys.sort.join(' ') }

# L

{
    my $s = set ;
    isa_ok $s, Set, '&set produces a Set';
    is showset($s), 'a b foo', '...with the right elements';

    is $s.default, False, "Default value is false";
    is $s, True, 'Single-key subscript (existing element)';
    isa_ok $s, Bool, 'Single-key subscript has correct type (existing element)';
    is $s, False, 'Single-key subscript (nonexistent element)';
    isa_ok $s, Bool, 'Single-key subscript has correct type (nonexistent element)';
    is $s:exists, True, 'exists with existing element';
    is $s:exists, False, 'exists with nonexistent element';

    ok ?$s, "Bool returns True if there is something in the Set";
    nok ?Set.new(), "Bool returns False if there is nothing in the Set";

    my $hash;
    lives_ok { $hash = $s.hash }, ".hash doesn't die";
    isa_ok $hash, Hash, "...and it returned a Hash";
    is showset($hash), 'a b foo', '...with the right elements';
    is $hash.values.grep({ ($_ ~~ Bool) && $_ }).elems, 3, "...and values";

    dies_ok { $s = True }, "Can't assign to an element (Sets are immutable)";
    dies_ok { $s.keys =  }, "Can't assign to .keys";
    dies_ok { $s.values =  }, "Can't assign to .values";
    dies_ok { $s:delete }, "Can't :delete from Set";
    dies_ok { $s.delete_key("a") }, "Can't .delete_key from Set";

    is ($s).grep(?*).elems, 2, 'Multiple-element access';
    is ($s).grep(?*).elems, 2, 'Multiple-element access (with nonexistent elements)';

    is $s.elems, 3, '.elems gives number of keys';
    is +$s, 3, '+$set gives number of keys';
}

{
    ok (set ) ~~ (set ), "Identical sets smartmatch with each other";
    nok (set ) ~~ (set ), "Subset does not smartmatch";
    nok (set ) ~~ (set ), "Superset does not smartmatch";
    nok "a" ~~ (set ), "Smartmatch is not element of";
    ok (set ) ~~ Set, "Type-checking smartmatch works";

    ok (bag ) ~~ (set ), "Bag smartmatches with equivalent set";
    ok (bag ) ~~ (set ), "... even if the Bag has greater quantities";
    nok (bag ) ~~ (set ), "Subset does not smartmatch";
    nok (bag ) ~~ (set ), "Superset does not smartmatch";
    nok (bag ) ~~ Set, "Type-checking smartmatch works";
}

{
    isa_ok "a".Set, Set, "Str.Set makes a Set";
    is showset("a".Set), 'a', "'a'.Set is set a";

    isa_ok (a => 1).Set, Set, "Pair.Set makes a Set";
    is showset((a => 1).Set), 'a', "(a => 1).Set is set a";
    is showset((a => 0).Set), '', "(a => 0).Set is the empty set";

    isa_ok .Set, Set, ".Set makes a Set";
    is showset(.Set), 'a b c', ".Set makes the set a b c";
    is showset(["a", "b", "c", "a"].Set), 'a b c', "[a b c a].Set makes the set a b c";
    is showset([a => 3, b => 0, 'c', 'a'].Set), 'a c', "[a => 3, b => 0, 'c', 'a'].Set makes the set a c";

    isa_ok {a => 2, b => 4, c => 0}.Set, Set, "{a => 2, b => 4, c => 0}.Set makes a Set";
    is showset({a => 2, b => 4, c => 0}.Set), 'a b', "{a => 2, b => 4, c => 0}.Set makes the set a b";
}

{
    my $s = set ;
    is $s:exists, True, ':exists with existing element';
    is $s:exists, False, ':exists with nonexistent element';
    dies_ok { $s:delete }, ':delete does not work on set';
    dies_ok { $s.delete_key() }, '.delete_key does not work on set';
}

{
    my $s = set 2, 'a', False;
    my @ks = $s.keys;
    #?niecza 3 todo
    is @ks.grep(Int)[0], 2, 'Int keys are left as Ints';
    is @ks.grep(* eqv False).elems, 1, 'Bool keys are left as Bools';
    is @ks.grep(Str)[0], 'a', 'And Str keys are permitted in the same set';
    is +$s, 3, 'Keys are counted correctly even when a key is False';
}

# RT #77760
#?rakudo skip "Odd number of elements"
#?niecza skip "Unmatched key in Hash.LISTSTORE"
{
    my %h = set ;
    ok %h ~~ Hash, 'A hash to which a Set has been assigned remains a hash';
    is %h.keys.sort.join, 'abop', '...with the right keys';
    is %h.values, (True, True, True, True), '...and values all True';
}
{
    my %h := set ;
    ok %h ~~ Set, 'A hash to which a Set has been bound becomes a set';
    is %h.keys.sort.join, 'abop', '...with the right keys';
    is %h.values, (True xx 4), '...and values all True';
}

{
    my $s = set ;
    is showset($s), 'bar baz foo', '&set discards duplicates';
}

{
    my $b = set [ foo => 10, bar => 17, baz => 42 ];
    isa_ok $b, Set, '&Set.new given an array of pairs produces a Set';
    is +$b, 1, "... with one element";
}

{
    # {}.hash interpolates in list context
    my $b = set { foo => 10, bar => 17, baz => 42 }.hash;
    isa_ok $b, Set, '&Set.new given a Hash produces a Set';
    #?rakudo todo "Not properly interpolating"
    is +$b, 3, "... with three elements";
    #?rakudo todo "Not properly interpolating"
    #?niecza todo "Losing type in Set"
    is +$b.grep(Pair), 3, "... all of which are Pairs";
}

{
    # plain {} does not interpolate in list context
    my $b = set { foo => 10, bar => 17, baz => 42 };
    isa_ok $b, Set, '&Set.new given a Hash produces a Set';
    is +$b, 1, "... with one element";
}

{
    my $b = set set ;
    isa_ok $b, Set, '&Set.new given a Set produces a Set';
    is +$b, 1, "... with one element";
}

#?niecza skip 'SetHash'
{
    my $b = set SetHash.new();
    isa_ok $b, Set, '&Set.new given a SetHash produces a Set';
    is +$b, 1, "... with one element";
}

#?niecza skip 'BagHash'
{
    my $b = set BagHash.new();
    isa_ok $b, Set, '&Set.new given a SetHash produces a Set';
    is +$b, 1, "... with one element";
}

{
    my $b = set bag ;
    isa_ok $b, Set, '&set given a Bag produces a Set';
    is +$b, 1, "... with one element";
}

{
    my $s = set ;
    isa_ok $s.list.elems, 3, ".list returns 3 things";
    is $s.list.grep(Str).elems, 3, "... all of which are Str";
    isa_ok $s.pairs.elems, 3, ".pairs returns 3 things";
    is $s.pairs.grep(Pair).elems, 3, "... all of which are Pair";
    #?niecza 2 todo
    is $s.pairs.grep({ .key ~~ Str }).elems, 3, "... the keys of which are Strs";
    is $s.pairs.grep({ .value ~~ Bool }).elems, 3, "... and the values of which are Bool";
    #?rakudo skip "Set is no longer Iterable"
    is $s.iterator.grep(Str).elems, 3, ".iterator yields three Strs";
}

{
    my $s = set ;
    my $str;
    my $c;
    lives_ok { $str = $s.perl }, ".perl lives";
    isa_ok $str, Str, "... and produces a string";
    lives_ok { $c = eval $str }, ".perl.eval lives";
    isa_ok $c, Set, "... and produces a Set";
    is showset($c), showset($s), "... and it has the correct values";
}

{
    my $s = set ;
    lives_ok { $s = $s.Str }, ".Str lives";
    isa_ok $s, Str, "... and produces a string";
    is $s.split(" ").sort.join(" "), "bar baz foo", "... which only contains bar baz and foo separated by spaces";
}

{
    my $s = set ;
    lives_ok { $s = $s.gist }, ".gist lives";
    isa_ok $s, Str, "... and produces a string";
    ok $s ~~ /foo/, "... which mentions foo";
    ok $s ~~ /bar/, "... which mentions bar";
    ok $s ~~ /baz/, "... which mentions baz";
}

# L may be bound to'>

{
    my %s := set ;
    isa_ok %s, Set, 'A Set bound to a %var is a Set';
    is showset(%s), 'a b c', '...with the right elements';

    is %s, True, 'Single-key subscript (existing element)';
    is %s, False, 'Single-key subscript (nonexistent element)';

    dies_ok { %s = True }, "Can't assign to an element (Sets are immutable)";
    dies_ok { %s = a => True, b => True }, "Can't assign to a %var implemented by Set";
    dies_ok { %s:delete }, "Can't :delete a key from a Set";
    dies_ok { %s.delete_key("a") }, "Can't .delete_key a key from a Set";
}

# L
#?niecza skip "Hypers not yet Set compatible"
#?rakudo todo "Hypers not yet Set compatible"
{
    is showset(set(1, 2, 3) »+» 6), '7 8 9', 'Set »+» Int';
    is showset("a" «~« set()), 'abbot apple armadillo', 'Str «~« Set';
    is showset(-« set(3, 9, -4)), '-9 -3 4', '-« Set';
    is showset(set()».pred), 'a d f j y', 'Set».pred';

    dies_ok { set(1, 2) »+« set(3, 4) }, 'Set »+« Set is illegal';
    dies_ok { set(1, 2) «+» set(3, 4) }, 'Set «+» Set is illegal';
    dies_ok { set(1, 2) »+« [3, 4] }, 'Set »+« Array is illegal';
    dies_ok { set(1, 2) «+» [3, 4] }, 'Set «+» Array is illegal';
    dies_ok { [1, 2] »+« set(3, 4) }, 'Set »+« Array is illegal';
    dies_ok { [1, 2] «+» set(3, 4) }, 'Set «+» Array is illegal';
}

# L

{
    my $s = set ;

    my $a = $s.roll;
    ok $a eq "a" || $a eq "b" || $a eq "c", "We got one of the three choices";

    my @a = $s.roll(2);
    is +@a, 2, '.roll(2) returns the right number of items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 2, '.roll(2) returned "a"s, "b"s, and "c"s';

    @a = $s.roll: 100;
    is +@a, 100, '.roll(100) returns 100 items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 100, '.roll(100) returned "a"s, "b"s, and "c"s';
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $s.total, 3, '.roll should not change Set';
}

# L

{
    my $s = set ;
    my @a = $s.pick: *;
    is @a.sort.join, 'abcdefgh', 'Set.pick(*) gets all elements';
    isnt @a.join, 'abcdefgh', 'Set.pick(*) returns elements in a random order';
      # There's only a 1/40_320 chance of that test failing by chance alone.
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $s.total, 8, '.pick should not change Set';
}

{
    my $s = set ;

    my $a = $s.pick;
    ok $a eq "a" || $a eq "b" || $a eq "c", "We got one of the three choices";

    my @a = $s.pick(2);
    is +@a, 2, '.pick(2) returns the right number of items';
    is @a.grep(* eq 'a' | 'b' | 'c').elems, 2, '.pick(2) returned "a"s, "b"s, and "c"s';
    ok @a.grep(* eq 'a').elems <= 1, '.pick(2) returned at most one "a"';
    ok @a.grep(* eq 'b').elems <= 1, '.pick(2) returned at most one "b"';
    ok @a.grep(* eq 'c').elems <= 1, '.pick(2) returned at most one "c"';
    #?pugs   skip '.total NYI'
    #?niecza skip '.total NYI'
    is $s.total, 3, '.pick should not change Set';
}

# L

#?pugs   skip '.grab NYI'
#?niecza skip '.grab NYI'
{
    my $s = set ;
    dies_ok { $s.grab }, 'cannot call .grab on a Set';
}

# L

#?pugs   skip '.grabpairs NYI'
#?niecza skip '.grabpairs NYI'
{
    my $s = set ;
    dies_ok { $s.grabpairs }, 'cannot call .grabpairs on a Set';
}

# RT 107022
{
    my $s1 = set ( set  ), ;
    is +$s1, 3, "Three elements";
    ok $s1, "One of them is 'c'";
    ok $s1, "One of them is 'd'";
    my $inner-set = $s1.list.first(Set);
    #?niecza 2 todo 'Set in Set does not work correctly yet'
    isa_ok $inner-set, Set, "One of the set's elements is indeed a set!";
    is showset($inner-set), "a b c", "With the proper elements";

    my $s = set ;
    $s1 = set $s, ;
    is +$s1, 3, "Three elements";
    ok $s1, "One of them is 'c'";
    ok $s1, "One of them is 'd'";
    $inner-set = $s1.list.first(Set);
    #?niecza 2 todo 'Set in Set does not work correctly yet'
    isa_ok $inner-set, Set, "One of the set's elements is indeed a set!";
    is showset($inner-set), "a b c", "With the proper elements";
}

{
    isa_ok 42.Set, Set, "Method .Set works on Int-1";
    is showset(42.Set), "42", "Method .Set works on Int-2";
    isa_ok "blue".Set, Set, "Method .Set works on Str-1";
    is showset("blue".Set), "blue", "Method .Set works on Str-2";
    my @a = ;
    isa_ok @a.Set, Set, "Method .Set works on Array-1";
    is showset(@a.Set), "Now Paradise cross-handed set the was way", "Method .Set works on Array-2";
    my %x = "a" => 1, "b" => 2;
    isa_ok %x.Set, Set, "Method .Set works on Hash-1";
    is showset(%x.Set), "a b", "Method .Set works on Hash-2";
    isa_ok (@a, %x).Set, Set, "Method .Set works on Parcel-1";
    is showset((@a, %x).Set), "Now Paradise a b cross-handed set the was way", "Method .Set works on Parcel-2";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/sigils-and-types.t0000664000175000017500000000500412224265625021074 0ustar  moritzmoritzuse v6;

use Test;

plan 28;

my $scalar;
ok $scalar.WHAT === Any, 'unitialized $var does Mu';
$scalar = 1;
ok $scalar ~~ Any, 'value contained in a $var does Mu';



{
    my @array;
    ok @array.does(Positional), 'unitialized @var does Positional';
}
{
    my @array = [];
    ok @array.does(Positional), 'value contained in a @var does Positional';
}
{
    my @array = 1;
    ok @array.does(Positional), 'generic val in a @var is converted to Positional';
}

ok eval('List').does(Positional), "List does Positional";
ok eval('Array').does(Positional), "Array does Positional";
ok eval('Range').does(Positional), "Range does Positional";
ok eval('Parcel').does(Positional), "Parcel does Positional";
#?niecza skip 'Undeclared name Buf'
ok eval('Buf').does(Positional), "Buf does Positional";
#?rakudo todo "Capture does Positional"
ok eval('Capture').does(Positional), "Capture does Positional";

my %hash;
#?pugs todo 'feature'
ok %hash.does(Associative), 'uninitialized %var does Associative';
%hash = {};
ok %hash.does(Associative), 'value in %var does Associative';

#?niecza todo
ok eval('Pair').does(Associative), "Pair does Associative";
ok eval('Set').does(Associative), "Set does Associative";
ok eval('Bag').does(Associative), "Bag does Associative";
#?niecza skip 'Undeclared name QuantHash'
ok eval('QuantHash').does(Associative), "QuantHash does Associative";
#?rakudo todo "Capture does Associative"
ok eval('Capture').does(Associative), "Capture does Associative";


sub foo {}
ok &foo.does(Callable), 'a Sub does Callable';

#?niecza skip 'Methods must be used in some kind of package'
{
    my method meth {}
    ok &meth.does(Callable), 'a Method does Callable';
}
proto mul(|) {*}
multi mul {}
ok &mul.does(Callable), 'a multi does Callable';
proto pro {}
ok &pro.does(Callable), 'a proto does Callable';

# &token, &rule return a Method?
#?niecza skip 'Methods must be used in some kind of package'
{
    my token bar {}
    #?pugs todo 'feature'
    ok &bar.does(Callable), 'a token does Callable';
    my rule baz {}
    #?pugs todo 'feature'
    ok &baz.does(Callable), 'a rule does Callable';
    # &quux returns a Sub ?
    macro quux {}
    #?pugs todo 'feature'
    ok &quux.does(Callable), 'a macro does Callable';
}

# RT 69318
{
    sub a { return 'a' };
    sub b { return 'b' };
    dies_ok { &a = &b }, 'cannot just assign &b to &a';
    is a(), 'a', 'and the correct function is still in place';

}

# RT #74654
{
    sub f() { '42' };
    my $x = &f;
    is &$x(), '42', 'can use &$x() for invoking';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/subscripts_and_context.t0000664000175000017500000000331712224265625022474 0ustar  moritzmoritzuse v6;

use Test;

plan 8;

# "The context inside of hash and array scripts seems to be/is wrong"

# L
{
  sub return_01 { my @sub_array = ("0", "1"); return @sub_array }

  my @array  = ;
  my @sliced = @array[return_01()];
  # @sliced *should* be , but it is .
  # This is because return_012() is called in numeric context, and so return_012
  # returns the *number* of elems in @sub_array instead of the array @sub_array.
  is ~@sliced, "a b", "context inside of array subscripts for slices";
}

# Same for hashes.
{
  sub return_ab { my @sub_array = ; return @sub_array }

  my %hash   = (a => 1, b => 2, c => 3);
  my @sliced = %hash{return_ab()};
  # @sliced *should* be ("1, "2").
  # The above for bug explanation.
  is ~@sliced, "1 2", "context inside of hash subscripts for slices";
}

# This time we return a single value.
{
  sub return_3 { 3   }
  sub return_c { "c" }

  my @array = ;
  my %hash  = (c => 12);

  is ~@array[return_3()], "d",
    "context inside of array subscripts in normal rvalue context";
  is ~%hash{return_c()},   12,
    "context inside of hash subscripts in normal rvalue context";

  @array[return_3()] = "Z";
  %hash{return_c()}  = 23;

  is @array[3], "Z", "context inside of array subscripts in lvalue context";
  is %hash,   23, "context inside of hash subscripts in lvalue context";

  @array[3] = 15;
  @array[return_3()]++;
  %hash{return_c()}++;

  is @array[3],  16, 'context inside of array subscripts when used with &postfix:<++>';
  is %hash,   24, 'context inside of hash subscripts when used with &postfix:<++>';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/subset.t0000664000175000017500000001344712224265625017217 0ustar  moritzmoritzuse v6;
use Test;
plan 43;

=begin description

Test for 'subset' with a closure

=end description

# L

subset Even of Int where { $_ % 2 == 0 };

{
    my Even $x = 2;
    is $x, 2, 'Can assign value to a type variable with subset';
};

#?pugs todo
dies_ok { eval('my Even $x = 3') },
              "Can't assign value that violates type constraint via subset";

# RT # 69518'
#?niecza todo
#?pugs todo
dies_ok { eval('Even.new') }, 'Cannot instantiate a subtype';

#?pugs skip "can't find Even"
{
    ok 2 ~~ Even,  'Can smartmatch against subsets 1';
    ok 3 !~~ Even, 'Can smartmatch against subsets 2';
}

# L

#?pugs emit #
subset Digit of Int where ^10;

{
    my Digit $x = 3;
    is  $x,     3,  "Can assign to var with 'subset' type constraint";
    $x = 0;
    is  $x,     0,  "one end of range";
    $x = 9;
    is  $x,     9,  "other end of range";
}

#?pugs 3 todo
dies_ok { my Digit $x = 10 },
             'type constraints prevents assignment 1';
dies_ok { my Digit $x = -1 },
        'type constraints prevents assignment 2';
dies_ok { my Digit $x = 3.1 },
             'original type prevents assignment';

# RT #67818
{
    subset Subhash of Hash;
    lives_ok { my Subhash $a = {} },
             'can create subset of hash';

    subset Person of Hash where { .keys.sort ~~  }
    lives_ok { my Person $p = { :firstname, :lastname } },
             'can create subset of hash with where';
    #?pugs todo
    dies_ok { my Person $p = { :first, :last } },
            'subset of hash with where enforces where clause';

    subset Austria of Array;
    lives_ok { my Austria $a = [] },
             'can create subset of array';

    subset NumArray of Array where { .elems == .grep: { $_ ~~ Num } }
    lives_ok { my NumArray $n = [] },
             'can create subset of array with where';
    #?rakudo skip '(noauto) succeeds for the wrong reason (need to test the error)'
    #?pugs todo
    dies_ok { my NumArray $n =  },
            'subset of array with where enforces where clause';

    subset Meercat of Pair;
    lives_ok { my Meercat $p = :a },
             'can create subset of pair';

    subset Ordered of Pair where { .key < .value }
    lives_ok { my Ordered $o = 23 => 42 },
             'can create subset of Pair with where';
    #?pugs todo
    dies_ok { my Ordered $o = 42 => 23 },
            'subset of pair with where enforces where clause';
}

{
    my subset Str_not2b of Str where /^[isnt|arent|amnot|aint]$/;
    my Str_not2b $text;
    $text = 'amnot';
    is $text, 'amnot', 'assignment to my subset of Str where pattern worked';
    #?pugs todo
    dies_ok { $text = 'oops' },
            'my subset of Str where pattern enforces pattern';
}

{
    subset Negation of Str where /^[isnt|arent|amnot|aint]$/;
    my Negation $text;
    $text = 'amnot';
    is $text, 'amnot', 'assignment to subset of Str where pattern worked';
    #?pugs todo
    dies_ok { $text = 'oops' }, 'subset of Str where pattern enforces pattern';
}

# RT #67256
#?niecza skip "Exception NYI"
#?pugs skip   "Exception NYI"
{
    subset RT67256 of Int where { $^i > 0 }
    my RT67256 $rt67256;

    try { $rt67256 = -42 }

    ok  $!  ~~ Exception, 'subset of Int enforces where clause';
    ok "$!" ~~ / RT67256 /, 'error for bad assignment mentions subset';
}

# RT #69334
#?pugs skip "Can't find SY"
{
    class Y {has $.z};
    subset sY of Y where {.z == 0};

    lives_ok { 4 ~~ sY }, 'Nominal type is checked first';
    ok 4 !~~ sY, 'and if nominal type check fails, it is False';
}

# RT #74234
#?niecza todo
{
    eval_lives_ok 'subset A of Mu; my A $x = 23;',
        'subset A of Mu + type check and assignment works';
}

# RT #77356
#?pugs skip "Can't find aboveLexLimit"
{
    sub limit() { 0 }
    subset aboveLexLimit of Int where { $_ > limit() };
    ok 1 ~~ aboveLexLimit, 'can use subset that depends on lexical sub (1)';
    nok -1 ~~ aboveLexLimit, 'can use subset that depends on lexical sub (2)';
}

# RT # 77356
#?pugs skip "Can't find aboveLexVarLimit"
{
    my $limit = 0;
    subset aboveLexVarLimit of Int where { $_ > $limit };
    ok 1 ~~ aboveLexVarLimit, 'can use subset that depends on lexical variable (1)';
    nok -1 ~~ aboveLexVarLimit, 'can use subset that depends on lexical variable (2)';
}

#?pugs emit #
subset Bug::RT80930 of Int where { $_ %% 2 };
lives_ok { my Bug::RT80930 $rt80930 }, 'subset with "::" in the name';

# RT #95500
#?pugs skip "Can't find SomeStr"
{
    subset SomeStr of Str where any ;
     ok 'foo' ~~ SomeStr, 'subset ... where any(...) (+)';
    nok 'fox' ~~ SomeStr, 'subset ... where any(...) (-)';
}


# RT #65308
#?niecza skip 'Methods must be used in some kind of package'
#?pugs todo
{
    subset FooStr of Str where /^foo/;
    my multi method uc(FooStr $self:) { return "OH HAI" }; #OK not used
    is "foo".uc, 'FOO', 'multi method with subset invocants do not magically find their way into the method dispatch';

}

# RT #73344
my $a = 1;
#?pugs skip 'where'
{
    my $a = 3;
    sub producer {
        my $a = 2;
        sub bar($x where $a ) { $x }  #OK not used
    }
    my &bar := producer();
    lives_ok { bar(2) }, 'where-constraint picks up the right lexical (+)';
    dies_ok  { bar(1) }, 'where-constraint picks up the right lexical (-)';
}

#?pugs skip 'MI not found'
{
    #RT #113434
    my subset MI of Int;
    ok MI ~~ Mu,   'subset conforms to Mu';
    ok MI ~~ Int,  'subset conforms to base type';
    nok Mu  ~~ MI, 'Mu does not conform to subset';
}

# RT #74352
#?pugs skip 'parsefail'
{
    subset A of Array;
    subset B of A;
    subset C of A;
    subset D of A where B & C;
    ok [] ~~ D, "complicated subset combinations #74352";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/type.t0000664000175000017500000001313112224265625016661 0ustar  moritzmoritzuse v6;
use Test;

=begin description

Basic tests about variables having built-in types assigned

=end description

# L

plan 50;

{
    ok(try {my Int $foo; 1}, 'compile my Int $foo');
    ok(try {my Str $bar; 1}, 'compile my Str $bar');
}

ok(do {my Int $foo; $foo ~~ Int}, 'Int $foo isa Int');
ok(do {my Str $bar; $bar ~~ Str}, 'Str $bar isa Str');

my Int $foo;
my Str $bar;

{
    #?pugs 1 todo
    dies_ok({$foo = 'xyz'},      'Int restricts to integers');
    #?pugs todo
    dies_ok { $foo = Mu },       'Int does not accept Mu';
    is(($foo = 42),       42,    'Int is an integer');

    #?pugs 1 todo
    dies_ok({$bar = 42},         'Str restricts to strings');
    #?pugs todo
    dies_ok { $bar = Mu },       'Str does not accept Mu';
    is(($bar = 'xyz'),    'xyz', 'Str is a strings');
}

#?niecza skip 'Trait of not available on variables'
#?pugs skip 'parsefail'
{
    my $baz of Int;
    dies_ok({$baz = 'xyz'},      'of Int restricts to integers');
    is(($baz = 42),       42,    'of Int is an integer');
}

# L
#?niecza skip 'native types (noauto)'
{
    eval_lives_ok('my int $alpha = 1',    'Has native type int');
    eval_dies_ok('my int $alpha = Nil', 'native int type cannot be undefined');
    #?pugs todo
    lives_ok({my Int $beta = Nil},      'object Int type can be undefined');
    eval_lives_ok('my num $alpha = 1e0',    'Has native type num');
    #?pugs 2 todo
    #?rakudo.jvm todo "nigh"
    eval_lives_ok('my num $alpha = Nil', 'native num type can be undefined');
    lives_ok({my Num $beta = Nil},      'object Num type can be undefined');
}

# L
{
    sub paramtype (Int $i) {return $i+1}
    is(paramtype(5), 6, 'sub parameters with matching type');
    eval_dies_ok('paramtype("foo")', 'sub parameters with non-matching type dies');
}

{
    # test contributed by Ovid++
    sub fact (Int $n) {
        if 0 == $n {
            1;
        }
        else {
            $n * fact($n - 1);
        }
    }
    is fact(5), 120, 'recursive factorial with type contstraints work';
}

# Num does not accept Int (used to, then spec changed)
#?pugs todo
dies_ok { my Num $n; $n = 42; }, 'Num does not accept Int';

# L
#?pugs skip 'parsefail'
{
    # Check with explicit return.
    my sub returntype1 (Bool $pass) returns Str { return $pass ?? 'ok' !! -1}
    my sub returntype2 (Bool $pass) of Int { return $pass ?? 42 !! 'no'}
    my Bool sub returntype3 (Bool $pass)   { return $pass ?? Bool::True !! ':('}
    my sub returntype4 (Bool $pass --> Str) { return $pass ?? 'ok' !! -1}

    is(returntype1(Bool::True), 'ok', 'good return value works (returns)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype1(Bool::False) }, 'bad return value dies (returns)');
    is(returntype2(Bool::True), 42, 'good return value works (of)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype2(Bool::False) }, 'bad return value dies (of)');

    is(returntype3(Bool::True), True, 'good return value works (my Type sub)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype3(Bool::False) }, 'bad return value dies (my Type sub)');

    is(returntype4(Bool::True), 'ok', 'good return value works (-->)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype4(Bool::False) }, 'bad return value dies (-->)');
}

#?pugs skip 'parsefail'
{
    # Check with implicit return.
    my sub returntype1 (Bool $pass) returns Str { $pass ?? 'ok' !! -1}
    my sub returntype2 (Bool $pass) of Int { $pass ?? 42 !! 'no'}
    my Bool sub returntype3 (Bool $pass)   { $pass ?? Bool::True !! ':('}
    my sub returntype4 (Bool $pass --> Str) { $pass ?? 'ok' !! -1}

    is(returntype1(Bool::True), 'ok', 'good implicit return value works (returns)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype1(Bool::False) }, 'bad implicit return value dies (returns)');
    is(returntype2(Bool::True), 42, 'good implicit return value works (of)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype2(Bool::False) }, 'bad implicit return value dies (of)');

    is(returntype3(Bool::True), True, 'good implicit return value works (my Type sub)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype3(Bool::False) }, 'bad implicit return value dies (my Type sub)');

    is(returntype4(Bool::True), 'ok', 'good implicit return value works (-->)');
    #?niecza todo 'retrun value type checking NYI'
    dies_ok({ returntype4(Bool::False) }, 'bad implicit return value dies (-->)');
}

{
    eval_dies_ok('my Int Str $x', 'multiple prefix constraints not allowed');
    eval_dies_ok('sub foo(Int Str $x) { }', 'multiple prefix constraints not allowed');
    eval_dies_ok('sub foo(--> Int Str) { }', 'multiple prefix constraints not allowed');
    eval_dies_ok('our Int Str sub foo() { }', 'multiple prefix constraints not allowed');
}

{
    # TODO: many more of these are possible
    ok Any ~~ Mu, 'Any ~~ Mu';
    ok Mu !~~ Any, 'Mu !~~ Any';
    ok Mu !~~ Int, 'Mu !~~ Int';

    #?pugs 2 skip "Numeric"
    ok Int ~~ Numeric, 'Int !~~ Numeric';
    ok Numeric !~~ Int, 'Numeric !~~ Int';

    ok Array ~~ List, 'Array is a kind of List';
    ok List !~~ Array, 'A List is not an Array';
    #?pugs skip "Positional"
    ok Array ~~ Positional, 'Array does Positional too';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/undefined-types.t0000664000175000017500000000763412224265625021016 0ustar  moritzmoritzuse v6;
use Test;
plan 49;

# L

# Nil is an empty container. As a container, it is defined.
{
    ok !Nil.defined, 'Nil is undefined';
    ok ().defined, '() is defined';
    my @a= 1, Nil, 3;
    is @a.elems, 2, 'Nil as part of list, is empty list';
    ok (@a.push: Nil) =:= @a, "Pushing Nil returns same array";
    is @a.elems, 2, 'Pushing Nil in list context is empty list';
    ok (@a.unshift: Nil) =:= @a, "Unshifting Nil returns same array";
    is @a.elems, 2, 'Unshifting Nil in list context is empty list';
    is (@a = Nil), Nil, "Setting to Nil returns Nil";
    is @a.elems, 0, 'Setting to Nil restores original state';
} #7

# typed scalar
#?pugs   skip "doesn't know typed stuff"
#?niecza skip "doesn't know typed stuff"
{
    my Int $a = 1;
    is ($a = Nil), Nil, "assigning Nil to Int should work";
    ok !$a.defined,  "Nil makes undefined here";
} #2

# typed array
#?pugs   skip "doesn't know typed stuff"
#?niecza skip "doesn't know typed stuff"
{
    my Int @a = 1, Nil, 3;
    #?rakudo todo ".clone doesn't copy typedness"
    is @a.of, '(Int)', "Check that we have an 'Int' array";
    is @a.elems, 2,  'Nil as part of Int list, is empty list';
    ok ( @a.push: Nil ) =:= @a, "assigning Nil returns same array";
    is @a.elems, 2, 'Pushing Nil in Int list context is empty list';
    ok ( @a.unshift: Nil ) =:= @a, "assigning Nil returns same array";
    is @a.elems, 2, 'Unshifting Nil in Int list context is empty list';
    ok !defined(@a[1] = Nil), "assigning Nil to Int should work";
    ok !@a[1].defined,  "Nil makes undefined here";
    is ( @a = Nil ), Nil, "setting to Nil returns Nil";
    #?rakudo todo ".clone doesn't copy typedness"
    is @a.of, '(Int)', "Check that we still have an 'Int' array";
    is @a.elems, 0, 'Setting to Nil restores original state';
} #11

# typed hash
#?pugs   skip "doesn't know typed stuff"
#?niecza skip "doesn't know typed stuff"
{
    my Int %a = a => 1, Nil, c => 3;
    #?rakudo todo ".clone doesn't copy typedness"
    is %a.of, '(Int)', "Check that we have an 'Int' hash";
    is %a.elems, 2,  'Nil as part of Int list, is empty pair';
    is ( %a = Nil ), Nil, "assigning Nil to hash element should work";
    ok !%a.defined,  "Nil makes undefined here";
    is ( %a = Nil ), Nil, "setting to Nil returns Nil";
    #?rakudo todo ".clone doesn't copy typedness"
    is %a.of, '(Int)', "Check that we still have an 'Int' hash";
    is %a.elems, 0, 'Setting to Nil restores original state';
} #7

# sink context returns Nil
{
    my @a;
    my $i = 0;
    @a.push: 1, sink $i++;
    is @a.elems, 1, 'sink statement prefix returns Nil (list context)';
    is $i, 1, 'sink execucted the statement';

    @a = ();
    @a.push: 2, sink { $i = 2 };
    is @a.elems, 1, 'sink block prefix returns Nil (list context)';
    is $i, 2, 'the block was executed';
    ok !defined(sink $i = 5 ), 'sink in scalar context (statement)';
    is $i, 5, '... statement executed';
    ok !defined(sink {$i = 8} ), 'sink in scalar context (block)';
    is $i, 8, '... block executed';
} #8

# undefined objects
{
    my $obj;
    my Int $int;

    is ~$obj, '', 'prefix:<~> on type object gives empty string (Any)';
    is ~$int, '', 'prefix:<~> on type object gives empty string (Int)';
    is $obj.Stringy, '', '.Stringy on type object gives empty string (Any)';
    is $int.Stringy, '', '.Stringy on type object gives empty string (Int)';

    ok (~$obj) ~~ Stringy, 'prefix:<~> returns a Stringy (Any)';
    ok (~$int) ~~ Stringy, 'prefix:<~> returns a Stringy (Int)';

    ok $obj.Stringy ~~ Stringy, '.Stringy returns a Stringy (Any)';
    ok $int.Stringy ~~ Stringy, '.Stringy returns a Stringy (Int)';

    is $obj.gist, '(Any)', '.gist on type object gives (Any)';
    is $int.gist, '(Int)', '.gist on type object gives (Int)';

    is 'a' ~ $obj, 'a', 'infix:<~> uses coercion to Stringy (Any)';
    is 'a' ~ $int, 'a', 'infix:<~> uses coercion to Stringy (Int)';
} #12

# vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/unicode.t0000664000175000017500000000377612224265625017344 0ustar  moritzmoritzuse v6;

use Test;
plan 16;

#L

# LATIN CAPITAL LETTER A, COMBINING GRAVE ACCENT
my Str $u = "\x[0041,0300]";
is $u.codes, 2, 'combining À is two codes';
is $u.graphs, 1, 'combining À is one graph';
is "foo\r\nbar".codes, 8, 'CRLF is 2 codes';
is "foo\r\nbar".graphs, 7, 'CRLF is 1 graph';

# Speculation, .chars is unspecced, also use Bytes etc.
is $u.chars, 1, '.chars defaults to .graphs';

# RT #65170
#?pugs todo
{
    my $rt65170;

    $rt65170 = "\c[LATIN CAPITAL LETTER A WITH DOT ABOVE, COMBINING DOT BELOW]";
    is $rt65170.chars, 1, '.chars defaults to .graphs (2)';
    $rt65170 = "\c[LATIN CAPITAL LETTER A, COMBINING DOT ABOVE, COMBINING DOT BELOW]";
    is $rt65170.chars, 1, '.chars defaults to .graphs (3)';
}

#L
    $u = "\x[41,
            E1,
            41, 0300,
            41, 0302, 0323,
            E0]";

#?pugs 9 todo ''
is eval('substr $u, 3.as(Bytes),  1.as(Bytes)'),  "\x[41]",             'substr with Bytes as units - utf8';
is eval('substr $u, 3.as(Codes),  1.as(Codes)'),  "\x[0300]",           'substr with Codes as units - utf8';
is eval('substr $u, 4.as(Graphs), 1.as(Graphs)'), "\x[E0]",             'substr with Graphs as units - utf8';
is eval('substr $u, 3.as(Graphs), 1.as(Codes)'),  "\x[41]",             'substr with Graphs and Codes as units 1 - utf8';
is eval('substr $u, 4.as(Codes),  1.as(Graphs)'), "\x[41, 0302, 0323]", 'substr with Graphs and Codes as units 2 - utf8';
is eval('substr $u, 4.as(Bytes),  1.as(Codes)'),  "\x[0300]",           'substr with Bytes and Codes as units 1 - utf8';
is eval('substr $u, 1.as(Codes),  2.as(Bytes)'),  "\x[E1]",             'substr with Bytes and Codes as units 2 - utf8';
is eval('substr $u, 3.as(Bytes),  1.as(Graphs)'), "\x[41, 0300]",       'substr with Bytes and Graphs as units 1 - utf8';
is eval('substr $u, 3.as(Graphs), 1.as(Bytes)'),  "\x[41]",             'substr with Bytes and Graphs as units 2 - utf8';


#vim: ft=perl6
rakudo-2013.12/t/spec/S02-types/version.t0000664000175000017500000000150512237474612017371 0ustar  moritzmoritzuse v6;
use Test;

plan 35;

my sub vtest($cmp, *@v) {
    my $x = shift @v;
    while (@v) {
        my $y = shift @v;
        is Version.new($x) cmp Version.new($y), $cmp, "$x cmp $y is $cmp";
        $x = $y;
    }
}

# From S03
vtest Order::Same, 
    < 1.2.1alpha1.0
      1.2.1alpha1
      1.2.1.alpha1
      1.2.1alpha.1
      1.2.1.alpha.1
      1.2-1+alpha/1 >;

# More from S03
vtest Order::Same,
    < 1.2.1_01
      1.2.1_1
      1.2.1._1
      1.2.1_1
      1.2.1._.1
      001.0002.0000000001._.00000000001
      1.2.1._.1.0.0.0.0.0 >;

# Still more from S03
my @sorted = <
   1.2.0.999
    1.2.1_01
    1.2.1_2
    1.2.1_003
    1.2.1a1
    1.2.1.alpha1
    1.2.1b1
    1.2.1.beta1
    1.2.1.gamma
    1.2.1α1
    1.2.1β1
    1.2.1γ
    1.2.1 >;

vtest Order::Less, @sorted;
vtest Order::More, @sorted.reverse;

done;

rakudo-2013.12/t/spec/S02-types/whatever.t0000664000175000017500000001700612253136645017533 0ustar  moritzmoritzuse v6;
use Test;

plan 83;

# L
# L

{
    my $x = *;
    isa_ok $x, Whatever, 'can assign * to a variable and isa works';

    my Whatever $y;
    ok $y.WHAT === Whatever, 'can type variables with Whatever';

    ok *.WHAT === Whatever, '*.WHAT does not autocurry';
}

# L

my $x = *-1;
lives_ok { $x.WHAT }, '(*-1).WHAT lives';
ok $x ~~ Code, '*-1 is some form of Code';
isa_ok $x, WhateverCode, '*-1 is a WhateverCode object';
is $x.(5), 4, 'and we can execute that Code';

ok *.abs ~~ Code, '*.abs is of type Code';
isa_ok *.abs, WhateverCode, '... WhateverCode, more specifically';

isa_ok 1..*, Range, '1..* is a Range, not a Code';
#?niecza skip 'Cannot use value like WhateverCode as a number'
isa_ok 1..*-1, WhateverCode, '1..*-1 is a WhateverCode';
#?niecza skip 'Unable to resolve method postcircumfix:<( )> in class Range'
isa_ok (1..*-1)(10), Range, '(1..*-1)(10) is a Range';

{
    my @a = map *.abs, 1, -2, 3, -4;
    is @a, [1,2,3,4], '*.meth created closure works';
}

{
    # check that it also works with Enums - used to be a Rakudo bug
    # RT #63880
    enum A ;
    isa_ok (b < *), Code, 'Enums and Whatever star interact OK';
}

# check that more complex expressions work:

{
    my $code = *.uc eq 'FOO';
    ok $code ~~ Callable, '"*.uc eq $str" produces a Callable object';
    ok $code("foo"), 'and it works (+)';
    ok !$code("bar"), 'and it works (-)';
}

# RT #64566
#?niecza skip 'hangs'
{
    my @a = 1 .. 4;
    is @a[1..*], 2..4, '@a[1..*] skips first element, stops at last';
    is @a, 1..4, 'array is unmodified after reference to [1..*]';
    # RT #61844
    is (0, 1)[*-1..*], 1, '*-1..* lives and clips to range of Parcel';
}

# RT #68894
{
    my @a = ;
    my $t = join '', map { @a[$_ % *] }, ^5;
    is $t, 'ababa', '$_ % * works';
}

{
    my $x = +*;
    isa_ok $x, Code, '+* is of type Code';

    # following is what we expect +* to do
    my @list = <1 10 2 3>;
    is sort(-> $key {+$key}, @list), [1,2,3,10], '-> $key {+$key} generates closure to numify';

    # and here are two actual applications of +*
    is sort($x, @list), [1,2,3,10], '+* generates closure to numify';
    is @list.sort($x), [1,2,3,10], '+* generates closure to numify';

    # test that  +* works in a slice
    my @x1;
    for 1..4 {
        @x1[+*] = $_;
    }
    is @x1.join('|'), '1|2|3|4', '+* in hash slice (RT 67450)';
}

# L
{
    my $c = * * *;
    ok $c ~~ Code, '* * * generated a closure';
    is $c(-3, -5), 15, '... that takes two arguments';
}

{
    my $c = * * * + *;
    ok $c ~~ Code, '* * * + * generated a closure';
    is $c(2, 2, 2), 6,  '... that works';
    is $c(-3, -3, -3), 6, '... that respects precdence';
    is $c(0, -10, 3), 3, 'that can work with three different arguments';
}

{
    my $c = * + * * *;
    ok $c ~~ Code, '* + * * * generated a closure';
    is $c(2, 2, 2), 6,  '... that works';
    is $c(-3, -3, -3), 6, '... that respects precdence';
    is $c(3, 0, -10), 3, 'that can work with three different arguments';
}

#?niecza skip 'hangs'
is (0,0,0,0,0,0) >>+>> ((1,2) xx *), <1 2 1 2 1 2>, 'xx * works';

{
    is (1, Mu, 2, 3).grep(*.defined), <1 2 3>, '*.defined works in grep';

    my $rt68714 = *.defined;
    ok $rt68714 ~~ Code, '*.defined generates a closure';
    ok $rt68714(68714), '*.defined works (true)';
    ok not $rt68714(Any), '*.defined works (false)';
}

# L
{
    # TODO: find out if this allowed for item assignment, or for list
    # assignment only
    #?rakudo todo '* as dummy'
    eval_lives_ok ' * = 5 ', 'can dummy-asign to *';

    my $x;
    (*, *, $x) = 1, 2, 3, 4, 5;
    is $x, 3, 'Can skip lvalues and replace them by Whatever';
}


# L

{
    my $x = 3;
    {
        is (* + (my $x = 5)).(8), 13,
            'can use a declaration in Whatever-curried expression';
        is $x, 5, 'and it did not get promoted into its own scope';
    }
}

# L Method/This is only for operators that are not
# Whatever-aware.>
{
    multi sub infix:($x, $y) { "$x|$y" };
    isa_ok * quack 5, Code,
        '* works on LHS of user-defined operator (type)';
    isa_ok 5 quack *, Code,
        '* works on RHS of user-defined operator (type)';
    isa_ok * quack *, Code,
        '* works on both sides of user-defined operator (type)';
    is (* quack 5).(3), '3|5',
        '* works on LHS of user-defined operator (result)';
    is (7 quack *).(3), '7|3',
        '* works on RHS of user-defined operator (result)';
    is (* quack *).('a', 'b'), 'a|b',
        '* works on both sides of user-defined operator (result)';
    is ((* quack *) quack *).(1, 2, 3), '1|2|3',
        'also with three *';
    is ((* quack *) quack 'a').(2, 3), '2|3|a',
        'also if the last is not a *, but a normal value';
}

# Ensure that in *.foo(blah()), blah() is not called until we invoke the closure.
{
    my $called = 0;
    sub oh_noes() { $called = 1; 4 }
    my $x = *.substr(oh_noes());
    is $called, 0, 'in *.foo(oh_noes()), oh_noes() not called when making closure';
    ok $x ~~ Callable, 'and we get a Callable as expected';
    is $x('lovelorn'), 'lorn', 'does get called when invoked';
    is $called, 1, 'does get called when invoked';
}

# chains of methods
{
    my $x = *.uc.flip;
    ok $x ~~ Callable, 'we get a Callable from chained methods with *';
    is $x('dog'), 'GOD', 'we call both methods';
}

# chains of operators, RT #71846
{
    is (0, 1, 2, 3).grep(!(* % 2)).join('|'),
        '0|2', 'prefix: Whatever-curries correctly';
}

# RT #69362
{
    my $x = *.uc;
    my $y = * + 3;
    ok $x.signature, 'Whatever-curried method calls have a signature';
    ok $y.signature, 'Whatever-curried operators have a signature';

}

# RT #73162
eval_lives_ok '{*.{}}()', '{*.{}}() lives';

# RT #80256
{
    my $f = * !< 3;
    isa_ok $f, Code, 'Whatever-currying !< (1)';
    nok $f(2), 'Whatever-currying !< (2)';
    ok $f(3), 'Whatever-currying !< (3)';
    ok $f(4), 'Whatever-currying !< (4)';
}

#?rakudo skip 'currying plus meta ops'
{
    my $f = 5 R- *;
    isa_ok $f, Code, 'Whatever-currying with R- (1)';
    is $f(7), 2, 'Whatever-currying with R- (2)';
    is $f(0), -5, 'Whatever-currying with R- (3)';

    dies_ok { &infix:<+>(*, 42) }, '&infix:<+>(*, 42) doesn\'t make a closure';
    #?niecza skip 'Undeclared routine'
    dies_ok { &infix:(*, 42) }, '&infix:<+>(*, 42) doesn\'t make a closure';
}

# RT 79166
{
    my $rt79166 = *;
    isa_ok $rt79166, Whatever, 'assignment of whatever still works';
    $rt79166 = 'RT 79166';
    is $rt79166, 'RT 79166', 'assignment to variable with whatever in it';
}

# RT #81448
{
    sub f($x) { $x x 2 };
    is *.&f.('a'), 'aa', '*.&sub curries';
}

# RT #77000
{
    isa_ok *[0], WhateverCode, '*[0] curries';
    is *[0]([1, 2, 3]), 1, '... it works';
}

# RT #102466

{
    my $chained = 1 < * < 3;
     ok $chained(2), 'Chained comparison (1)';
    nok $chained(1), 'Chained comparison (2)';
    nok $chained(3), 'Chained comparison (3)';
}

# RT #120385
{
    isa_ok (*.[1]), Code, '*.[1] is some kind of code';
    isa_ok (*.), Code, '*. is some kind of code';
    isa_ok (*.{1}), Code, '*.{1} is some kind of code';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/arrays.t0000664000175000017500000001627012227737244017463 0ustar  moritzmoritzuse v6;

use Test;

# L

plan 47;

# Binding of array elements.
# See thread "Binding of array elements" on p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22915">

{
  my @array  = ;
  my $var    = "d";

  try { @array[1] := $var };
  is @array[1], "d", "basic binding of an array element (1)";
  unless @array[1] eq "d" {
    skip_rest "Skipping binding of array elements tests (not yet implemented in the normal runcore)";
    exit;
  }

  $var = "e";
  is @array[1], "e", "basic binding of an array element (2)";

  @array[1] = "f";
  is $var,      "f", "basic binding of an array element (3)";
}

#?niecza skip ":delete"
#?pugs skip ':delete'
{
  my @array  = ;
  my $var    = "d";

  @array[1] := $var;
  $var       = "e";
  is @array[1], "e",  "binding of array elements works with delete (1)";

  @array[1]:delete;
  # $var unchanged, but assigning to $var doesn't modify @array any
  # longer; similarily, changing @array[1] doesn't modify $var now
  is $var,    "e",    "binding of array elements works with delete (2)";
  is ~@array, "a  c", "binding of array elements works with delete (3)";

  $var      = "f";
  @array[1] = "g";
  is $var,      "f",  "binding of array elements works with delete (4)";
  is @array[1], "g",  "binding of array elements works with delete (5)";
}

{
  my @array  = ;
  my $var    = "d";

  @array[1] := $var;
  $var       = "e";
  is @array[1], "e", "binding of array elements works with resetting the array (1)";

  @array = ();
  # $var unchanged, but assigning to $var doesn't modify @array any
  # longer; similarily, changing @array[1] doesn't modify $var now
  is $var,    "e",   "binding of array elements works with resetting the array (2)";
  is ~@array, "",    "binding of array elements works with resetting the array (3)";

  $var      = "f";
  @array[1] = "g";
  is $var,      "f", "binding of array elements works with resetting the array (4)";
  is @array[1], "g", "binding of array elements works with resetting the array (5)";
}

{
  my @array  = ;
  my $var    = "d";

  @array[1] := $var;
  $var       = "e";
  is @array[1], "e",   "binding of array elements works with rebinding the array (1)";

  my @other_array = ;
  @array := @other_array;
  # $var unchanged, but assigning to $var doesn't modify @array any
  # longer; similarily, changing @array[1] doesn't modify $var now
  is $var,    "e",     "binding of array elements works with rebinding the array (2)";
  is ~@array, "x y z", "binding of array elements works with rebinding the array (3)";

  $var      = "f";
  @array[1] = "g";
  is $var,      "f",   "binding of array elements works with rebinding the array (4)";
  is @array[1], "g",   "binding of array elements works with rebinding the array (5)";
}

{
  my sub foo (@arr) { @arr[1] = "new_value" }

  my @array  = ;
  my $var    = "d";
  @array[1] := $var;

  foo @array;
  is $var,    "new_value",     "passing an array to a sub expecting an array behaves correctly (1)";
  is ~@array, "a new_value c", "passing an array to a sub expecting an array behaves correctly (2)";
}

{
  my sub foo (Array $arr) { $arr[1] = "new_value" }

  my @array  = ;
  my $var    = "d";
  @array[1] := $var;

  foo @array;
  is $var,    "new_value",     "passing an array to a sub expecting an arrayref behaves correctly (1)";
  is ~@array, "a new_value c", "passing an array to a sub expecting an arrayref behaves correctly (2)";
}

{
  my sub foo (@args) { @args[1] = "new_value" }

  my @array  = ;
  my $var    = "d";
  @array[1] := $var;

  foo @array;
  is $var,    "new_value",     "passing an array to a slurpying sub behaves correctly (1)";
  is ~@array, "a new_value c", "passing an array to a slurpying sub behaves correctly (2)";
}

#?pugs skip "Can't modify constant item: VUndef"
{
  my sub foo (*@args) { push @args, "new_value" }

  my @array  = ;
  my $var    = "d";
  @array[1] := $var;

  foo @array;
  is $var,    "d",     "passing an array to a slurpying sub behaves correctly (3)";
  is ~@array, "a d c", "passing an array to a slurpying sub behaves correctly (4)";
}

# Binding of not yet existing elements should autovivify
{
  my @array;
  my $var    = "d";

  lives_ok { @array[1] := $var },
                     "binding of not yet existing elements should autovivify (1)";
  is @array[1], "d", "binding of not yet existing elements should autovivify (2)";

  $var = "e";
  is @array[1], "e", "binding of not yet existing elements should autovivify (3)";
  is $var,      "e", "binding of not yet existing elements should autovivify (4)";
}

# Binding with .splice
{
  my @array  = ;
  my $var    = "d";

  @array[1] := $var;
  $var       = "e";
  is @array[1], "e",  "binding of array elements works with splice (1)";

  splice @array, 1, 1, ();
  # $var unchanged, but assigning to $var doesn't modify @array any
  # longer; similarily, changing @array[1] doesn't modify $var now
  #?niecza todo "binding of array elements works with splice (2)"
  is $var,    "e",    "binding of array elements works with splice (2)";
  is ~@array, "a c",  "binding of array elements works with splice (3)";

  $var      = "f";
  @array[1] = "g";
  is $var,      "f",  "binding of array elements works with splice (4)";
  is @array[1], "g",  "binding of array elements works with splice (5)";
}

# Assignment (not binding) creates new containers
{
  my @array  = ;
  my $var    = "d";

  @array[1] := $var;
  $var       = "e";
  is @array[1], "e",       "array assignment creates new containers (1)";

  my @new_array = @array;
  $var          = "f";
  # @array[$idx] and $var are now "f", but @new_array is unchanged.
  is $var,        "f",     "array assignment creates new containers (2)";
  is ~@array,     "a f c", "array assignment creates new containers (3)";
  is ~@new_array, "a e c", "array assignment creates new containers (4)";
}

# Binding does not create new containers
{
  my @array  = ;
  my $var    = "d";

  @array[1] := $var;
  $var       = "e";
  is @array[1], "e",       "array binding does not create new containers (1)";

  my @new_array := @array;
  $var           = "f";
  # @array[$idx] and $var are now "f", but @new_array is unchanged.
  is $var,        "f",     "array binding does not create new containers (2)";
  is ~@array,     "a f c", "array binding does not create new containers (3)";
  is ~@new_array, "a f c", "array binding does not create new containers (4)";
}

# Binding @array := $arrayref.
# See
# http://colabti.de/irclogger/irclogger_log/perl6?date=2005-11-06,Sun&sel=388#l564
# and consider the magic behind parameter binding (which is really normal
# binding).
{
  my $arrayref  = [];
  my @array    := $arrayref;

  is +@array, 3,          'binding @array := $arrayref works (1)';

  @array[1] = "B";
  is ~$arrayref, "a B c", 'binding @array := $arrayref works (2)';
  is ~@array,    "a B c", 'binding @array := $arrayref works (3)';
}

# RT #61566
#?niecza todo
#?pugs todo
{
    eval_dies_ok 'my @rt61566 := 1', 'can only bind Positional stuff to @a';
    # TODO: check that the error is the right one
    #  you should get a "Int does not do Positional role"
    #            exception or something like that.
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/attributes.t0000664000175000017500000000354312224265625020343 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 12;

# Tests for binding instance and class attributes
# note that only attributes themselves ($!foo) can be bound,
# not accessors ($.foo)

{
    my $var = 42;
    class Klass1 { has $.x; method bind { $!x := $var } }

    my $obj1 = Klass1.new;
    lives_ok { $obj1.bind() }, 'attribute binding lives';

    #?pugs 3 todo 'bug'
    is $obj1.x, 42, 'binding $!x instance attribute (1)';
    $var = 23;
    is $obj1.x, 23, 'binding $!x instance attribute (2)';
}

{
    my $var = 42;
    class Klass2 {
        has $x;
        method bind { $x := $var }
        method get_x { $x }
        method set_x ($new_x) { $x = $new_x }
    }

    my $obj2 = Klass2.new;
    $obj2.bind();

    #?pugs 3 todo 'bug'
    is $obj2.get_x, 42, 'binding $x instance attribute (1)';
    $var = 23;
    is $obj2.get_x, 23, 'binding $x instance attribute (2)';
    $obj2.set_x(19);
    is $var,    19,     'binding $x instance attribute (3)';
}

# Public class attributes
#?rakudo skip 'class attributes'
{
    my $var = 42;
    class Klass3 { our $.x; method bind { $!x := $var } }

    try { Klass3.bind() };

    #?pugs 3 todo 'bug'
    is try { Klass3.x }, 42, "binding public class attribute (1)";
    $var = 23;
    is try { Klass3.x }, 23, "binding public class attribute (2)";
    try { Klass3.x = 19 };
    is $var,    19,  "binding public class attribute (3)";
}

# Private class attributes
{
    my $var = 42;
    class Klass4 {
        our $x;
        method bind { $x := $var }
        method get_x { $x }
        method set_x ($new_x) { $x = $new_x }
    }

    try { Klass4.bind() };

    is Klass4.get_x, 42, "binding private class attribute (1)";
    $var = 23;
    is Klass4.get_x, 23, "binding private class attribute (2)";
    Klass4.set_x(19);
    is $var,    19,      "binding private class attribute (3)";
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/closure.t0000664000175000017500000000172512224265625017631 0ustar  moritzmoritzuse v6;

use Test;
plan 8;

diag "Testing for calling block bindings...";
is eval(q[
	my &foo := { "foo" };
	foo;
]), 'foo',  "Calling block binding without argument. (Runtime)";

{
is eval(q[
	my &foo ::= { "foo" };
	foo;
]), 'foo',  "Calling block binding without argument. (read-only bind)";
}

is eval(q[
	my &foo := { $^a };
	foo(1);
]), 1, "Calling block binding with argument. (Runtime, with parens)";

is eval(q[
	my &foo := { $^a };
	foo 1;
]), 1,  "Calling block binding with argument. (Runtime, no parens)";

{
is eval(q[
	my &foo ::= { $^a };
	foo(1);
]), 1,  "Calling block binding with argument. (read-only bind, with parens)";

is eval(q[
	my &foo ::= { $^a };
	foo 1;
]), 1,  "Calling block binding with argument. (read-only bind, no parens)";
}


my &foo_r := { $^a + 5 };
is foo_r(1), 6, "Testing the value for placeholder(Runtime binding)";
{
my &foo_c ::= { $^a + 5 };
is foo_c(1), 6, "Testing the value for placeholder(read-only binding)";
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/hashes.t0000664000175000017500000001371612227737244017437 0ustar  moritzmoritzuse v6;

use Test;

# L

plan 39;

# Binding of hash elements.
# See thread "Binding of array elements" on p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22915">
{
  my %hash  = (:a, :b, :c);
  my $var   = "d";

  try { %hash := $var };
  is %hash, "d", "basic binding of a hash element (1)";
  unless %hash eq "d" {
    skip_rest "Skipping binding of hash elements tests (not yet implemented in the normal runcore)";
    exit;
  }

  $var = "e";
  is %hash, "e", "basic binding of a hash element (2)";

  %hash = "f";
  is $var,     "f", "basic binding of a hash element (3)";
}

#?pugs skip ':delete'
{
  my %hash  = (:a, :b, :c);
  my $var   = "d";

  %hash := $var;
  $var      = "e";
  is %hash, "e",             "binding of hash elements works with delete (1)";

  %hash:delete;
  # $var unchanged, but assigning to $var doesn't modify @hash any
  # longer; similarily, changing @hash[1] doesn't modify $var now
  is $var,   "e",               "binding of hash elements works with delete (2)";
  #?pugs todo
  is ~%hash.values.sort, "x z", "binding of hash elements works with delete (3)";

  $var     = "f";
  %hash = "g";
  is $var,     "f",             "binding of hash elements works with delete (4)";
  is %hash, "g",             "binding of hash elements works with delete (5)";
}

{
  my %hash  = (:a, :b, :c);
  my $var   = "d";

  %hash := $var;
  $var      = "e";
  is %hash, "e", "binding of hash elements works with resetting the hash (1)";

  %hash = ();
  # $var unchanged, but assigning to $var doesn't modify @hash any
  # longer; similarily, changing @hash[1] doesn't modify $var now
  is $var,   "e",   "binding of hash elements works with resetting the hash (2)";
  is ~%hash, "",    "binding of hash elements works with resetting the hash (3)";

  $var     = "f";
  %hash = "g";
  is $var,     "f", "binding of hash elements works with resetting the hash (4)";
  is %hash, "g", "binding of hash elements works with resetting the hash (5)";
}

{
  my %hash  = (:a, :b, :c);
  my $var   = "d";

  %hash := $var;
  $var      = "e";
  is %hash, "e", "binding of hash elements works with rebinding the hash (1)";

  my %other_hash = (:p, :r, :t);
  %hash := %other_hash;
  # $var unchanged, but assigning to $var doesn't modify @hash any
  # longer; similarily, changing @hash[1] doesn't modify $var now
  is $var,    "e",  "binding of hash elements works with rebinding the hash (2)";
  #?pugs todo
  is ~%hash.values.sort, "q s u",
    "binding of hash elements works with rebinding the hash (3)";

  $var     = "f";
  %hash = "g";
  is $var,     "f", "binding of hash elements works with rebinding the hash (4)";
  is %hash, "g", "binding of hash elements works with rebinding the hash (5)";
}

{
  my sub foo (%h) { %h = "new_value" }

  my %hash  = (:a, :b, :c);
  my $var   = "d";
  %hash := $var;

  foo %hash;
  is $var,    "new_value",     "passing a hash to a sub expecting a hash behaves correctly (1)";
  #?pugs todo
  is ~%hash.values.sort, "new_value x z",
    "passing a hash to a sub expecting a hash behaves correctly (2)";
}

{
  my sub foo (Hash $h) { $h = "new_value" }

  my %hash  = (:a, :b, :c);
  my $var   = "d";
  %hash := $var;

  foo %hash;
  is $var, "new_value",
    "passing a hash to a sub expecting a hashref behaves correctly (1)";
  #?pugs todo
  is ~%hash.values.sort, "new_value x z",
    "passing a hash to a sub expecting a hashref behaves correctly (2)";
}

# Binding of not yet existing elements should autovivify
{
  my %hash;
  my $var = "d";

  lives_ok { %hash := $var },
                    "binding of not yet existing elements should autovivify (1)";
  is %hash, "d", "binding of not yet existing elements should autovivify (2)";

  $var = "e";
  is %hash, "e", "binding of not yet existing elements should autovivify (3)";
  is $var,     "e", "binding of not yet existing elements should autovivify (4)";
}

# Assignment (not binding) creates new containers
{
  my %hash  = (:a, :b, :c);
  my $var   = "d";

  %hash := $var;
  $var      = "e";
  is %hash, "e",                   "hash assignment creates new containers (1)";

  my %new_hash = %hash;
  $var         = "f";
  # %hash and $var are now "f", but %new_hash is unchanged.
  is $var,                   "f",     "hash assignment creates new containers (2)";
  #?pugs todo
  is ~%hash\   .values.sort, "f x z", "hash assignment creates new containers (3)";
  #?pugs todo
  is ~%new_hash.values.sort, "e x z", "hash assignment creates new containers (4)";
}

# Binding does not create new containers
{
  my %hash  = (:a, :b, :c);
  my $var   = "d";

  %hash := $var;
  $var      = "e";
  is %hash, "e",                   "hash binding does not create new containers (1)";

  my %new_hash := %hash;
  $var          = "f";
  # %hash and $var are now "f", but %new_hash is unchanged.
  is $var,        "f",                "hash binding does not create new containers (2)";
  #?pugs todo
  is ~%hash\   .values.sort, "f x z", "hash binding does not create new containers (3)";
  #?pugs todo
  is ~%new_hash.values.sort, "f x z", "hash binding does not create new containers (4)";
}

# Binding %hash := $hashref.
# See
# http://colabti.de/irclogger/irclogger_log/perl6?date=2005-11-06,Sun&sel=388#l564
# and consider the magic behind parameter binding (which is really normal
# binding).
{
  my $hashref = { a => "a", b => "b" };
  my %hash   := $hashref;

  is +%hash, 2,                    'binding %hash := $hashref works (1)';

  %hash = "c";
  is ~$hashref.values.sort, "a c", 'binding %hash := $hashref works (2)';
  is ~%hash\  .values.sort, "a c", 'binding %hash := $hashref works (3)';
}

#?pugs todo
eval_dies_ok 'my %h = a => 1, b => 2; %h := (4, 5)',
    'Cannot bind to hash slices';
#?rakudo skip 'without fudging 1 rakudo test, the whole file fails?'
is 1,1, 'dummy';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/nested.t0000664000175000017500000002170012224265625017432 0ustar  moritzmoritzuse v6;

use Test;

# L

# Tests for binding multidimensional structures.

plan 43;

# Nested refs as RHS in a binding operation
{
    my $struct = [
        "ignored",
        {
            key => {
                ignored => 23,
                subkey  => [
                    "ignored",
                    42,
                ],
            },
            ignored => 19,
        },
    ];

    is $struct[1][1], 42, "basic sanity (1)";

    my $abbrev := $struct[1][1];
    is $abbrev, 42,
        "using a multidimensional structure as RHS in a binding op works (1)";

    $struct[1][1] = 43;
    is $abbrev, 43,
        "using a multidimensional structure as RHS in a binding op works (2)";

    $abbrev = 44;
    is $struct[1][1], 44,
        "using a multidimensional structure as RHS in a binding op works (3)";
}

# Nested refs as LHS in a binding operation
{
    my $struct = [
        "ignored",
        {
            key => {
                ignored => 23,
                subkey  => [
                    "ignored",
                    42,
                ],
            },
            ignored => 19,
        },
    ];

    is $struct[1][1], 42, "basic sanity (2)";

    my $abbrev = 30;
    try { $struct[1][1] := $abbrev };
    is $abbrev, 30,
        "using a multidimensional structure as LHS in a binding op works (1)";

    $struct[1][1] = 31;
    is $abbrev, 31,
        "using a multidimensional structure as LHS in a binding op works (2)";

    $abbrev = 32;
    is $struct[1][1], 32,
        "using a multidimensional structure as LHS in a binding op works (3)";
}

# Evil more evil structure: with an embedded "is parcel" sub!
# As RHS...
#?niecza skip "is parcel - https://github.com/sorear/niecza/issues/177"
{
    my $innerstruct = {
        ignored => 23,
        subkey  => [
            "ignored",
            42,
        ],
    };

    my sub get_innerstruct () is parcel { $innerstruct }

    my $struct = [
        "ignored",
        {
            key     => &get_innerstruct,
            ignored => 19,
        },
    ];

    is $struct[1]()[1], 42, "basic sanity (3)";

    my $abbrev := $struct[1]()[1];
    is $abbrev, 42,
        "using a multidimensional structure with an embedded sub as RHS works (1)";

    $struct[1]()[1] = 43;
    is $abbrev, 43,
        "using a multidimensional structure with an embedded sub as RHS works (2)";

    $abbrev = 44;
    is $struct[1]()[1], 44,
        "using a multidimensional structure with an embedded sub as RHS works (3)";
}

# ...and as LHS
#?niecza skip "is parcel - https://github.com/sorear/niecza/issues/177"
{
    my $innerstruct = {
        ignored => 23,
        subkey  => [
            "ignored",
            42,
        ],
    };

    my sub get_innerstruct () is parcel { $innerstruct }

    my $struct = [
        "ignored",
        {
            key     => &get_innerstruct,
            ignored => 19,
        },
    ];

    is $struct[1]()[1], 42, "basic sanity (4)";

    my $abbrev = 30;
    try { $struct[1]()[1] := $abbrev };
    is $abbrev, 30,
        "using a multidimensional structure with an embedded sub as LHS works (1)";

    $struct[1]()[1] = 31;
    is $abbrev, 31,
        "using a multidimensional structure with an embedded sub as LHS works (2)";

    $abbrev = 32;
    is $struct[1]()[1], 32,
        "using a multidimensional structure with an embedded sub as LHS works (3)";
}

# Binding should cope with a subtree being redefined.
# As RHS...
{
    my $struct = [
        "ignored",
        {
            key => {
                ignored => 23,
                subkey  => [
                    "ignored",
                    42,
                ],
            },
            ignored => 19,
        },
    ];

    is $struct[1][1], 42, "basic sanity (5)";

    my $abbrev := $struct[1][1];
    is $abbrev, 42,
        "RHS binding should cope with a subtree being redefined (1)";

    $struct[1][1] = 43;
    is $abbrev, 43,
        "RHS binding should cope with a subtree being redefined (2)";

    $struct[1] = "foo";
    is $struct[1], "foo",
        "RHS binding should cope with a subtree being redefined (3)";
    is $abbrev, 43,
        "RHS binding should cope with a subtree being redefined (4)";

    $abbrev = 44;
    is $abbrev, 44,
        "RHS binding should cope with a subtree being redefined (5)";
    is $struct[1], "foo",
        "RHS binding should cope with a subtree being redefined (6)";
}

# ...and as LHS
{
    my $struct = [
        "ignored",
        {
            key => {
                ignored => 23,
                subkey  => [
                    "ignored",
                    42,
                ],
            },
            ignored => 19,
        },
    ];

    is $struct[1][1], 42, "basic sanity (6)";

    my $abbrev = 42;
    try { $struct[1][1] := $abbrev };
    is $abbrev, 42,
        "LHS binding should cope with a subtree being redefined (1)";

    $struct[1][1] = 43;
    is $abbrev, 43,
        "LHS binding should cope with a subtree being redefined (2)";

    $struct[1] = "foo";
    is $struct[1], "foo",
        "LHS binding should cope with a subtree being redefined (3)";
    is $abbrev, 43,
        "LHS binding should cope with a subtree being redefined (4)";

    $abbrev = 44;
    is $abbrev, 44,
        "LHS binding should cope with a subtree being redefined (5)";
    is $struct[1], "foo",
        "LHS binding should cope with a subtree being redefined (6)";
}

# Tests for binding an element of a structure to an element of another
# structure.
{
    my $foo = [
        "ignored",
        {
            key => {
                ignored => 1,
                subkey  => [
                    "ignored",
                    2,
                ],
            },
            ignored => 3,
        },
    ];

    my $bar = [
        "ignored",
        {
            key => {
                ignored => 4,
                subkey  => [
                    "ignored",
                    5,
                ],
            },
            ignored => 6,
        },
    ];

    try { $bar[1] := $foo[1] };
    is (try { $bar[1][1] }), 2,
        "binding an element of a structure to an element of another structure works (1)";

    try { $foo[1][1] = 7 };
    is (try { $bar[1][1] }), 7,
        "binding an element of a structure to an element of another structure works (2)";

    try { $bar[1][1] = 8 };
    is (try { $foo[1][1] }), 8,
        "binding an element of a structure to an element of another structure works (3)";
}

# Tests for binding an element of a structure to an element of *the same*
# structure, effectively creating an infinite structure.
{
    my $struct = [
        "ignored",
        {
            key => {
                foo    => "bar",
                subkey => [
                    "ignored",
                    100,
                ],
            },
            ignored => 200,
        },
    ];

    try { $struct[1][1] := $struct[1] };
    is (try { $struct[1][1] }), "bar",
        "binding an element of a structure to an element of the same structure works (1)";

    try { $struct[1][1] = "new_value" };
    is $struct[1], "new_value",
        "binding an element of a structure to an element of the same structure works (2)";

    $struct[1] = "very_new_value";
    is (try { $struct[1][1] }), "very_new_value",
        "binding an element of a structure to an element of the same structure works (3)";

    $struct[1][1] = 23;
    is $struct[1], 23,
        "binding an element of a structure to an element of the same structure works (4)";
}

# Test that rebinding to some other value really breaks up the binding.
{
    my $struct = [
        "ignored",
        {
            key => {
                ignored => 23,
                subkey  => [
                    "ignored",
                    42,
                ],
            },
            ignored => 19,
        },
    ];

    is $struct[1][1], 42, "basic sanity (7)";

    my $abbrev := $struct[1][1];
    is $abbrev, 42,
        "rebinding to some other value destroys the previous binding (1)";

    $struct[1][1] = 43;
    is $abbrev, 43,
        "rebinding to some other value destroys the previous binding (2)";

    $abbrev = 44;
    is $struct[1][1], 44,
        "rebinding to some other value destroys the previous binding (3)";

    $abbrev := 45;
    is $abbrev, 45,
        "rebinding to some other value destroys the previous binding (4)";
    is $struct[1][1], 44,
        "rebinding to some other value destroys the previous binding (5)";
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/ro.t0000664000175000017500000000175712224265625016602 0ustar  moritzmoritzuse v6;
use Test;

plan 9;

# L

{
    my $x = 5;
    my $y = 3;
    $x ::= $y;
    is $x, 3, '::= on scalars took the value from the RHS';
    #?rakudo todo 'nom regression'
    #?pugs todo
    dies_ok { $x = 5 }; '... and made the LHS RO';
    #?rakudo todo 'nom regression'
    #?pugs todo
    is $x, 3, 'variable is still 3';
}

#?pugs todo
{
    my Int $a = 4;
    my Str $b;
    dies_ok { $b ::= $a },
        'Cannot ro-bind variables with incompatible type constraints';
}

{
    my @x = ;
    my @y = ;

    @x ::= @y;
    is @x.join('|'), 'd|e', '::= on arrays';
    #?rakudo 4 todo '::= on arrays'
    #?niecza todo
    #?pugs 4 todo
    dies_ok { @x := <3 4 foo> }, '... make RO';
    #?niecza todo
    is @x.join('|'), 'd|e', 'value unchanged';
    #?niecza todo
    lives_ok { @x[2] = 'k' }, 'can still assign to items of RO array';
    #?niecza todo
    is @x.join(''), 'd|e|k', 'assignment relly worked';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/scalars.t0000664000175000017500000000760012224265625017603 0ustar  moritzmoritzuse v6;

use Test;

=begin head1
Binding tests

These tests are derived from the "Item assignment precedence" section of Synopsis 3

# L

=end head1

plan 33;

# Basic scalar binding tests
{
  my $x = 'Just Another';
  is($x, 'Just Another', 'normal assignment works');

  my $y := $x;
  is($y, 'Just Another', 'y is now bound to x');

  ok($y =:= $x, 'y is bound to x (we checked with the =:= identity op)');

  my $z = $x;
  is($z, 'Just Another', 'z is not bound to x');

  ok(!($z =:= $x), 'z is not bound to x (we checked with the =:= identity op)');

  $y = 'Perl Hacker';
  is($y, 'Perl Hacker', 'y has been changed to "Perl Hacker"');
  is($x, 'Perl Hacker', 'x has also been changed to "Perl Hacker"');

  is($z, 'Just Another', 'z is still "Just Another" because it was not bound to x');
}

# RT #77594
eval_dies_ok '0 := 1', 'cannot bind to a literal';


# Binding and $CALLER::
#XXX This can pass bogusly (was doing for Rakudo for a while).
#?niecza skip 'CALLER::'
{
  sub bar {
    return $CALLER::a eq $CALLER::b;
  }

  sub foo {
    my $a is dynamic = "foo";
    my $b is dynamic := $a;    #OK not used
    return bar(); # && bar2();
  }

  ok(foo(), "CALLER resolves bindings in caller's dynamic scope");
}

# Binding to swap
#?rakudo skip 'list binding'
#?niecza skip 'list binding'
{
  my $a = "a";
  my $b = "b";

  ($a, $b) := ($b, $a);
  is($a, 'b', '$a has been changed to "b"');
  is($b, 'a', '$b has been changed to "a"');

  $a = "c";
  is($a, 'c', 'binding to swap didn\'t make the vars readonly');
}

# More tests for binding a list
#?rakudo skip 'list binding'
#?niecza skip 'list binding'
{
  my $a = "a";
  my $b = "b";
  my $c = "c";

  ($a, $b) := ($c, $c);
  is($a, 'c', 'binding a list literal worked (1)');
  is($b, 'c', 'binding a list literal worked (2)');

  $c = "d";
  is($a, 'd', 'binding a list literal really worked (1)');
  is($b, 'd', 'binding a list literal really worked (2)');
}


# Binding subroutine parameters
# XXX! When executed in interactive Pugs, the following test works!
{
  my $a;
  my $b = sub ($arg) { $a := $arg };
  my $val = 42;

  $b($val);
  is $a, 42, "bound readonly sub param was bound correctly (1)";
  $val++;
  #?niecza todo "difference of interpretation on ro binding"
  #?rakudo todo 'nom regression'
  is $a, 43, "bound readonly sub param was bound correctly (2)";

  dies_ok { $a = 23 },
    "bound readonly sub param remains readonly (1)";
  #?niecza todo "difference of interpretation on ro binding"
  #?rakudo todo 'nom regression'
  is $a, 43,
    "bound readonly sub param remains readonly (2)";
  is $val, 43,
    "bound readonly sub param remains readonly (3)";
}

{
  my $a;
  my $b = sub ($arg is rw) { $a := $arg };
  my $val = 42;

  $b($val);
  is $a, 42, "bound rw sub param was bound correctly (1)";
  $val++;
  is $a, 43, "bound rw sub param was bound correctly (2)";

  lives_ok { $a = 23 }, "bound rw sub param remains rw (1)";
  is $a, 23,            "bound rw sub param remains rw (2)";
  is $val, 23,          "bound rw sub param remains rw (3)";
}

# := actually takes subroutine parameter list
#?rakudo skip 'List binding'
#?niecza skip 'list binding'
#?pugs skip 'Cannot bind this as lhs'
{
  my $a;
  :(:$a) := (:a);
  is($a, "foo", "bound keyword");
  my @tail;
  :($a, *@tail) := (1, 2, 3);
  ok($a == 1 && ~@tail eq '2 3', 'bound slurpy');
}

# RT #77462
# binding how has the same precedence as list assignment
#?pugs todo
{
    my $x := 1, 2;
    is $x.join, '12', 'binding has same precdence as list assignment'
}

# RT #76508
{
    my $a := 2;
    $a := $a;
    is $a, 2, 'can bind variable to itself (no-oop)';
}

# RT #89484
{
    my $x = 5;
    sub f($y) { $x := 5 }	#OK not used
    f($x);
    is $x, 5, 'interaction between signature binding and ordinary binding';
}

# RT #87034
{
    my $x = 1;
    my $y := $x;
    $x := 3;
    is $y, 1, 'rebinding';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-binding/subs.t0000664000175000017500000000522312224265625017126 0ustar  moritzmoritzuse v6;

use Test;

plan 12;

# L

# Tests for rebinding subroutines themselves

{
  my sub foo { 42 }
  my sub bar { 41 }

  is(foo(), 42, 'before sub redefinition');

  &foo := &bar;
  is(foo(), 41, 'after sub redefinition');
}

# Since regexes are methods, token redefinition should work the same way

package TokenTest {
  token foo { <[ab]> }
  token bar { <[ef]> }

  my $target = 'cat';
  my Bool $bool;

  #?pugs todo
  ok($bool = ($target ~~ m//), 'before token redefinition');

  &foo := &bar;
  ok(not($bool = ($target ~~ m//)), 'after token redefinition');
}

# Tests for binding the return value of subroutines (both as RHS and LHS).

{
    my sub foo { 42 }

    my $var := foo();
    is $var, 42,
        "binding a var to the return value of a sub (a constant) works (1)";

    dies_ok { $var = 23 },
        "binding a var to the return value of a sub (a constant) works (2)";
}

=begin unspecced

{
    my sub foo { 42 }

    dies_ok { foo() := 23 },
        "using the constant return value of a sub as the LHS in a binding operation dies";
}

There're two ways one can argue:
* 42 is constant, and rebinding constants doesn't work, so foo() := 23 should
  die.
* 42 is constant, but the implicit return() packs the constant 42 into a
  readonly 42, and readonly may be rebound.
  To clear the terminology,
    42                  # 42 is a constant
    sub foo ($a) {...}  # $a is a readonly

=end unspecced

{
    my sub foo { my $var = 42; $var }

    my $var := foo();
    is $var, 42,
        "binding a var to the return value of a sub (a variable) works (1)";

    #?pugs todo
    dies_ok { $var = 23 },
        "binding a var to the return value of a sub (a variable) works (2)";
}

{
    my sub foo is parcel { my $var = 42; $var }

    my $var := foo();
    is $var, 42,
        "binding a var to the return value of an 'is parcel' sub (a variable) works (1)";

    lives_ok { $var = 23 },
        "binding a var to the return value of an 'is parcel' sub (a variable) works (2)";
    is $var, 23,
        "binding a var to the return value of an 'is parcel' sub (a variable) works (3)";
}

{
    my sub foo is parcel { my $var = 42; $var }

    #?pugs todo 'bug'
    lives_ok { foo() := 23 },
        "using the variable return value of an 'is parcel' sub as the LHS in a binding operation works";
}

=begin discussion

Should the constant return value be autopromoted to a var? Or should it stay a
constant?

{
    my sub foo is parcel { 42 }

    dies_ok/lives_ok { foo() := 23 },
        "using the constant return value of an 'is parcel' sub as the LHS in a binding operation behaves correctly";
}

=end discussion

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-feeds/basic.t0000664000175000017500000000752212224265625016713 0ustar  moritzmoritzuse v6;

use Test;

# L
# L

=begin pod

Tests for the feed operators 

    ==> and <== 
    
=end pod

plan 25;

#?pugs skip '<== dies with cast error'
{
    my @a = (1, 2);
    my (@b, @c);
    
    @a ==> @b;
    @c <== @a;

    #?pugs 2 todo 'feed operators do not work'
    is(~@b, ~@a, "ltr feed as simple assignment");
    is(~@c, ~@a, "rtl feed as simple assignment");
}

#?pugs skip '<== dies with cast error'
{
    my @a = (1 .. 5);
    my @e = (2, 4);

    my (@b, @c);
    @a ==> grep { ($_ % 2) == 0 } ==> @b;
    @c <== grep { ($_ % 2) == 0 } <== @a;
    my @f = do {@a ==> grep {($_ % 2) == 0}};
    my @g = (@a ==> grep {($_ % 2) == 0});

    #?pugs 4 todo 'feed operators do not work'
    is(~@b, ~@e, "array ==> grep ==> result");
    is(~@c, ~@e, "result <== grep <== array");
    is(~@f, ~@e, 'result = do {array ==> grep}');
    is(~@g, ~@e, 'result = (array ==> grep)');
}

{
    my ($got_x, $got_y, @got_z);
    sub foo ($x, $y?, *@z) {
        $got_x = $x;
        $got_y = $y;
        @got_z = @z;
    }

    my @a = (1 .. 5);

    @a ==> foo "x";

    #?pugs todo 'feed operators do not work'
    is($got_x, "x", "x was passed as explicit param");
    #?rakudo 2 todo 'feeds + signatures'
    ok(!defined($got_y), "optional param y was not bound to fed list");
    #?pugs todo 'feed operators do not work'
    is(~@got_z, ~@a, '...slurpy array *@z got it');
}

{
    my @data = <1 2 4 5 7 8>;
    my @odds = <1 5 7>;

    eval_dies_ok('@data <== grep {$_ % 2} <== @data', 'a chain of feeds may not begin and end with the same array');

    @data = <1 2 4 5 7 8>;
    @data <== grep {$_ % 2} <== eager @data;
    #?rakudo 2 todo 'feeds + eager'
    is(~@data, ~@odds, '@arr <== grep <== eager @arr works');

    @data = <1 2 4 5 7 8>;
    @data <== eager grep {$_ % 2} <== @data;
    is(~@data, ~@odds, '@arr <== eager grep <== @arr works');
}

# checking the contents of a feed: installing a tap
{
    my @data = <0 1 2 3 4 5 6 7 8 9>;
    my @tap;

    @data <== map {$_ + 1} <== @tap <== grep {$_ % 2} <== eager @data;
    is(@tap, <1 3 5 7 9>, '@tap contained what was expected at the time');
    #?rakudo todo 'feeds + eager'
    is(@data, <2 4 6 8 10>, 'final result was unaffected by the tap variable');
}

# <<== and ==>> pretending to be unshift and push, respectively
#?rakudo skip 'double-ended feeds'
{
    my @odds = <1 3 5 7 9>;
    my @even = <0 2 4 6 8>;

    my @numbers = do {@odds ==>> @even};
    is(~@numbers, ~(@even, @odds), 'basic ==>> test');

    @numbers = do {@odds <<== @even};
    is(~@numbers, ~(@odds, @even), 'basic <<== test');
}

# feeding to whatever using ==> and ==>>

#?rakudo skip 'double-ended feeds'
{
    my @data = 'a' .. 'e';

    @data ==> *;
    is(@(*), @data, 'basic feed to whatever');

     ==>  *;
    0 .. 3    ==>> *;
    is(@(*), , 'two feeds to whatever as array');
}

# stacked feeds
#?rakudo todo '* feeds'
{
    ('a' .. 'd'; 0 .. 3) ==> my @data;
    is(@(@data), , 'two stacked feeds');
}

# feed and Inf
#?nieza skip "unhandled exception
{
  lives_ok { my @a <== 0..Inf }
}

#?nieza skip "Unhandled exception"
{
  my $call-count = 0;
  my @a <== gather for 1..10 -> $i { $call-count++; take $i };
  @a[0];
  #?rakudo todo "isn't lazy"
  is $call-count, 1;
}

# no need for temp variables in feeds: $(*), @(*), %(*)
#?rakudo skip '* feeds'
#?DOES 4
{
    my @data = 'a' .. 'z';
    my @out  = ;

    @data ==> grep {/<[aeiouy]>/} ==> is($(*), $(@out), 'basic test for $(*)');
    @data ==> grep {/<[aeiouy]>/} ==> is(@(*), @(@out), 'basic test for @(*)');
    @data ==> grep {/<[aeiouy]>/} ==> is(%(*), %(@out), 'basic test for %(*)');

    # XXX: currently the same as the @(*) test above. Needs to be improved
    @data ==> grep {/<[aeiouy]>/} ==> is(@(*).slice, @(@out).slice, 'basic test for @(*).slice');
}


done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-junctions/associative.t0000664000175000017500000000165012224265625021066 0ustar  moritzmoritzuse v6;

use Test;

plan 10;

# Checking Junctions' Associativeness
# TODO: need smartlink

sub jv(Mu $j) {
    my @e;
    (-> Any $x { @e.push: $x }).($j);
    return @e.sort.join(' ');
}

# L
# L
{

    is('1 2 3', jv((1|2)|3), "Left-associative any, | operator");
    is('1 2 3', jv(1|(2|3)), "Right-associative any, | operator");

    is('1 2 3', jv(any(any(1,2),3)), "Left-associative any()");
    is('1 2 3', jv(any(1,any(2,3))), "Right-associative any()");

    is('1 2 3', jv((1&2)&3), "Left-associative all, & operator");
    is('1 2 3', jv(1&(2&3)), "Right-associative all, & operator");

    is('1 2 3', jv(all(all(1,2),3)), "Left-associative all()");
    is('1 2 3', jv(all(1,all(2,3))), "Right-associative all()");

    is('1 2 3', jv(none(none(1,2),3)), "Left-associative none()");
    is('1 2 3', jv(none(1,none(2,3))), "Right-associative none()");

}

done();

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-junctions/autothreading.t0000664000175000017500000002647112224265625021422 0ustar  moritzmoritzuse v6;
use Test;

plan 89;

{
    # Solves the equation A + B = A * C for integers
    # by autothreading over all interesting values

    my $n = 0;
    sub is_it($a, $b, $c) {
        $n++;
        if ($a != $b && $b != $c && $a != $c &&
        $a * 10 + $c == $a + $b ) {
            return "$a + $b = $a$c";
        } else {
            return ();
        }
    }

    # note that since the junction is not evaluated in boolean context,
    # it's not collapsed, and the auto-threading may not abort prematurely
    # when a result is found.
    my Mu $answer = is_it(any(1..2), any(7..9), any(0..6));
    is($n, 42, "called lots of times :-)");
    ok( ?($answer eq "1 + 9 = 10"), "found right answer");
}

{
    # Checks auto-threading works on method calls too, and that we get the
    # right result.
    class Foo {
        has $.count = 0;
        method test($x) { $!count++; return $x }
    }

    my $x;
    my Mu $r;
    my Mu $ok;
    $x = Foo.new;
    $r = $x.test(1|2);
    is($x.count, 2, 'method called right number of times');
    $ok = $r.perl.subst(/\D/, '', :g) eq '12' | '21';
    ok(?$ok,        'right values passed to method');

    $x = Foo.new;
    $r = $x.test(1 & 2 | 3);
    is($x.count, 3, 'method called right number of times');
    $ok = $r.perl.subst(/\D/, '', :g) eq '123' | '213' | '312' | '321'; # e.g. & values together
    ok(?$ok,        'junction structure maintained');
}

{
    # Check auto-threding works right on multi-subs.
    my $calls_a = 0;
    my $calls_b = 0;
    my $calls_c = 0;
    my ($r, $ok);
    multi mstest(Int $x) { $calls_a++; return $x }
    multi mstest(Str $x, Str $y) { $calls_b++ }    #OK not used
    multi mstest(Str $x) { $calls_c++ }    #OK not used
    $r = mstest(1&2 | 3);
    is($calls_a, 3, 'correct multi-sub called right number of times');
    is($calls_b, 0, 'incorrect multi-sub not called');
    is($calls_c, 0, 'incorrect multi-sub not called');
    $ok = $r.perl.subst(/\D/, '', :g) eq '123' | '213' | '312' | '321'; # e.g. & values together
    ok(?$ok,        'junction structure maintained');

    $calls_a = 0;
    $calls_b = 0;
    $calls_c = 0;
    mstest("a" | "b", "c" & "d");
    is($calls_b, 4, 'correct multi-sub called right number of times');
    is($calls_a, 0, 'incorrect multi-sub not called');
    is($calls_c, 0, 'incorrect multi-sub not called');
    
    $calls_a = 0;
    $calls_b = 0;
    $calls_c = 0;
    mstest('a' | 1 & 'b');
    is($calls_a, 1, 'correct multi-sub called right number of times (junction of many types)');
    is($calls_c, 2, 'correct multi-sub called right number of times (junction of many types)');
    is($calls_b, 0, 'incorrect multi-sub not called');

    # Extra sanity, in case some multi-dispatch caching issues existed.
    $calls_a = 0;
    $calls_b = 0;
    $calls_c = 0;
    mstest('a' | 1 & 'b');
    is($calls_a, 1, 'correct multi-sub called again right number of times (junction of many types)');
    is($calls_c, 2, 'correct multi-sub called again right number of times (junction of many types)');
    is($calls_b, 0, 'incorrect multi-sub again not called');
    
    $calls_a = 0;
    $calls_b = 0;
    $calls_c = 0;
    mstest('a');
    is($calls_a, 0, 'non-junctional dispatch still works');
    is($calls_b, 0, 'non-junctional dispatch still works');
    is($calls_c, 1, 'non-junctional dispatch still works');
}

{
    # Check auto-threading with multi-methods. Basically a re-hash of the
    # above, but in a class.
    class MMTest {
        has $.calls_a = 0;
        has $.calls_b = 0;
        has $.calls_c = 0;
        multi method mmtest(Int $x) { $!calls_a++; return $x }
        multi method mmtest(Str $x, Str $y) { $!calls_b++ }    #OK not used
        multi method mmtest(Str $x) { $!calls_c++ }    #OK not used
    }
    my ($obj, $r, $ok);
    $obj = MMTest.new();
    $r = $obj.mmtest(1&2 | 3);
    is($obj.calls_a, 3, 'correct multi-method called right number of times');
    is($obj.calls_b, 0, 'incorrect multi-method not called');
    is($obj.calls_c, 0, 'incorrect multi-method not called');
    $ok = $r.perl.subst(/\D/, '', :g) eq '123' | '213' | '312' | '321'; # e.g. & values together
    ok(?$ok,            'junction structure maintained');

    $obj = MMTest.new();
    $obj.mmtest("a" | "b", "c" & "d");
    is($obj.calls_b, 4, 'correct multi-method called right number of times');
    is($obj.calls_a, 0, 'incorrect multi-method not called');
    is($obj.calls_c, 0, 'incorrect multi-method not called');
    
    $obj = MMTest.new();
    $obj.mmtest('a' | 1 & 'b');
    is($obj.calls_a, 1, 'correct multi-method called right number of times (junction of many types)');
    is($obj.calls_c, 2, 'correct multi-method called right number of times (junction of many types)');
    is($obj.calls_b, 0, 'incorrect multi-method not called');
}

{
    # Ensure named params in single dispatch auto-thread.
    my $count = 0;
    my @got;
    sub nptest($a, :$b, :$c) { $count++; @got.push($a ~ $b ~ $c) }
    my Mu $r = nptest(1, c => 4|5, b => 2|3);
    is($count, 4,      'auto-threaded over named parameters to call sub enough times');
    @got .= sort;
    is(@got.elems, 4,  'got array of right size to check what was called');
    is(@got[0], '124', 'called with correct parameters');
    is(@got[1], '125', 'called with correct parameters');
    is(@got[2], '134', 'called with correct parameters');
    is(@got[3], '135', 'called with correct parameters');
}

{
    # Ensure named params in multi dispatch auto-thread.
    my $count_a = 0;
    my $count_b = 0;
    my @got;
    multi npmstest(Int $a, :$b, :$c) { $count_a++; @got.push($a ~ $b ~ $c) }
    multi npmstest(Str $a, :$b, :$c) { $count_b++; @got.push($a ~ $b ~ $c) }
    my $r = npmstest(1&'a', c => 2|3, b => 1);
    is($count_a, 2,    'auto-threaded over named parameters to call multi-sub variant enough times');
    is($count_b, 2,    'auto-threaded over named parameters to call multi-sub variant enough times');
    @got .= sort;
    is(@got.elems, 4,  'got array of right size to check what was called');
    is(@got[0], '112', 'called with correct parameters');
    is(@got[1], '113', 'called with correct parameters');
    is(@got[2], 'a12', 'called with correct parameters');
    is(@got[3], 'a13', 'called with correct parameters');
}

{
    # Auto-threading over an invocant.
    our $cnt1 = 0;
    class JuncInvTest1 {
        method a { $cnt1++; }
        has $.n;
        method d { 2 * $.n }
    }
    our $cnt2 = 0;
    class JuncInvTest2 {
        method a { $cnt2++; }
        method b($x) { $cnt2++ }    #OK not used
    }

    my Mu $x = JuncInvTest1.new | JuncInvTest1.new | JuncInvTest2.new;
    $x.a;
    is $cnt1, 2, 'basic auto-threading over invocant works';
    is $cnt2, 1, 'basic auto-threading over invocant works';

    $cnt1 = $cnt2 = 0;
    $x = JuncInvTest1.new | JuncInvTest2.new & JuncInvTest2.new;
    $x.a;
    is $cnt1, 1, 'auto-threading over invocant of nested junctions works';
    is $cnt2, 2, 'auto-threading over invocant of nested junctions works';

    $x = JuncInvTest1.new(n => 1) | JuncInvTest1.new(n => 2) & JuncInvTest1.new(n => 4);
    my Mu $r = $x.d;
    my $ok = ?($r.perl.subst(/\D/, '', :g) eq '248' | '284' | '482' | '842');
    ok($ok, 'auto-threading over invocant produced correct junctional result');

    $cnt2 = 0;
    $x = JuncInvTest2.new | JuncInvTest2.new;
    $x.b('a' | 'b' | 'c');
    is $cnt2, 6, 'auto-threading over invocant and parameters works';
}

# test that various things autothread

{
    my Mu $j = [1, 2] | 5;

    ok ?( +$j == 5 ), 'prefix:<+> autothreads (1)';
    ok ?( +$j == 2 ), 'prefix:<+> autothreads (2)';
    ok !( +$j == 3 ), 'prefix:<+> autothreads (3)';
}

# this is nothing new, but it's such a cool example for 
# autothreading that I want it to be in the test suite nonetheless ;-)
{
    sub primetest(Int $n) {
        ?(none(2..$n) * any(2..$n) == $n);
    };

    #               2  3  4  5  6  7  8  9  10  11  12  13  14  15
    my @is_prime = (1, 1, 0, 1, 0, 1, 0, 0,  0,  1,  0,  1,  0,  0);

    for @is_prime.kv -> $idx, $ref {
        is +primetest($idx + 2), $ref, "primality test for { $idx + 2 } works";
    }
}


#?pugs skip 'autothreading over array indexing'
{
    my Mu $junc = 0|1|2;
    my @a = (0,1,2);
    my $bool = Bool::False;
    ok ?(@a[$junc] == $junc), 'can autothread over array indexes';
}

# Tests former autothreading junction example from Synopsis 09
{
    my $c = 0;

    is(substr("camel", 0, 2),  "ca", "substr()");

    $c = 0;
    sub my_substr ($str, $i, $j) {
        $c++;
        my @c = split "", $str;
        join("", @c[$i..($i+$j-1)]);
    }

    my $j = my_substr("camel", 0|1, 2&3);

    is($c, 4, "substr() called 4 times");
}

# test autothreading while passing arrays:
{
    sub my_elems(@a) {
        @a.elems;
    }
    ok !(my_elems([2, 3]|[4, 5, 6]) == 1),
       'autothreading over array parameters (0)';
    ok ?(my_elems([2, 3]|[4, 5, 6]) == 2),
       'autothreading over array parameters (1)';
    ok ?(my_elems([2, 3]|[4, 5, 6]) == 3),
       'autothreading over array parameters (2)';
    ok !(my_elems([2, 3]|[4, 5, 6]) == 4),
       'autothreading over array parameters (3)';
}

# L

# block parameters default to Mu, so test that they don't autothread:
{
    my $c = 0;
    for 1|2, 3|4, 5|6 -> $x {
        $c++;
    }
    is $c, 3, 'do not autothread over blocks by default';
}
#?niecza skip 'interferes hard with inlining'
{
    my $c = 0;
    for 1|2, 3|4, 5|6 -> Any $x {
        $c++;
    }
    is $c, 6, 'do autothread over blocks with explicit Any';
}

# used to be RT #75368
# L
{
    my Mu $x = 'a' ne ('a'|'b'|'c');
    ok $x ~~ Bool, 'infix: collapses the junction (1)';
    ok $x !~~ Junction, 'infix: collapses the junction (2)';
    nok $x, '... and the result is False';

    my Mu $y = 'a' !eq ('a'|'b'|'c');
    ok $y ~~ Bool, 'infix: collapses the junction (1)';
    ok $y !~~ Junction, 'infix: collapses the junction (2)';
    nok $y, '... and the result is False';

    my Mu $z = any(1, 2, 3);
    ok  4 != $z, '!= autothreads like not == (1)';
    nok 3 != $z, '!= autothreads like not == (2)';
}

# RT #69863
# autothreading over named-only params
{
    sub foo(Int :$n) { $n }
    ok foo(n => 1|2) ~~ Junction, 'named-only params autothread correctly';
}

# test that junctions doen't flatten ranges
# RT #76422
{
    ok ((1..42) | (8..35)).max == 42, 'infix | does not flatten ranges';
}

# test that the order of junction autothreading is:
# the leftmost all or none junction (if any), then
# the leftmost one or any junction.

{
    sub tp($a, $b, $c) { "$a $b $c" };

    my Mu $res = tp("dog", 1|2, 10&20);
    # should turn into:
    #     all( tp("dog", 1|2, 10),
    #          tp("dog", 1|2, 20))
    #
    # into:
    #     all( any( tp("dog", 1, 10), tp("dog", 2, 10),
    #          any( tp("dog", 1, 20), tp("dog", 2, 20)))
    is $res.Str, q{all(any("dog 1 10", "dog 2 10"), any("dog 1 20", "dog 2 20"))}, "an & junction right of a | junction will be autothreaded first";

    $res = tp("foo"&"bar", 1|2, 0);
    # should turn into:
    #     all( tp("foo", 1|2, 0),
    #          tp("bar", 1|2, 0))
    #
    # into:
    #     all( any( tp("foo", 1, 0), tp("foo", 2, 0)),
    #          any( tp("bar", 1, 0), tp("bar", 2, 0)))
    is $res.Str, q{all(any("foo 1 0", "foo 2 0"), any("bar 1 0", "bar 2 0"))}, "an & junction left of a | junction will be autothreaded first";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-junctions/boolean-context.t0000664000175000017500000001222712224265625021657 0ustar  moritzmoritzuse v6;
use Test;
plan 77;

# L

my Mu $undef = Mu;  $undef.defined();

ok ?any(1..2), 'any(1..2) in boolean context';
ok !(any(0,0)), 'any(0,0) in boolean context';
ok !(one(1..2)), 'one(1..2) in boolean context';
ok ?(1|2), '1|2 in boolean context';
ok !(1^2), '1^2 in boolean context';
ok !($undef|0), 'undef|0 in boolean context';
ok !($undef|$undef), 'undef|undef in boolean context';
ok !($undef), 'undef in boolean context';
ok !(defined $undef), 'defined undef in boolean context';
ok !(all($undef, $undef)), 'all(undef, undef) in boolean context';
ok ?all(1,1), 'all(1,1) in boolean context';
ok !(all(1,$undef)), 'all(1,undef) in boolean context';

ok ?(1 | $undef), '1|undef in boolean context';
ok ?($undef | 1), 'undef|1 in boolean context';
ok !(1 & $undef), '1&undef in boolean context';
ok !($undef & 1), 'undef&1 in boolean context';
ok ?(1 ^ $undef), '1^undef in boolean context';
ok ?($undef ^ 1), 'undef^1 in boolean context';

ok ?(-1 | $undef), '-1|undef in boolean context';
ok ?($undef | -1), 'undef|-1 in boolean context';
ok !(-1 & $undef), '-1&undef in boolean context';
ok !($undef & -1), 'undef&-1 in boolean context';
ok ?(-1 ^ $undef), '-1^undef in boolean context';
ok ?($undef ^ -1), 'undef^-1 in boolean context';

#?DOES 3
{
(1|$undef && pass '1|undef in boolean context') || flunk '1|undef in boolean context';
(1 & $undef && flunk '1&undef in boolean context') || pass '1&undef in boolean context';
(1^$undef && pass '1^undef in boolean context') || flunk '1^undef in boolean context';
}

ok !(0 | $undef), '0|undef in boolean context';
ok !($undef | 0), 'undef|0 in boolean context';
ok !(0 & $undef), '0&undef in boolean context';
ok !($undef & 0), 'undef&0 in boolean context';
ok !(0 ^ $undef), '0^undef in boolean context';
ok !($undef ^ 0), 'undef^0 in boolean context';

{
    (0 | $undef && flunk '0|undef in boolean context') || pass '0|undef in boolean context';
    (0 & $undef && flunk '0&undef in boolean context') || pass '0&undef in boolean context';
    (0 ^ $undef && flunk '0^undef in boolean context') || pass '0^undef in boolean context';
}

my $message1 = 'boolean context collapses Junctions';
my $message2 = '...so that they\'re not Junctions anymore';
ok ?(Bool::True & Bool::False)    ==  Bool::False, $message1;
#?DOES 1
ok ?(Bool::True & Bool::False)    !~~ Junction,    $message2;
ok !(Bool::True & Bool::False)    ==  Bool::True,  $message1;
#?DOES 1
ok !(Bool::True & Bool::False)    !~~ Junction,    $message2;
#?rakudo todo 'named unary as function call'
ok so(Bool::True & Bool::False) ==  Bool::False, $message1;
ok (so Bool::True & Bool::False) !~~ Junction,    $message2;
ok ( not Bool::True & Bool::False)  ==  Bool::True,  $message1;
ok not(Bool::True & Bool::False)  !~~ Junction,    $message2;


ok do if 1 | 2 | 3 == 2 { 1 } else { 0 }, "3x very simple invocation of | and & in if";
ok do if 2 & 2 & 2 == 2 { 1 } else { 0 };
ok do if 2 & 2 & 2 == 3 { 0 } else { 1 };

{
    my $foo = 0;
    sub infix:<|>(*@a) { $foo++; any(|@a) };
    sub infix:<&>(*@a) { $foo++; all(|@a) };
    ok do if 1 | 2 | 3 | 4 == 3 { 1 } else { 0 }, "4x local sub shadows | and &";
    #?niecza todo "Difficulties overloading | and &"
    is $foo, 1;
    ok do if 1 & 2 & 3 & 4 == 3 { 0 } else { 1 };
    #?niecza todo "Difficulties overloading | and &"
    is $foo, 2;
}

{
    my $count = 0;
    sub side-effect() { $count++ };
    ok do if side-effect() == 0 | 1 | 2 | 3 { 1 } else { 0 }, "6x side effect executed only once";
    is $count, 1;
    ok do if side-effect() == any(1, 2, 3) { 1 } else { 0 };
    is $count, 2;
    ok do if 1 | 2 | 3 | 4 == side-effect() { 1 } else { 0 };
    is $count, 3;
    ok do if any(1, 2, 3, 4) == side-effect() { 1 } else { 0 };
    is $count, 4;
}

{
    my $c = 0;
    for (-4..4)X(-4..4) -> $x, $y {
        if $x & $y == -1 | 0 | 1 {
            $c++;
        }
    }
    is $c, 9, "junctions on both sides of a comparison";
}

given 1 {
    when 0 | 1 | 2 {
        ok 1, "2x given + when";
    }
    when 3 | 4 | 5 {
        ok 0;
    }
}

{
    my $ctr = 0;
    while $ctr == 0 | 1 | 2 | 3 | 4 {
        $ctr++;
    }
    is $ctr, 5, "junction and while";
}

ok do if 5 & 6 & 7 <= 10 { 1 } else { 0 }, "using <=";

ok do if 5 < 3 | 5 | 10 { 1 } else { 0 }, "using <";

ok do if 3 & 5 & 6 != 4 { 1 } else { 0 }, "using !=";

ok do if 3 & 5 & 6 <= 5 | 10 { 1 } else { 0 }, "&, <= and |";

ok do if 1 | 2 | 3 <= 3 <= 5 { 1 } else { 0 }, "4x triple-chaining works";
ok do if 1 | 2 | 3 <= 3 <= 2 { 0 } else { 1 };
ok do if 1 <= 1 & 2 & 3 & 4 <= 4 { 1 } else { 0 };
ok do if 1 <= 1 & 2 & 3 & 4 <= 3 { 0 } else { 1 };

{
    my @a = 2, 3;
    ok do if any(1, @a, 4) == 3 { 1 } else { 0 }, "flattening in any works";
    ok do if all(1, @a, 4) <= 4 { 1 } else { 0 }, "flattening in all works";
    ok do if none(1, @a, 4) > 4 { 1 } else { 0 }, "flattening in none works";
}

# RT 117579
{
    ok do if 1 ne 2|3|4 { 1 } else { 0 }, "ne in if context";
    ok do if 1 ne 1|3|4 { 0 } else { 1 }, "ne in if context";

    my $invoc = 0;
    sub infix:(Mu $a, Mu $b) { $invoc++; True };
    ok do if 1 test 2 | 3 | 4 | 5 { 1 } else { 0 }, "custom operator";
    is $invoc, 1, "operator with Mu argument doesn't get autothreaded.";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-junctions/misc.t0000664000175000017500000003041312224265625017506 0ustar  moritzmoritzuse v6;

use Test;

plan 103;

=begin pod

Misc. Junction tests 

=end pod

# RT #64184
{
    isa_ok any(6,7), Junction;
    is any(6,7).WHAT.gist, Junction.gist, 'junction.WHAT works';
}

# avoid auto-threading on ok()
#?DOES 1
sub jok(Mu $condition, $msg?) { ok ?($condition), $msg };

# L
# L
{

    # initialize them all to empty strings
    my $a = '';
    my $b = '';
    my $c = '';
    
    # make sure they all match to an empty string
    jok('' eq ($a & $b & $c), 'junction of ($a & $b & $c) matches an empty string');
    jok('' eq all($a, $b, $c), 'junction of all($a, $b, $c) matches an empty string');   
    
    # give $a a value
    $a = 'a';  
    
    # make sure that at least one of them matches 'a' 
    jok('a' eq ($b | $c | $a), 'junction of ($b | $c | $a) matches at least one "a"');
    jok('a' eq any($b, $c, $a), 'junction of any($b, $c, $a) matches at least one "a"');   

    jok('' eq ($b | $c | $a), 'junction of ($b | $c | $a) matches at least one empty string');
    jok('' eq any($b, $c, $a), 'junction of any($b, $c, $a) matches at least one empty string');
    
    # make sure that ~only~ one of them matches 'a'
    jok('a' eq ($b ^ $c ^ $a), 'junction of ($b ^ $c ^ $a) matches at ~only~ one "a"');
    jok('a' eq one($b, $c, $a), 'junction of one($b, $c, $a) matches at ~only~ one "a"');
    
    # give $b a value
    $b = 'a';
    
    # now this will fail
    jok('a' ne ($b ^ $c ^ $a), 'junction of ($b ^ $c ^ $a) matches at more than one "a"');              

    # change $b and give $c a value
    $b = 'b';
    $c = 'c';
    
    jok('a' eq ($b ^ $c ^ $a), 'junction of ($b ^ $c ^ $a) matches at ~only~ one "a"');
    jok('b' eq ($a ^ $b ^ $c), 'junction of ($a ^ $b ^ $c) matches at ~only~ one "b"');
    jok('c' eq ($c ^ $a ^ $b), 'junction of ($c ^ $a ^ $b) matches at ~only~ one "c"');  

    jok('a' eq ($b | $c | $a), 'junction of ($b | $c | $a) matches at least one "a"');
    jok('b' eq ($a | $b | $c), 'junction of ($a | $b | $c) matches at least one "b"');
    jok('c' eq ($c | $a | $b), 'junction of ($c | $a | $b) matches at least one "c"'); 

    
    # test junction to junction
    jok(('a' | 'b' | 'c') eq ($a & $b & $c), 'junction ("a" | "b" | "c") matches junction ($a & $b & $c)');    
    jok(('a' & 'b' & 'c') eq ($a | $b | $c), 'junction ("a" & "b" & "c") matches junction ($a | $b | $c)'); 
    
    # mix around variables and literals
    
    jok(($a & 'b' & 'c') eq ('a' | $b | $c), 'junction ($a & "b" & "c") matches junction ("a" | $b | $c)');              
    jok(($a & 'b' & $c) eq ('a' | $b | 'c'), 'junction ($a & "b" & $c) matches junction ("a" | $b | "c")');              
    
}

# same tests, but with junctions as variables
{
        # initialize them all to empty strings
    my $a = '';
    my $b = '';
    my $c = '';
    
    my Mu $all_of_them = $a & $b & $c;
    jok('' eq $all_of_them, 'junction variable of ($a & $b & $c) matches and empty string');
    
    $a = 'a';  
    
    my Mu $any_of_them = $b | $c | $a;
    jok('a' eq $any_of_them, 'junction variable of ($b | $c | $a) matches at least one "a"');  
    jok('' eq $any_of_them, 'junction variable of ($b | $c | $a) matches at least one empty string');
    
    my Mu $one_of_them = $b ^ $c ^ $a;
    jok('a' eq $one_of_them, 'junction variable of ($b ^ $c ^ $a) matches at ~only~ one "a"');
    
    $b = 'a';
    
    {
        my Mu $one_of_them = $b ^ $c ^ $a;
        jok('a' ne $one_of_them, 'junction variable of ($b ^ $c ^ $a) matches at more than one "a"');              
    }
    
    $b = 'b';
    $c = 'c';
    
    {
        my Mu $one_of_them = $b ^ $c ^ $a;    
        jok('a' eq $one_of_them, 'junction of ($b ^ $c ^ $a) matches at ~only~ one "a"');
        jok('b' eq $one_of_them, 'junction of ($a ^ $b ^ $c) matches at ~only~ one "b"');
        jok('c' eq $one_of_them, 'junction of ($c ^ $a ^ $b) matches at ~only~ one "c"');  
    }

    {
        my Mu $any_of_them = $b | $c | $a;
        jok('a' eq $any_of_them, 'junction of ($b | $c | $a) matches at least one "a"');
        jok('b' eq $any_of_them, 'junction of ($a | $b | $c) matches at least one "b"');
        jok('c' eq $any_of_them, 'junction of ($c | $a | $b) matches at least one "c"'); 
    }

}

{
    my Mu $j = 1 | 2;
    $j = 5;
    is($j, 5, 'reassignment of junction variable');
}

{
    my Mu $j;
    my Mu $k;

    $j = 1|2;
    #?rakudo 2 todo 'lower case junction type'
    is(WHAT($j).gist, '(Junction)', 'basic junction type reference test');

    $k=$j;
    is(WHAT($k).gist, '(Junction)', 'assignment preserves reference');
}


=begin description

Tests junction examples from Synopsis 03 

j() is used to convert a junction to canonical string form, currently
just using .perl until a better approach presents itself.

=end description

# L

# Canonical stringification of a junction
sub j (Mu $j) { return $j.perl }

{
    # L
    my Mu $got;
    my Mu $want;
    $got = ((1|2|3)+4);
    $want = (5|6|7);
    is( j($got), j($want), 'thread + returning junctive result');

    $got = ((1|2) + (3&4));
    $want = ((4|5) & (5|6));
    is( j($got), j($want), 'thread + returning junctive combination of results');

    # L
    # unless $roll == any(1..6) { print "Invalid roll" }
    my $roll;
    my $note;
    $roll = 3; $note = '';
    unless $roll == any(1..6) { $note = "Invalid roll"; };
    is($note, "", 'any() junction threading ==');

    $roll = 7; $note = '';
    unless $roll == any(1..6) { $note = "Invalid roll"; };
    is($note, "Invalid roll", 'any() junction threading ==');

    # if $roll == 1|2|3 { print "Low roll" }
    $roll = 4; $note = '';
    if $roll == 1|2|3 { $note = "Low roll" }
    is($note, "", '| junction threading ==');

    $roll = 2; $note = '';
    if $roll == 1|2|3 { $note = "Low roll" }
    is($note, "Low roll", '| junction threading ==');
}

{
    # L
    my $got;
    my @foo;
    $got = ''; @foo = ();
    $got ~= 'y' if try { @foo[any(1,2,3)] };
    is($got, '', "junctions work through subscripting, 0 matches");

    $got = ''; @foo = (0,1);
    $got ~= 'y' if try { @foo[any(1,2,3)] };
    is($got, 'y', "junctions work through subscripting, 1 match");

    $got = ''; @foo = (1,1,1);
    $got ~= 'y' if try { @foo[any(1,2,3)] };
    is($got, 'y', "junctions work through subscripting, 3 matches");


    # L
    # Compiler *can* reorder and parallelize but *may not* so don't test
    # for all(@foo) {...};  

    # Not sure what is expected
    #my %got = ('1' => 1); # Hashes are unordered too
    #@foo = (2,3,4);
    #for all(@foo) { %got{$_} = 1; };
    #is( %got.keys.sort.join(','), '1,2,3,4',
    #    'for all(...) { ...} as parallelizable');
}

=begin description

These are implemented but still awaiting clarification on p6l.

 On Fri, 2005-02-11 at 10:46 +1100, Damian Conway wrote:
 > Subject: Re: Fwd: Junctive puzzles.
 >
 > Junctions have an associated boolean predicate that's preserved across 
 > operations on the junction. Junctions also implicitly distribute across 
 > operations, and rejunctify the results.

=end description

# L

{
    my @subs = (sub {3}, sub {2});

    my Mu $got;
    my Mu $want;

    is(j(any(@subs)()), j(3|2), '.() on any() junction of subs');

    $want = (3&2);
    $got = all(@subs)();
    is(j($got), j($want), '.() on all() junction of subs');

    $want = (3^2);
    $got = one(@subs)();
    is(j($got), j($want), '.() on one() junction of subs');

    $want = none(3,2);
    $got = none(@subs)();
    is(j($got), j($want), '.() on none() junction of subs');

    $want = one( any(3,2), all(3,2) );
    $got = one( any(@subs), all(@subs) )();
    is(j($got), j($want), '.() on complex junction of subs');

    # Avoid future constant folding
    #my $rand = rand;
    #my $zero = int($rand-$rand);
    #my @subs = (sub {3+$zero}, sub {2+$zero});
}

# Check functional and operator versions produce the same structure
{
    is(j((1|2)^(3&4)), j(one(any(1,2),all(3,4))),
        '((1|2)^(3&4)) equiv to one(any(1,2),all(3,4))');

    is(j((1|2)&(3&4)), j(all(any(1,2),all(3,4))), 
        '((1|2)&(3&4)) equiv to all(any(1,2),all(3,4))');

    is(j((1|2)|(3&4)), j(any(any(1,2),all(3,4))),
        '((1|2)|(3&4)) equiv to any(any(1,2),all(3,4))');
}

# junction in boolean context
ok(?(0&0) == ?(0&&0), 'boolean context');
ok(?(0&1) == ?(0&&1), 'boolean context');
ok(?(1&1) == ?(1&&1), 'boolean context');
ok(?(1&0) == ?(1&&0), 'boolean context');
ok(!(?(0&0) != ?(0&&0)), 'boolean context');
ok(!(?(0&1) != ?(0&&1)), 'boolean context');
ok(!(?(1&1) != ?(1&&1)), 'boolean context');
ok(!(?(1&0) != ?(1&&0)), 'boolean context');


{
    my $c = 0;
    if 1 == 1 { $c++ }
    is $c, 1;
    if 1 == 1|2 { $c++ }
    is $c, 2;
    if 1 == 1|2|3 { $c++ }
    is $c, 3;

    $c++ if 1 == 1;
    is $c, 4;
    $c++ if 1 == 1|2;
    is $c, 5, 'if modifier with junction should be called once';

    $c = 0;
    $c++ if 1 == 1|2|3;
    is $c, 1, 'if modifier with junction should be called once';

    $c = 0;
    $c++ if 1 == any(1, 2, 3);
    is $c, 1, 'if modifier with junction should be called once';
}

{
    my @array = <1 2 3 4 5 6 7 8>;
    jok( all(@array) == one(@array), "all(@x) == one(@x) tests uniqueness(+ve)" );

    push @array, 6;
    jok( !( all(@array) == one(@array) ), "all(@x) == one(@x) tests uniqueness(-ve)" );

}

# used to be a rakudo regression (RT #60886)
ok Mu & Mu ~~ Mu, 'Mu & Mu ~~ Mu works';

## See also S03-junctions/autothreading.t
{
  is substr("abcd", 1, 2), "bc", "simple substr";
  my Mu $res = substr(any("abcd", "efgh"), 1, 2);
  isa_ok $res, Junction;
  ok $res eq "bc", "substr on junctions: bc";
  ok $res eq "fg", "substr on junctions: fg";
}

{
  my Mu $res = substr("abcd", 1|2, 2);
  isa_ok $res, Junction;
  ok $res eq "bc", "substr on junctions: bc"; 
  ok $res eq "cd", "substr on junctions: cd";
}

{
  my Mu $res = substr("abcd", 1, 1|2);
  isa_ok $res, Junction;
  ok $res eq "bc", "substr on junctions: bc"; 
  ok $res eq "b", "substr on junctions: b"; 
}

{
  my Mu $res = index(any("abcd", "qwebdd"), "b");
  isa_ok $res, Junction;
  ok $res == 1, "index on junctions: 1";
  ok $res == 3, "index on junctions: 3";
}

{
  my Mu $res = index("qwebdd", "b"|"w");
  isa_ok $res, Junction;
  ok $res == 1, "index on junctions: 1";
  ok $res == 3, "index on junctions: 3";
}

# RT #63686
{
    lives_ok { try { for any(1,2) -> $x {}; } },
             'for loop over junction in try block';

    sub rt63686 {
        for any(1,2) -> $x {};    #OK not used
        return 'happiness';
    }
    is rt63686(), 'happiness', 'for loop over junction in sub';
}

# RT#67866: [BUG] [LHF] Error with stringifying .WHAT on any junctions
#?rakudo skip 'lower case junction'
#?niecza skip 'Impossible test: === takes Any'
{
    ok((WHAT any()) === Junction, "test WHAT on empty any junction");
    ok(any().WHAT === Junction, "test WHAT on empty any junction");
    ok((WHAT any(1,2)) === Junction, "test WHAT on any junction");
    ok(any(1,2).WHAT === Junction, "test WHAT on any junction");
}

# Any list has junction methods
{
    jok(5 < (6,7,8).all, '.all method builds "all" junction');
    jok(!(7 < (6,7,8).all), '.all method builds "all" junction');
    jok(7 == (6,7,8).one, '.one method builds "one" junction');
    jok(9 == (6,7,8).none, '.none method builds "none" junction');

    my @x = (6,7,8);
    jok(5 < @x.all, '.all method works on array objects');
}

# RT #63126
#?rakudo todo 'nom regression'
#?DOES 2
{
    my @a = "foo", "foot";
    ok @a[all(0,1)] ~~ /^foo/,
        'junction can be used to index Array';

    my %h = (
        "0" => "foo",
        "1" => "foot"
    );
    ok %h{all(0,1)} ~~ /^foo/,
        'junction can be used to index Hash';
}

# stringy tests
#?niecza todo '#82'
{
   my class Foo {
      multi method gist(Foo:D:) { "gisted"; }
      multi method perl(Foo:D:) { "perled"; }
      multi method Str(Foo:D:) { "Stred"; }
   }
   is any(Foo.new).perl, 'any(perled)', 'any(Foo.new).perl';
   is any(Foo.new).gist, 'any(gisted)', 'any(Foo.new).gist';
}

# RT #109188
ok { a => 1} ~~ List|Hash, 'Can construct junction with List type object';

# RT #112392
ok (1|2).Str ~~ Str, 'Junction.Str returns a Str, not a Junction';

done();

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/cross.t0000664000175000017500000000652412237474612017350 0ustar  moritzmoritzuse v6;

use Test;
plan 28;

# L
ok eval(' X '), 'cross non-meta operator parses';

{
    my @result =  X <1 2>;
    is @result, ,
    'non-meta cross produces expected result';

}

is (1, 2, 3 X** 2, 4), (1, 1, 4, 16, 9, 81), 'X** works';

is ([+] 1, 2, 3 X** 2, 4), (1+1 + 4+16 + 9+81), '[+] and X** work';

# L
{
    my @result = gather {
        for @(1..3 X 'a'..'b') -> $n, $a {
            take "$n|$a"
        }
    }
    is @result, <1|a 1|b 2|a 2|b 3|a 3|b>, 'smooth cross operator works';
}

# L
#?rakudo skip ".slice for iterators NYI"
#?niecza skip 'Unable to resolve method slice in class List'
{
    my @result = gather for (1..3 X 'A'..'B').slice -> $na {
        take $na.join(':');
    }
    is @result, <1:A 1:B 2:A 2:B 3:A 3:B>, 'chunky cross operator works';
}

# L
ok eval(' X, '), 'cross metaoperator parses';

# L
#?pugs todo 'feature'
{
    my @result =  X~ <1 2>;
    is @result, ,
        'cross-concat produces expected result';
}

# L
{
    my @result =  X, 1,2 X, ;
    is @result.elems, 24, 'chained cross-comma produces correct number of elements';

    my @expected = (
        ['a', 1, 'x'],
        ['a', 1, 'y'],
        ['a', 2, 'x'],
        ['a', 2, 'y'],
        ['b', 1, 'x'],
        ['b', 1, 'y'],
        ['b', 2, 'x'],
        ['b', 2, 'y'],
    );
    is @result, @expected, 'chained cross-comma produces correct results';
}

# L
is (1,2 X* 3,4), (3,4,6,8), 'cross-product works';

is (1,2 Xcmp 3,2,0), (Order::Less, Order::Less, Order::More, Order::Less, Order::Same, Order::More), 'Xcmp works';

# L
eval_dies_ok '@result Xcmp @expected Xcmp <1 2>',
    'non-associating ops cannot be cross-ops';

# let's have some fun with X..., comparison ops and junctions:

{
    ok ( ? all 1, 2 X<= 2, 3, 4 ), 'all @list1 X<= @list2';
    ok ( ? [|] 1, 2 X<= 0, 3),     '[|] @l1 X<= @l2';
    ok ( ! all 1, 2 X<  2, 3),     'all @l1 X<  @l2';
    ok ( ? one 1, 2 X== 2, 3, 4),  'one @l1 X== @l2';
    ok ( ! one 1, 2 X== 2, 1, 4),  'one @l1 X== @l2';
}

{
    my ($a, $b, $c, $d);
    # test that the containers on the LHS are mutually exclusive from
    # those on the RHS
    ok ( ? all $a, $b X!=:= $c, $d ), 'X!=:= (1)';
    ok ( ? all $a, $a X!=:= $c, $d ), 'X!=:= (2)';
    #?rakudo todo 'huh?'
    ok ( ! all $a, $b X!=:= $c, $b ), 'X!=:= (3)';
    $c := $b;
    #?rakudo todo 'huh?'
    ok ( ? one $a, $b X=:=  $c, $d ), 'one X=:=';
}

# tests for non-list arguments
is (1 X* 3,4), (3, 4), 'cross-product works with scalar left side';
is (1, 2 X* 3), (3, 6), 'cross-product works with scalar right side';
is (1 X* 3), (3), 'cross-product works with scalar both sides';

is ( X  X < e f>).join(','),
    'a,c,e,a,c,f,a,d,e,a,d,f,b,c,e,b,c,f,b,d,e,b,d,f',
    'cross works with three lists';

#?rakudo todo 'RT 74072'
#?niecza todo
is ([1,2] X~ ), '1 2a1 2b', '[] does not flatten';

is (1,2 X (  X "x")).join, '1a1x1b1x2a2x2b2x',
    'Nested X works';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/eager-hyper.t0000664000175000017500000000246512224265625020425 0ustar  moritzmoritzuse v6;

use Test;

plan 8;

# L

# Laziness test
{
    my $counter = 0;
    my @test = gather { for 1 .. 5 { $counter++; take $_ } };
    is(@test[0], 1, 'iterator works as expected');
    #?rakudo todo "Array assignment is not lazy -- is this test wrong?"
    #?pugs todo
    is($counter, 1, 'iterator was lazy and only ran the block once');
}

# "Counting the elements in the array will also force eager completion."
{
    my $counter = 0;
    my @test = gather { for 1 .. 5 { $counter++; take $_ } };
    is(@test.elems, 5, 'iterator has expected length');
    is($counter, 5, 'iterator was lazy and only ran the block once');
}

# Eager
{
    my $counter = 0;
    my @test = eager gather { for 1 .. 5 { $counter++; take $_ } };
    is(@test[0], 1, 'iterator works as expected');
    is($counter, 5, 'iterator was eager and calculated all the values');
}

# L
# Hyper
#?rakudo skip 'hyper prefix NYI'
#?pugs skip   'hyper prefix NYI'
{
    my $counter = 0;
    my @test = hyper gather { for 1 .. 5 { $counter++; take $_; } };
    is(sort @test, <1 2 3 4 5>, 'hyper returned all the values in some order');
    is($counter, 5, 'iterator was hyper and calculated all the values');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/hyper.t0000664000175000017500000006725112241704255017344 0ustar  moritzmoritzuse v6;

use Test;

plan 281;

=begin pod

 Hyper operators L

=end pod

# L
 # binary infix
my @r;
my @e;
{
        @r = (1, 2, 3) »+« (2, 4, 6);
        @e = (3, 6, 9);
        is(~@r, ~@e, "hyper-sum two arrays");

        @r = (1, 2, 3) »-« (2, 4, 6);
        @e = (-1, -2, -3);
        is(~@r, ~@e, "hyper-subtract two arrays");

        @r = (1, 2, 3) »*« (2, 4, 6);
        @e = (2, 8, 18);
        is(~@r, ~@e, "hyper-multiply two arrays");

        @r = (1, 2, 3) »x« (3, 2, 1);
        @e = ('111', '22', '3');
        is(~@r, ~@e, "hyper-x two arrays");

        @r = (1, 2, 3) »xx« (3, 2, 1);
        @e = ((1,1,1), (2,2), (3));
        is(~@r, ~@e, "hyper-xx two arrays");

        @r = (20, 40, 60) »div« (2, 5, 10);
        @e = (10, 8, 6);
        is(~@r, ~@e, "hyper-divide two arrays");

        @r = (1, 2, 3) »+« (10, 20, 30) »*« (2, 3, 4);
        @e = (21, 62, 123);
        is(~@r, ~@e, "precedence - »+« vs »*«");
}

{
        @r = (1, 2, 3) >>+<< (2, 4, 6);
        @e = (3, 6, 9);
        is(~@r, ~@e, "hyper-sum two arrays ASCII notation");

        @r = (1, 2, 3) >>-<< (2, 4, 6);
        @e = (-1, -2, -3);
        is(~@r, ~@e, "hyper-subtract two arrays ASCII notation");

        @r = (1, 2, 3) >>*<< (2, 4, 6);
        @e = (2, 8, 18);
        is(~@r, ~@e, "hyper-multiply two arrays ASCII notation");

        @r = (1, 2, 3) >>x<< (3, 2, 1);
        @e = ('111', '22', '3');
        is(~@r, ~@e, "hyper-x two arrays ASCII notation");

        @r = (1, 2, 3) >>xx<< (3, 2, 1);
        @e = ((1,1,1), (2,2), (3));
        is(~@r, ~@e, "hyper-xx two arrays ASCII notation");

        @r = (20, 40, 60) >>div<< (2, 5, 10);
        @e = (10, 8, 6);
        is(~@r, ~@e, "hyper-divide two arrays ASCII notation");

        @r = (1, 2, 3) >>+<< (10, 20, 30) >>*<< (2, 3, 4);
        @e = (21, 62, 123);
        is(~@r, ~@e, "precedence - >>+<< vs >>*<< ASCII notation");
};

{ # unary postfix
        my @r = (1, 2, 3);
        @r»++;
        my @e = (2, 3, 4);
        #?pugs todo
        is(~@r, ~@e, "hyper auto increment an array");

        @r = (1, 2, 3);
        @r>>++;
        @e = (2, 3, 4);
        #?pugs todo
        is(~@r, ~@e, "hyper auto increment an array ASCII notation");
};

{ # unary prefix
        my @r;
        @r = -« (3, 2, 1);
        my @e = (-3, -2, -1);
        is(~@r, ~@e, "hyper op on assignment/pipeline");

        @r = -<< (3, 2, 1);
        @e = (-3, -2, -1);
        is(~@r, ~@e, "hyper op on assignment/pipeline ASCII notation");
};

{ # dimension upgrade - ASCII
        my @r;
        @r = (1, 2, 3) >>+>> 1;
        my @e = (2, 3, 4);
        is(~@r, ~@e, "auto dimension upgrade on rhs ASCII notation");

        @r = 2 <<*<< (10, 20, 30);
        @e = (20, 40, 60);
        is(~@r, ~@e, "auto dimension upgrade on lhs ASCII notation");
}

{ # extension
        @r = (1,2,3,4) >>~>> ;
        @e = <1A 2B 3C 4D>;
        is(~@r, ~@e, "list-level element truncate on rhs ASCII notation");

        @r = (1,2,3,4,5) <<~<< ;
        @e =  <1A 2B 3C 4D>;
        is(~@r, ~@e, "list-level element truncate on lhs ASCII notation");

        @r = (1,2,3,4) >>~>> ;
        @e = <1A 2B 3C 4A>;
        is(~@r, ~@e, "list-level element extension on rhs ASCII notation");

        @r = (1,2,3) <<~<< ;
        @e =  <1A 2B 3C 1D>;
        is(~@r, ~@e, "list-level element extension on lhs ASCII notation");

        @r = (1,2,3,4) >>~>> ;
        @e = <1A 2B 3A 4B>;
        is(~@r, ~@e, "list-level element extension on rhs ASCII notation");
        
        @r = (1,2) <<~<< ;
        @e =  <1A 2B 1C 2D>;
        is(~@r, ~@e, "list-level element extension on lhs ASCII notation");
         
        @r = (1,2,3,4) >>~>> ;
        @e = <1A 2A 3A 4A>;
        is(~@r, ~@e, "list-level element extension on rhs ASCII notation");
        
        @r = (1,) <<~<< ;
        @e = <1A 1B 1C 1D>;
        is(~@r, ~@e, "list-level element extension on lhs ASCII notation");

        @r = (1,2,3,4) >>~>> 'A';
        @e = <1A 2A 3A 4A>;
        is(~@r, ~@e, "scalar element extension on rhs ASCII notation");

        @r = 1 <<~<< ;
        @e = <1A 1B 1C 1D>;
        is(~@r, ~@e, "scalar element extension on lhs ASCII notation");
};

{ # dimension upgrade - unicode
        @r = (1,2,3,4) »~» ;
        @e = <1A 2B 3C 4D>;
        is(~@r, ~@e, "list-level element truncate on rhs unicode notation");

        @r = (1,2,3,4,5) «~« ;
        @e =  <1A 2B 3C 4D>;
        is(~@r, ~@e, "list-level element truncate on lhs unicode notation");

        @r = (1,2,3,4) »~» ;
        @e = <1A 2B 3C 4A>;
        is(~@r, ~@e, "list-level element extension on rhs unicode notation");

        @r = (1,2,3) «~« ;
        @e =  <1A 2B 3C 1D>;
        is(~@r, ~@e, "list-level element extension on lhs unicode notation");

        @r = (1,2,3,4) »~» ;
        @e = <1A 2B 3A 4B>;
        is(~@r, ~@e, "list-level element extension on rhs unicode notation");

        @r = (1,2) «~« ;
        @e =  <1A 2B 1C 2D>;
        is(~@r, ~@e, "list-level element extension on lhs unicode notation");
 
        @r = (1,2,3,4) »~» ;
        @e = <1A 2A 3A 4A>;
        is(~@r, ~@e, "list-level element extension on rhs unicode notation");

        @r = (1,) «~« ;
        @e = <1A 1B 1C 1D>;
        is(~@r, ~@e, "list-level element extension on lhs unicode notation");

        @r = (1,2,3,4) »~» 'A';
        @e = <1A 2A 3A 4A>;
        is(~@r, ~@e, "scalar element extension on rhs unicode notation");

        @r = 1 «~« ;
        @e = <1A 1B 1C 1D>;
        is(~@r, ~@e, "scalar element extension on lhs unicode notation");
};

{ # unary postfix with integers
        my @r;
        @r = (1, 4, 9)».sqrt;
        my @e = (1, 2, 3);
        is(~@r, ~@e, "method call on integer list elements");

        @r = (1, 4, 9)>>.sqrt;
        @e = (1, 2, 3);
        is(~@r, ~@e, "method call on integer list elements (ASCII)");
}

{
        my (@r, @e);
        (@r = (1, 4, 9))»++;
        @e = (2, 5, 10);
        is(~@r, ~@e, "operator call on integer list elements");
}

{
        my (@r, @e);
        (@r = (1, 4, 9))»++;
        @e = (2, 5, 10);
        is(~@r, ~@e, "operator call on integer list elements");

        (@r = (1, 4, 9)).»++;
        is(~@r, ~@e, "operator call on integer list elements (Same thing, dot form)");
}

#?rakudo skip 'huh?'
{
        my (@r, @e);
        (@r = (1, 4, 9))».++;
        @e = (2, 5, 10);
        is(~@r, ~@e, "operator call on integer list elements (Same thing, dot form)");

        (@r = (1, 4, 9)).».++;
        is(~@r, ~@e, "operator call on integer list elements (Same thing, dot form)");

        (@r = (1, 4, 9))\  .»\  .++;
        @e = (2, 5, 10);
        is(~@r, ~@e, "operator call on integer list elements (Same thing, upspace form)");
};

# postfix forms
{ # unary postfix again, but with a twist
        my @r;
        @r = ("f", "oo", "bar")».chars;
        my @e = (1, 2, 3);
        is(~@r, ~@e, "method call on list elements");

        @r = ("f", "oo", "bar").».chars;
        @e = (1, 2, 3);
        is(~@r, ~@e, "method call on list elements (Same thing, dot form)");


        @r = ("f", "oo", "bar")>>.chars;
        @e = (1, 2, 3);
        is(~@r, ~@e, "method call on list elements (ASCII)");

        # RT #74890 analogue
        @r = ("f", "oo", "bar").>>.chars;
        @e = (1, 2, 3);
        is(~@r, ~@e, "method call on list elements (ASCII, Same thing, dot form)");

};

{ # unary postfix on a user-defined object
	my $t;
	class FooTest { method bar { 42 } }; $t = FooTest.new.bar;
	is($t, 42, 'plain method call works OK');

        my @r;
	class FooTest2 { method bar { 42 } }; @r = (FooTest2.new)>>.bar;
	my @e = (42);
	is(~@r, ~@e, "hyper-method-call on list of user-defined objects");
};

{ # distribution for unary prefix
        my @r;
        @r = -« ([1, 2], [3, [4, 5]]);
        my @e = ([-1, -2], [-3, [-4, -5]]);
        is(~@r, ~@e, "distribution for unary prefix");
        is_deeply(@r, @e, "distribution for unary prefix, deep comparison");

        @r = -<< ([1, 2], [3, [4, 5]]);
        @e = ([-1, -2], [-3, [-4, -5]]);
        is(~@r, ~@e, "distribution for unary prefix, ASCII");
        is_deeply(@r, @e, "distribution for unary prefix, ASCII, deep comparison");
};

{ # distribution for unary postfix autoincrement
        my @r;
        @r = ([1, 2], [3, [4, 5]]);
        @r»++;
        my @e = ([2, 3], [4, [5, 6]]);
        #?pugs todo
        is(~@r, ~@e, "distribution for unary postfix autoincr");
        is_deeply(@r, @e, "distribution for unary postfix autoincr, deep comparison");

        @r = ([1, 2], [3, [4, 5]]);
        @r>>++;
        @e = ([2, 3], [4, [5, 6]]);
        #?pugs todo
        is(~@r, ~@e, "distribution for unary postfix autoincr, ASCII");
        is_deeply(@r, @e, "distribution for unary postfix autoincr, ASCII, deep comparison");
};

#?DOES 3
{ # distribution for binary infix - ASCII
        my @r;
        @r = (1, 2, [3, 4]) >>+<< (4, 5, [6, 7]);
        my @e = (5, 7, [9, 11]);
        is(~@r, ~@e, "distribution for binary infix, same shape, ASCII");
        is_deeply(@r, @e, "distribution for binary infix, same shape, ASCII, deep comparison");

        @r = (1, 2, [3, 4]) >>+>> (5, 6, 7);
        @e = (6, 8, [10, 11]);
        is(~@r, ~@e, "distribution for binary infix, dimension upgrade, ASCII");
        is_deeply(@r, @e, "distribution for binary infix, dimension upgrade, ASCII, deep comparison");

        @r = ([1, 2], 3) <<+>> (4, [5, 6]);
        @e = ([5, 6], [8, 9]);
        is(~@r, ~@e, "distribution for binary infix, S03 cross-upgrade, ASCII");
        is_deeply(@r, @e, "distribution for binary infix, S03 cross-upgrade, ASCII, deep comparison");
};

#?DOES 3
{ # distribution for binary infix - unicode
        my @r;
        @r = (1, 2, [3, 4]) »+« (4, 5, [6, 7]);
        my @e = (5, 7, [9, 11]);
        is(~@r, ~@e, "distribution for binary infix, same shape");
        is_deeply(@r, @e, "distribution for binary infix, same shape, deep comparison");

        @r = (1, 2, [3, 4]) »+» (5, 6, 7);
        @e = (6, 8, [10, 11]);
        is(~@r, ~@e, "distribution for binary infix, dimension upgrade");
        is_deeply(@r, @e, "distribution for binary infix, dimension upgrade, deep comparison");

        @r = ([1, 2], 3) «+» (4, [5, 6]);
        @e = ([5, 6], [8, 9]);
        is(~@r, ~@e, "distribution for binary infix, S03 cross-upgrade");
        is_deeply(@r, @e, "distribution for binary infix, S03 cross-upgrade, deep comparison");
};

{ # regression test, ensure that hyper works on arrays
        my @r1;
        my @r2;
        my @e1 = (2, 4, 6);
        my @a = (1, 2, 3);
        @r1 = @a >>+<< @a;
        is(~@r1, ~@e1, "hyper op works on variables, too.");
}
{
        my @a = (1, 2, 3);
        my @e2 = (2, 3, 4);
        my @r2 = @a >>+>> 1;
        is(~@r2, ~@e2, "hyper op and correctly promotes scalars");
};


# mixed hyper and reduce metaops -
# this unveils a spec bug as << recurses into arrays and [+] never gets applied,
# so we disable the entire chunk for now.
=begin todo_unspecced

    is ~([+]<< ([1,2,3], [4,5,6])), "6 15", "mixed hyper and reduce metaop ([+]<<) works";
    ## XXX: Test for [+]<<<< - This is unspecced, commenting it out
    #is ~([+]<<<< ([[1,2],[3,4]],[[5,6],[7,8]])), "3 7 11 15",
    #  "mixed double hyper and reduce metaop ([+]<<<<) works";

    is ~([+]« [1,2,3], [4,5,6]), "6 15",
      "mixed Unicode hyper and reduce metaop ([+]«) works";

=end todo_unspecced

#?pugs todo 'hyper ops'
#?niecza skip 'does not work; recurses into hash'
#?rakudo skip 'nom regression: possible spec change/improvement'
#?DOES 2
{ # hyper dereferencing
    my @array = (
        { key => 'val' },
        { key => 'val' },
        { key => 'val' }
    );

    my $full = join '', eval '@array>>.';
    is($full, 'valvalval', 'hyper-dereference an array');

    my $part = join '', eval '@array[0,1]>>.';
    is($part, 'valval', 'hyper-dereference an array slice');
}

#?pugs todo 'feature'
#?DOES 4
{ # junction hyper -- regression?
    my @a = 1..3;
    my @b = 4..6;
    ok ?(@a »|« @b), '»|« hyperjunction evals';
    ok ?(@a >>|<< @b), '>>|<< hyperjunction evals, ASCII';
    ok ?(@a »&« @b), '»&« hyperjunction evals';
    ok ?(@a >>&<< @b), '>>&<< hyperjunction evals, ASCII';
}

# test hypers on hashes
{
    my %a = a => 1, b => 2, c => 3;
    my %b = a => 5, b => 6, c => 7;
    my %c = a => 1, b => 2;
    my %d = a => 5, b => 6;

    my %r;
    %r = %a >>+<< %b;
    is +%r,   3,  'hash - >>+<< result has right number of keys (same keys)';
    is %r, 6,  'hash - correct result from >>+<< (same keys)';
    is %r, 8,  'hash - correct result from >>+<< (same keys)';
    is %r, 10, 'hash - correct result from >>+<< (same keys)';

    %r = %a »+« %d;
    is +%r,   3, 'hash - »+« result has right number of keys (union test)';
    is %r, 6, 'hash - correct result from »+« (union test)';
    is %r, 8, 'hash - correct result from »+« (union test)';
    is %r, 3, 'hash - correct result from »+« (union test)';

    %r = %c >>+<< %b;
    is +%r,   3, 'hash - >>+<< result has right number of keys (union test)';
    is %r, 6, 'hash - correct result from >>+<< (union test)';
    is %r, 8, 'hash - correct result from >>+<< (union test)';
    is %r, 7, 'hash - correct result from >>+<< (union test)';

    %r = %a <<+>> %b;
    is +%r,   3,  'hash - <<+>> result has right number of keys (same keys)';
    is %r, 6,  'hash - correct result from <<+>> (same keys)';
    is %r, 8,  'hash - correct result from <<+>> (same keys)';
    is %r, 10, 'hash - correct result from <<+>> (same keys)';

    %r = %a <<+>> %d;
    is +%r,   2, 'hash - <<+>> result has right number of keys (intersection test)';
    is %r, 6, 'hash - correct result from <<+>> (intersection test)';
    is %r, 8, 'hash - correct result from <<+>> (intersection test)';

    %r = %c <<+>> %b;
    is +%r,   2, 'hash - <<+>> result has right number of keys (intersection test)';
    is %r, 6, 'hash - correct result from <<+>> (intersection test)';
    is %r, 8, 'hash - correct result from <<+>> (intersection test)';

    %r = %a >>+>> %c;
    is +%r,   3, 'hash - >>+>> result has right number of keys';
    is %r, 2, 'hash - correct result from >>+>>';
    is %r, 4, 'hash - correct result from >>+>>';
    is %r, 3, 'hash - correct result from >>+>>';

    %r = %c >>+>> %b;
    is +%r,   2, 'hash - >>+>> result has right number of keys';
    is %r, 6, 'hash - correct result from >>+>>';
    is %r, 8, 'hash - correct result from >>+>>';

    %r = %c <<+<< %a;
    is +%r,   3, 'hash - <<+<< result has right number of keys';
    is %r, 2, 'hash - correct result from <<+<<';
    is %r, 4, 'hash - correct result from <<+<<';
    is %r, 3, 'hash - correct result from <<+<<';

    %r = %b <<+<< %c;
    is +%r,   2, 'hash - <<+<< result has right number of keys';
    is %r, 6, 'hash - correct result from <<+<<';
    is %r, 8, 'hash - correct result from <<+<<';
}

{
    my %a = a => 1, b => 2, c => 3;
    my %r = -<<%a;
    is +%r,   3, 'hash - -<< result has right number of keys';
    is %r, -1, 'hash - correct result from -<<';
    is %r, -2, 'hash - correct result from -<<';
    is %r, -3, 'hash - correct result from -<<';
    
    %r = --<<%a;
    is +%r,   3, 'hash - --<< result has right number of keys';
    is %r, 0, 'hash - correct result from --<<';
    is %r, 1, 'hash - correct result from --<<';
    is %r, 2, 'hash - correct result from --<<';
    is +%a,   3, 'hash - --<< result has right number of keys';
    is %a, 0, 'hash - correct result from --<<';
    is %a, 1, 'hash - correct result from --<<';
    is %a, 2, 'hash - correct result from --<<';
    
    %r = %a>>++;
    is +%r,   3, 'hash - >>++ result has right number of keys';
    is %r, 0, 'hash - correct result from >>++';
    is %r, 1, 'hash - correct result from >>++';
    is %r, 2, 'hash - correct result from >>++';
    is +%a,   3, 'hash - >>++ result has right number of keys';
    is %a, 1, 'hash - correct result from >>++';
    is %a, 2, 'hash - correct result from >>++';
    is %a, 3, 'hash - correct result from >>++';
}

#?DOES 4
{
    our sub postfix:($a) {
        [*] 1..$a;
    }

    my %a = a => 1, b => 2, c => 3;
    my %r = %a>>!;
    is +%r,   3, 'hash - >>! result has right number of keys';
    is %r, 1, 'hash - correct result from >>!';
    is %r, 2, 'hash - correct result from >>!';
    is %r, 6, 'hash - correct result from >>!';
}

{
    my %a = a => 1, b => 2, c => 3;

    my %r = %a >>*>> 4;
    is +%r,   3, 'hash - >>*>> result has right number of keys';
    is %r, 4, 'hash - correct result from >>*>>';
    is %r, 8, 'hash - correct result from >>*>>';
    is %r, 12, 'hash - correct result from >>*>>';
    
    %r = 2 <<**<< %a ;
    is +%r,   3, 'hash - <<**<< result has right number of keys';
    is %r, 2, 'hash - correct result from <<**<<';
    is %r, 4, 'hash - correct result from <<**<<';
    is %r, 8, 'hash - correct result from <<**<<';
    
    %r = %a <<*>> 4;
    is +%r,   3, 'hash - <<*>> result has right number of keys';
    is %r, 4, 'hash - correct result from <<*>>';
    is %r, 8, 'hash - correct result from <<*>>';
    is %r, 12, 'hash - correct result from <<*>>';
    
    %r = 2 <<**>> %a ;
    is +%r,   3, 'hash - <<**>> result has right number of keys';
    is %r, 2, 'hash - correct result from <<**>>';
    is %r, 4, 'hash - correct result from <<**>>';
    is %r, 8, 'hash - correct result from <<**>>';
}

{
    my %a = a => 1, b => -2, c => 3;
    my %r = %a>>.abs;
    is +%r,   3, 'hash - >>.abs result has right number of keys';
    is %r, 1, 'hash - correct result from >>.abs';
    is %r, 2, 'hash - correct result from >>.abs';
    is %r, 3, 'hash - correct result from >>.abs';
}

{
    my @a = (1, { a => 2, b => 3 }, 4);
    my @b = ;
    my @c = ('z', { a => 'y', b => 'x' }, 'w');
    my @d = 'a'..'f';

    my @r = @a <<~>> @b;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from <<~>>';
    is @r[1], "2b", 'hash in array - correct result from <<~>>';
    is @r[1], "3b", 'hash in array - correct result from <<~>>';
    is @r[2], "4c", 'hash in array - correct result from <<~>>';

    @r = @a >>~<< @c;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1z", 'hash in array - correct result from >>~<<';
    is @r[1], "2y", 'hash in array - correct result from >>~<<';
    is @r[1], "3x", 'hash in array - correct result from >>~<<';
    is @r[2], "4w", 'hash in array - correct result from >>~<<';
    
    @r = @a >>~>> @d;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from >>~>>';
    is @r[1], "2b", 'hash in array - correct result from >>~>>';
    is @r[1], "3b", 'hash in array - correct result from >>~>>';
    is @r[2], "4c", 'hash in array - correct result from >>~>>';

    @r = @d <, "2b", 'hash in array - correct result from <, "3b", 'hash in array - correct result from <> @d;
    is +@r, 6, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from <<~>>';
    is @r[1], "2b", 'hash in array - correct result from <<~>>';
    is @r[1], "3b", 'hash in array - correct result from <<~>>';
    is @r[2], "4c", 'hash in array - correct result from <<~>>';
    is @r[3], "1d", 'hash in array - correct result from <<~>>';
    is @r[4], "2e", 'hash in array - correct result from <<~>>';
    is @r[4], "3e", 'hash in array - correct result from <<~>>';
    is @r[5], "4f", 'hash in array - correct result from <<~>>';
}

{
    my @a = (1, { a => 2, b => 3 }, 4);
    my @b = ;
    my @c = ('z', { a => 'y', b => 'x' }, 'w');
    my @d = 'a'..'f';

    my @r = @a «~» @b;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from «~»';
    is @r[1], "2b", 'hash in array - correct result from «~»';
    is @r[1], "3b", 'hash in array - correct result from «~»';
    is @r[2], "4c", 'hash in array - correct result from «~»';

    @r = @a »~« @c;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1z", 'hash in array - correct result from »~«';
    is @r[1], "2y", 'hash in array - correct result from »~«';
    is @r[1], "3x", 'hash in array - correct result from »~«';
    is @r[2], "4w", 'hash in array - correct result from »~«';
    
    @r = @a »~» @d;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from »~»';
    is @r[1], "2b", 'hash in array - correct result from »~»';
    is @r[1], "3b", 'hash in array - correct result from »~»';
    is @r[2], "4c", 'hash in array - correct result from »~»';

    @r = @d «R~« @a;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from «R~«';
    is @r[1], "2b", 'hash in array - correct result from «R~«';
    is @r[1], "3b", 'hash in array - correct result from «R~«';
    is @r[2], "4c", 'hash in array - correct result from «R~«';

    @r = @a «~» @d;
    is +@r, 6, 'hash in array - result array is the correct length';
    is @r[0], "1a", 'hash in array - correct result from «~»';
    is @r[1], "2b", 'hash in array - correct result from «~»';
    is @r[1], "3b", 'hash in array - correct result from «~»';
    is @r[2], "4c", 'hash in array - correct result from «~»';
    is @r[3], "1d", 'hash in array - correct result from «~»';
    is @r[4], "2e", 'hash in array - correct result from «~»';
    is @r[4], "3e", 'hash in array - correct result from «~»';
    is @r[5], "4f", 'hash in array - correct result from «~»';
}

{
    my @a = (1, { a => 2, b => 3 }, 4);
    my @r = -<<@a;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], -1, 'hash in array - correct result from -<<';
    is @r[1], -2, 'hash in array - correct result from -<<';
    is @r[1], -3, 'hash in array - correct result from -<<';
    is @r[2], -4, 'hash in array - correct result from -<<';
    
    @r = ++<<@a;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], 2, 'hash in array - correct result from ++<<';
    is @r[1], 3, 'hash in array - correct result from ++<<';
    is @r[1], 4, 'hash in array - correct result from ++<<';
    is @r[2], 5, 'hash in array - correct result from ++<<';
    
    @r = @a>>--;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], 2, 'hash in array - correct result from ++<<';
    is @r[1], 3, 'hash in array - correct result from ++<<';
    is @r[1], 4, 'hash in array - correct result from ++<<';
    is @r[2], 5, 'hash in array - correct result from ++<<';
    is +@a, 3, 'hash in array - result array is the correct length';
    is @a[0], 1, 'hash in array - correct result from ++<<';
    is @a[1], 2, 'hash in array - correct result from ++<<';
    is @a[1], 3, 'hash in array - correct result from ++<<';
    is @a[2], 4, 'hash in array - correct result from ++<<';
}

{
    my @a = (1, { a => 2, b => 3 }, 4);
    my @r = -«@a;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], -1, 'hash in array - correct result from -«';
    is @r[1], -2, 'hash in array - correct result from -«';
    is @r[1], -3, 'hash in array - correct result from -«';
    is @r[2], -4, 'hash in array - correct result from -«';
    
    @r = ++«@a;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], 2, 'hash in array - correct result from ++«';
    is @r[1], 3, 'hash in array - correct result from ++«';
    is @r[1], 4, 'hash in array - correct result from ++«';
    is @r[2], 5, 'hash in array - correct result from ++«';
    
    @r = @a»--;
    is +@r, 3, 'hash in array - result array is the correct length';
    is @r[0], 2, 'hash in array - correct result from ++«';
    is @r[1], 3, 'hash in array - correct result from ++«';
    is @r[1], 4, 'hash in array - correct result from ++«';
    is @r[2], 5, 'hash in array - correct result from ++«';
    is +@a, 3, 'hash in array - result array is the correct length';
    is @a[0], 1, 'hash in array - correct result from ++«';
    is @a[1], 2, 'hash in array - correct result from ++«';
    is @a[1], 3, 'hash in array - correct result from ++«';
    is @a[2], 4, 'hash in array - correct result from ++«';
}

# test non-UTF-8 input
#?niecza skip 'nonsensical test'
#?pugs skip 'eval(Buf)'
#?rakudo skip 'eval(Buf)'
#?DOES 1
{
    my $t = '(1, 2, 3) »+« (4, 3, 2)';
    ok !eval($t.encode('ISO-8859-1')),
       'Latin-1 »+« without pre-declaration is an error';
}

# Test for 'my @a =  »~» "z";' wrongly
# setting @a to [['az', 'bz', 'cz']].
{
    my @a =  »~» 'z';
    is "{@a[0]}, {@a[1]}, {@a[2]}", 'az, bz, cz', "dwimmy hyper doesn't return an itemized list";
}

# L
#?rakudo todo 'nom regression - whatever extension'
{
    @r =  »~» (1, 2, 3, *);
    @e = ;
    is ~@r, ~@e, 'dwimmy hyper extends lists ending with * by copying the last element';

    @r =  «~» (1, 2, 3, *);
    @e = ;
    is ~@r, ~@e, 'dwimmy hyper extends lists ending with * by copying the last element';

    @r = (1, 2, 3, *) «~« ;
    @e = <1A 2B 3C 3D 3E>;
    is ~@r, ~@e, 'dwimmy hyper extends lists ending with * by copying the last element';

    @r = (1, 2, 3, *) «~» ;
    @e = <1A 2B 3C 3D 3E>;
    is ~@r, ~@e, 'dwimmy hyper extends lists ending with * by copying the last element';

    @r = (1, 2, *) «~» (4, 5, *);
    @e = <14 25>;
    is ~@r, ~@e, 'dwimmy hyper omits * when both arguments of same length have one';

    @r = (1, 2, *) «~» (4, 5, 6, *);
    @e = <14 25 26>;
    is ~@r, ~@e, 'dwimmy hyper takes longer length given two arguments ending with *';
}

# RT #77010

{
    # niecza doesn't propagate slangs into &eval yet
    eval_lives_ok 'sub infix:<+++>($a, $b) { ($a + $b) div 2 }; 10 >>+++<< 14', 'can use hypers with local scoped user-defined operators';
} 

# RT #74530
{
    is ~(-<<(1..3)), '-1 -2 -3', 'ranges and hyper ops mix';
}

# RT #77800
# Parsing hyper-subtraction
{
    is ((9, 8) <<-<< (1, 2, 3, 4)), (8, 6, 6, 4), '<<-<<';
    is ((9, 8, 10, 12) >>->> (1, 2)), (8, 6, 9, 10), '>>->>';
    is ((9, 8) >>-<< (1, 2)), (8, 6), '>>-<<';
    is ((9, 8) <<->> (1, 2, 5)), (8, 6, 4), '<<->>';
}

# RT #77876
# L
# Hyper assignment operators
{
    my @array = 3, 8, 2, 9, 3, 8;
    @r = @array »+=« (1, 2, 3, 4, 5, 6);
    @e = 4, 10, 5, 13, 8, 14;
    is @r, @e, '»+=« returns the right value';
    is @array, @e, '»+=« changes its lvalue';

    @array = 3, 8, 2, 9, 3, 8;
    @r = @array »*=» (1, 2, 3);
    @e = 3, 16, 6, 9, 6, 24;
    is @r, @e, '»*=» returns the right value';
    is @array, @e, '»*=» changes its lvalue';

    my $a = 'apple';
    my $b = 'blueberry';
    my $c = 'cherry';
    @r = ($a, $b, $c) »~=» ;
    @e = ;
    is @r, @e, '»~=» with list of scalars on the left returns the right value';
    my $e = 'applepie, blueberrytart, cherrypie';
    is "$a, $b, $c", $e, '»~=» changes each scalar';
}

# RT #83510
is ((1, 2) >>[+]<< (100, 200)).join(','), '101,202',
    '>>[+]<< works';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/not.t0000664000175000017500000000362512224265625017014 0ustar  moritzmoritzuse v6;
use Test;

plan 33;

=begin pod

=head1 DESCRIPTION

This test tests the C not metaoperator.

=end pod

is 4 !< 5, !(4 < 5), "4 !< 5";
isa_ok 4 !< 5, Bool, "4 !< 5 is Bool";
is 4 !> 5, !(4 > 5), "4 !> 5";
isa_ok 4 !> 5, Bool, "4 !> 5 is Bool";
is 4 !<= 5, !(4 <= 5), "4 !<= 5";
isa_ok 4 !<= 5, Bool, "4 !<= 5 is Bool";
is 4 !>= 5, !(4 >= 5), "4 !>= 5";
isa_ok 4 !>= 5, Bool, "4 !>= 5 is Bool";
is 4 !== 5, !(4 == 5), "4 !== 5";
isa_ok 4 !== 5, Bool, "4 !== 5 is Bool";

is 'bat' !lt 'ace', !('bat' lt 'ace'), "'bat' !lt 'ace'";
isa_ok 'bat' !lt 'ace', Bool, "'bat' !lt 'ace' is Bool";
is 'bat' !gt 'ace', !('bat' gt 'ace'), "'bat' !gt 'ace'";
isa_ok 'bat' !gt 'ace', Bool, "'bat' !gt 'ace' is Bool";
is 'bat' !le 'ace', !('bat' le 'ace'), "'bat' !le 'ace'";
isa_ok 'bat' !le 'ace', Bool, "'bat' !le 'ace' is Bool";
is 'bat' !ge 'ace', !('bat' ge 'ace'), "'bat' !ge 'ace'";
isa_ok 'bat' !ge 'ace', Bool, "'bat' !ge 'ace' is Bool";
is 'bat' !eq 'ace', !('bat' eq 'ace'), "'bat' !eq 'ace'";
isa_ok 'bat' !eq 'ace', Bool, "'bat' !eq 'ace' is Bool";

is 'bat' !before 'ace', !('bat' before 'ace'), "'bat' !before 'ace'";
isa_ok 'bat' !before 'ace', Bool, "'bat' !before 'ace' is Bool";
is 'bat' !after 'ace', !('bat' after 'ace'), "'bat' !after 'ace'";
isa_ok 'bat' !after 'ace', Bool, "'bat' !after 'ace' is Bool";

# !~~ is tested all over the test suite, so we'll skip
# it here.

is 4 !=== 5, !(4 === 5), "4 !=== 5";
isa_ok 4 !=== 5, Bool, "4 !=== 5 is Bool";
is 4 !eqv 5, !(4 eqv 5), "4 !eqv 5";
isa_ok 4 !eqv 5, Bool, "4 !eqv 5 is Bool";
is 4 !=:= 5, !(4 =:= 5), "4 !=:= 5";
isa_ok 4 !=:= 5, Bool, "4 !=:= 5 is Bool";

# Tests based on http://irclog.perlgeek.de/perl6/2012-01-24#i_5045770
# and the next few minutes of log.  --colomon
eval_dies_ok '"a" !!eq "a"', 'Doubled prefix: is illegal';
ok "a" ![!eq] "a", '![!eq] is legal and works (1)';
nok "a" ![!eq] "b", '![!eq] is legal and works (2)';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/reduce.t0000664000175000017500000003371512224265625017466 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

=head1 DESCRIPTION

This test tests the C<[...]> reduce metaoperator.

Reference:
L<"http://groups.google.de/group/perl.perl6.language/msg/bd9eb275d5da2eda">

=end pod

# L

# [...] reduce metaoperator
{
  my @array = <5 -3 7 0 1 -9>;
  my $sum   = 5 + -3 + 7 + 0 + 1 + -9; # laziness :)

  is(([+] @array),      $sum, "[+] works");
  is(([*]  1,2,3),    (1*2*3), "[*] works");
  is(([-]  1,2,3),    (1-2-3), "[-] works");
  is(([/]  12,4,3),  (12/4/3), "[/] works");
  is(([div]  12,4,3),  (12 div 4 div 3), "[div] works");
  is(([**] 2,2,3),  (2**2**3), "[**] works");
  is(([%]  13,7,4), (13%7%4),  "[%] works");
  is(([mod]  13,7,4), (13 mod 7 mod 4),  "[mod] works");

  is((~ [\+] @array), "5 2 9 9 10 1", "[\\+] works");
  is((~ [\-] 1, 2, 3), "1 -1 -4",      "[\\-] works");
}

{
  is ([~] ), "abcd", "[~] works";
  is (~ [\~] ), "a ab abc abcd", "[\\~] works";
}

{
    ok  ([<]  1, 2, 3, 4), "[<] works (1)";
    nok ([<]  1, 3, 2, 4), "[<] works (2)";
    ok  ([>]  4, 3, 2, 1), "[>] works (1)";
    nok ([>]  4, 2, 3, 1), "[>] works (2)";
    ok  ([==] 4, 4, 4),    "[==] works (1)";
    nok ([==] 4, 5, 4),    "[==] works (2)";
    #?niecza 2 skip 'this is parsed as ![=], not good'
    ok  ([!=] 4, 5, 6),    "[!=] works (1)";
    nok ([!=] 4, 4, 4),    "[!=] works (2)";
}

{
    ok (! [eq] ),    '[eq] basic sanity (positive)';
    ok (  [eq] ),    '[eq] basic sanity (negative)';
    ok (  [ne] ),    '[ne] basic sanity (positive)';
    ok (! [ne] ),    '[ne] basic sanity (negative)';
    ok (  [lt] ),    '[lt] basic sanity (positive)';
    ok (! [lt] ),    '[lt] basic sanity (negative)';
}

{
    my ($x, $y);
    #?rakudo todo 'huh?'
    ok (    [=:=]  $x, $x, $x), '[=:=] basic sanity 1';
    ok (not [=:=]  $x, $y, $x), '[=:=] basic sanity 2';
    #?rakudo 2 skip 'huh?'
    ok (    [!=:=] $x, $y, $x), '[!=:=] basic sanity (positive)';
    ok (not [!=:=] $y, $y, $x), '[!=:=] basic sanity (negative)';
    $y := $x;
    #?rakudo todo 'huh?'
    ok (    [=:=]  $y, $x, $y), '[=:=] after binding';
}

{
    my $a = [1, 2];
    my $b = [1, 2];

    ok  ([===] 1, 1, 1, 1),      '[===] with literals';
    ok  ([===] $a, $a, $a),      '[===] with vars (positive)';
    nok ([===] $a, $a, [1, 2]),  '[===] with vars (negative)';
    #?rakudo 2 skip '[!===]'
    ok  ([!===] $a, $b, $a),     '[!===] basic sanity (positive)';
    nok ([!===] $a, $b, $b),     '[!===] basic sanity (negative)';
}

{
    is ~ ([\<]  1, 2, 3, 4).map({+$_}), "1 1 1 1", "[\\<] works (1)";
    is ~ ([\<]  1, 3, 2, 4).map({+$_}), "1 1 0 0", "[\\<] works (2)";
    is ~ ([\>]  4, 3, 2, 1).map({+$_}), "1 1 1 1", "[\\>] works (1)";
    is ~ ([\>]  4, 2, 3, 1).map({+$_}), "1 1 0 0", "[\\>] works (2)";
    is ~ ([\==]  4, 4, 4).map({+$_}),   "1 1 1",   "[\\==] works (1)";
    is ~ ([\==]  4, 5, 4).map({+$_}),   "1 0 0",   "[\\==] works (2)";
    #?niecza 2 todo 'this is parsed as ![=], not good'
    is ~ ([\!=]  4, 5, 6).map({+$_}),   "1 1 1",   "[\\!=] works (1)";
    is ~ ([\!=]  4, 5, 5).map({+$_}),   "1 1 0",   "[\\!=] works (2)";
    is (~ [\**]  1, 2, 3),   "3 8 1",   "[\\**] (right assoc) works (1)";
    is (~ [\**]  3, 2, 0),   "0 1 3",   "[\\**] (right assoc) works (2)";
}

# RT #76110
{
    is ~([\+] [\+] 1 xx 5), '1 3 6 10 15', 'two nested [\+]';
    #?niecza todo 'unary [] does not context yet'
    is ([+] [1, 2, 3, 4]), 4,  '[+] does not flatten []-arrays';
}

#?niecza skip '[macro]'
{
  my @array = (Mu, Mu, 3, Mu, 5);
  is ([//]  @array), 3, "[//] works";
  is ([orelse] @array), 3, "[orelse] works";
}

#?niecza skip '[macro]'
{
  my @array = (Mu, Mu, 0, 3, Mu, 5);
  is ([||] @array), 3, "[||] works";
  is ([or] @array), 3, "[or] works";

  # Mu as well as [//] should work too, but testing it like
  # this would presumably emit warnings when we have them.
  is (~ [\||] 0, 0, 3, 4, 5), "0 0 3 3 3", "[\\||] works";
}

#?niecza skip '[macro]'
{
  my @array = (Mu, Mu, 0, 3, Mu, 5);
  my @array1 = (2, 3, 4);
  nok ([&&] @array), "[&&] works with 1 false";
  is ([&&] @array1), 4, "[&&] works";
  nok ([and] @array), "[and] works with 1 false";
  is ([and] @array1), 4, "[and] works";
}

# not currently legal without an infix subscript operator
# {
#   my $hash = {a => {b => {c => {d => 42, e => 23}}}};
#   is try { [.{}] $hash,  }, 42, '[.{}] works';
# }
# 
# {
#   my $hash = {a => {b => 42}};
#   is ([.{}] $hash, ), 42, '[.{}] works two levels deep';
# }
# 
# {
#   my $arr = [[[1,2,3],[4,5,6]],[[7,8,9],[10,11,12]]];
#   is ([.[]] $arr, 1, 0, 2), 9, '[.[]] works';
# }

{
  # 18:45 < autrijus> hm, I found a way to easily do linked list consing in Perl6
  # 18:45 < autrijus> [=>] 1..10;
  my $list = [=>] 1,2,3;
  is $list.key,                 1, "[=>] works (1)";
  is (try {$list.value.key}),   2, "[=>] works (2)";
  is (try {$list.value.value}), 3, "[=>] works (3)";
}

{
    my @array = <5 -3 7 0 1 -9>;
    # according to http://irclog.perlgeek.de/perl6/2008-09-10#i_560910
    # [,] returns a scalar (holding an Array)
    my $count = 0;
    $count++ for [,] @array;
    #?rakudo todo 'item context'
    #?niecza todo 'huh?'
    is $count, 1, '[,] returns a single Array';
    ok ([,] @array) ~~ Positional, '[,] returns something Positional';
}

# Following two tests taken verbatim from former t/operators/reduce.t
lives_ok({my @foo = [1..3] >>+<< [1..3] >>+<< [1..3]},'Sanity Check');
#?rakudo todo 'reduced hyper op'
#?niecza todo 'These are hyperop tests!'
lives_ok({my @foo = [>>+<<] ([1..3],[1..3],[1..3])},'Parse [>>+<<]');

# Check that user defined infix ops work with [...], too.
#?pugs todo 'bug'
{
    sub infix:($a, $b) { $a + $b + 1 }
    is (try { [more_than_plus] 1, 2, 3 }), 8, "[...] reduce metaop works on user defined ops";
}

# {
#   my $arr = [ 42, [ 23 ] ];
#   $arr[1][1] = $arr;
# 
#   is try { [.[]] $arr, 1, 1, 1, 1, 1, 0 }, 23, '[.[]] works with infinite data structures';
# }
# 
# {
#   my $hash = {a => {b => 42}};
#   $hash = $hash;
# 
#   is try { [.{}] $hash,  }, 42, '[.{}] works with infinite data structures';
# }

# L

is( ([*]()), 1, "[*]() returns 1");
is( ([+]()), 0, "[+]() returns 0");

is( ([*] 41), 41, "[*] 41 returns 41");
is( ([*] 42), 42, "[*] 42 returns 42");
is( ~([\*] 42), "42", "[\*] 42 returns (42)");
is( ([~] 'towel'), 'towel', "[~] 'towel' returns 'towel'");
is( ([~] 'washcloth'), 'washcloth', "[~] 'washcloth' returns 'washcloth'");
is( ([\~] 'towel'), 'towel', "[\~] 'towel' returns 'towel'");
#?niecza skip 'Iterable'
ok( ([\~] 'towel') ~~ Iterable, "[\~] 'towel' returns something Iterable");
is( ([<] 42), Bool::True, "[<] 42 returns true");
is( ~([\<] 42), ~True, "[\<] 42 returns '1'");
#?niecza skip 'Iterable'
ok( ([\<] 42) ~~ Iterable, "[\<] 42 returns something Iterable");

is( ([\*] 1..*).[^10].join(', '), '1, 2, 6, 24, 120, 720, 5040, 40320, 362880, 3628800', 
    'triangle reduce is lazy');
#?niecza skip 'Str cmp Inf'
is( ([\R~] 'a'..*).[^8].join(', '), 'a, ba, cba, dcba, edcba, fedcba, gfedcba, hgfedcba',
    'triangle reduce is lazy');

is( ([max]()), -Inf, '[max]() returns -Inf');
is( ([min]()),  Inf, '[min]() returns -Inf');

#?niecza 2 todo ""
is( ([max] Any, Any, 2), 2, '[max] Any, Any, 2 returns 2');
is( ([min] Any, Any, 2), 2, '[min] Any, Any, 2 returns 2');

# RT #65164 implement [^^]
#?niecza skip '^^'
{
    is ([^^] 0, 42), 42, '[^^] works (one of two true)';
    is ([^^] 42, 0), 42, '[^^] works (one of two true)';
    ok ! ([^^] 1, 42),   '[^^] works (two true)';
    ok ! ([^^] 0, 0),    '[^^] works (two false)';

    ok ! ([^^] 0, 0, 0), '[^^] works (three false)';
    ok ! ([^^] 5, 9, 17), '[^^] works (three true)';

    is ([^^] 5, 9, 0),  (5 ^^ 9 ^^ 0),  '[^^] mix 1';
    is ([^^] 5, 0, 17), (5 ^^ 0 ^^ 17), '[^^] mix 2';
    is ([^^] 0, 9, 17), (0 ^^ 9 ^^ 17), '[^^] mix 3';
    is ([^^] 5, 0, 0),  (5 ^^ 0 ^^ 0),  '[^^] mix 4';
    is ([^^] 0, 9, 0),  (0 ^^ 9 ^^ 0),  '[^^] mix 5';
    is ([^^] 0, 0, 17), (0 ^^ 0 ^^ 17), '[^^] mix 6';

    nok ([^^] ()), 'reduce empty list ok';

    # test False / undefined things
    my $msg1 = 'reduce [^^] false variable test';
    my $msg2 = 'infix ^^ false variable test';
    for (0, '0', '', Bool::False, Any, Mu, Nil) -> $undef {
        ok ( [^^]  $undef, $undef, $undef, 5 ), "|{$undef.perl}| $msg1 \#1";
        nok ( [^^]  1, 2, $undef, 3, $undef ), "|{$undef.perl}| $msg1 \#2";
        nok ( [^^]  $undef, $undef, 1, 5 ), "|{$undef.perl}| $msg1 \#3";
        nok ( [^^]  1, $undef, $undef, 5 ), "|{$undef.perl}| $msg1 \#4";
        ok ( [^^]  $undef, $undef, 2, $undef ), "|{$undef.perl}| $msg1 \#5";
        nok ( [^^]  $undef, $undef, $undef ), "|{$undef.perl}| $msg1 \#6";
        nok ( [^^]  $undef, $undef ), "|{$undef.perl}| $msg1 \#7";
        ok ( [^^]  $undef, 1 ), "|{$undef.perl}| $msg1 \#8";
        ok ( [^^]  1, $undef ), "|{$undef.perl}| $msg1 \#9";
        nok ( [^^]  $undef ), "|{$undef.perl}| $msg1 \#10";
        ok ( $undef ^^ $undef ^^ $undef ^^ 5 ), "|{$undef.perl}| $msg2 \#1";
        nok ( 1 ^^ 2 ^^ $undef ^^ 3 ^^ $undef ), "|{$undef.perl}| $msg2 \#2";
        nok ( $undef ^^ $undef ^^ 1 ^^ 5 ), "|{$undef.perl}| $msg2 \#3";
        nok ( 1 ^^ $undef ^^ $undef ^^ 5 ), "|{$undef.perl}| $msg2 \#4";
        ok ( $undef ^^ $undef ^^ 2 ^^ $undef ), "|{$undef.perl}| $msg2 \#5";
        nok ( $undef ^^ $undef ^^ $undef ), "|{$undef.perl}| $msg2 \#6";
        nok ( $undef ^^ $undef ), "|{$undef.perl}| $msg2 \#7";
        ok ( $undef ^^ 1 ), "|{$undef.perl}| $msg2 \#8";
        ok ( 1 ^^ $undef ), "|{$undef.perl}| $msg2 \#9";
    }

    # test numericy true things
    $msg1 = 'reduce [^^] true numbery variable test';
    $msg2 = 'infix ^^ true numbery variable test';
    for (1, -147, pi, Bool::True) -> $def {
        nok ( [^^] 0, 0, $def, 3, $def ), "|{$def.perl}| $msg1 \#1";
        nok ( [^^] $def, $def, 0 ), "|{$def.perl}| $msg1 \#2";
        nok ( [^^] 1, $def, Any, 5 ), "|{$def.perl}| $msg1 \#3";
        ok ( [^^] $def, 0, 0, 0 ) == $def, "|{$def.perl}| $msg1 \#4";
        ok ( [^^] Any, Any, Any, $def ) == $def, "|{$def.perl}| $msg1 \#5";
        nok ( [^^] $def, $def ), "|{$def.perl}| $msg1 \#6";
        ok ( [^^] $def, 0 ) == $def, "|{$def.perl}| $msg1 \#7";
        ok ( [^^] 0, $def ) == $def, "|{$def.perl}| $msg1 \#8";
        ok ( [^^] $def ), "|{$def.perl}| $msg1 \#9";
        nok ( 0 ^^ 0 ^^ $def ^^ 3 ^^ $def ), "|{$def.perl}| $msg2 \#1";
        nok ( $def ^^ $def ^^ 0 ), "|{$def.perl}| $msg2 \#2";
        nok ( 1 ^^ $def ^^ Any ^^ 5 ), "|{$def.perl}| $msg2 \#3";
        ok ( $def ^^ 0 ^^ 0 ^^ 0 ) == $def, "|{$def.perl}| $msg2 \#4";
        ok ( Any ^^ Any ^^ Any ^^ $def ) == $def,"|{$def.perl}| $msg2 \#5";
        nok ( $def ^^ $def ), "|{$def.perl}| $msg2 \#6";
        ok ( $def ^^ 0 ) == $def, "|{$def.perl}| $msg2 \#7";
        ok ( 0 ^^ $def ) == $def, "|{$def.perl}| $msg2 \#8";
    }

    # test stringy true things
    $msg1 = 'reduce [^^] true string variable test';
    $msg2 = 'infix ^^ true string variable test';
    for ('no', 'Bob', '10', 'False') -> $def {
        nok ( [^^] $def, $def, $def, 'string' ), "|{$def.perl}| $msg1 \#1";
        nok ( [^^] '', '', $def, 'str', $def ), "|{$def.perl}| $msg1 \#2";
        nok ( [^^] $def, $def,'' ), "|{$def.perl}| $msg1 \#3";
        nok ( [^^] 1, $def, Any, 5 ), "|{$def.perl}| $msg1 \#4";
        ok ( [^^] $def, '', '', '' ) eq $def, "|{$def.perl}| $msg1 \#5";
        ok ( [^^] Any, Any, Any, $def ) eq $def, "|{$def.perl}| $msg1 \#6";
        nok ( [^^] $def, $def ), "|{$def.perl}| $msg1 \#7";
        ok ( [^^] $def, '' ) eq $def, "|{$def.perl}| $msg1 \#8";
        ok ( [^^] '', $def ) eq $def, "|{$def.perl}| $msg1 \#9";
        ok ( [^^] $def ) eq $def, "|{$def.perl}| $msg1 \#10";
        nok ( $def ^^ $def ^^ $def ^^ 'string' ), "|{$def.perl}| $msg2 \#1";
        nok ( '' ^^ '' ^^ $def ^^ 'str' ^^ $def ),"|{$def.perl}| $msg2 \#2";
        nok ( $def ^^ $def ^^'' ), "|{$def.perl}| $msg2 \#3";
        nok ( 1 ^^ $def ^^ Any ^^ 5 ), "|{$def.perl}| $msg2 \#4";
        ok ( $def ^^ '' ^^ '' ^^ '' ) eq $def, "|{$def.perl}| $msg2 \#5";
        ok ( Any ^^ Any ^^ Any ^^ $def ) eq $def,"|{$def.perl}| $msg2 \#6";
        nok ( $def ^^ $def ), "|{$def.perl}| $msg2 \#7";
        ok ( $def ^^ '' ) eq $def, "|{$def.perl}| $msg2 \#8";
        ok ( '' ^^ $def ) eq $def, "|{$def.perl}| $msg2 \#9";
    }
}

#?rakudo todo 'triangle [\^^] and [\xor]'
#?niecza skip '^^'
{
    is (join ', ', [\^^] False, 0, 5, '', False, 16,    0,     Any,   "hello", False),
       (join ', ',       False, 0, 5, 5,  5,     False, False, False, False,   False),
       '[\^^]';
    is (join ', ', [\xor] 'xyzzy', Int,     0.0,     '',      False,   'plugh', 4,     2,     'xyzzy'),
       (join ', ',        'xyzzy', 'xyzzy', 'xyzzy', 'xyzzy', 'xyzzy', False,   False, False, False),
       '[\xor]';
}

# RT 57976 implement orelse
#?niecza skip 'huh?  these are macros'
#?rakudo todo 'orelse'
{

    is (join ', ', [\//] Any,    0, 1),
       (join ', ',      'Any()', 0, 0),
       '[\orelse]';
    is (join ', ', [\orelse] Any,    0, 1),
       (join ', ',          'Any()', 0, 0),
       '[\orelse]';

}

# RT #75234
# rakudo had a problem where once-used meta operators weren't installed
# in a sufficiently global location, so using a meta operator in class once
# makes it unusable further on
{
    class A {
        method m { return [~] gather for ^3 {take 'a'} }
    }
    class B {
        method n { return [~] gather for ^4 {take 'b'}}
    }
    is A.new.m, 'aaa',  '[~] works in first class';
    is B.new.n, 'bbbb', '[~] works in second class';
    is ([~] 1, 2, 5), '125', '[~] works outside class';
}

ok [+](1..10) + 0 == ([+] 1..10) + 0,
   'a listop with immediate () is a function call (RT 82210)';
# RT #76758
ok [+](1, 2, 3) / 2 == 3, '[+] is a normal listop';

# RT #80332
ok ([+]) == 0, 'argumentless [+] parses';

# RT #99942
{
    sub rt99942 { [+] @_ };
    is rt99942(1, 42), 43, 'RT #99942'
}

# RT #67064
#?niecza skip "reduce is not supposed to flatten?"
{
    is(([X~] [] xx 3), , 'reduce with X');
}

done;
# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/reverse.t0000664000175000017500000000435112224265625017664 0ustar  moritzmoritzuse v6;
use Test;

plan 34;

=begin pod

=head1 DESCRIPTION

This test tests the C reverse metaoperator.

=end pod

# Try mulitple versions of Rcmp, as it is one of the more
# more useful reversed ops, and if it works, probably
# most of the others will work as well.

is 4 Rcmp 5, 5 cmp 4, "4 Rcmp 5";
isa_ok 4 Rcmp 5, (5 cmp 4).WHAT, "4 Rcmp 5 is the same type as 5 cmp 4";
is 4.3 Rcmp 5, 5 cmp 4.3, "4.3 Rcmp 5";
isa_ok 4.3 Rcmp 5, (5 cmp 4.3).WHAT, "4.3 Rcmp 5 is the same type as 5 cmp 4.3";
is 4.3 Rcmp 5.Num, 5.Num cmp 4.3, "4.3 Rcmp 5.Num";
isa_ok 4.3 Rcmp 5.Num, (5.Num cmp 4.3).WHAT, "4.3 Rcmp 5.Num is the same type as 5.Num cmp 4.3";
is 4.3i Rcmp 5.Num, 5.Num cmp 4.3i, "4.3i Rcmp 5.Num";
isa_ok 4.3i Rcmp 5.Num, (5.Num cmp 4.3i).WHAT, "4.3i Rcmp 5.Num is the same type as 5.Num cmp 4.3i";

# Try to get a good sampling of math operators

is 4 R+ 5, 5 + 4, "4 R+ 5";
isa_ok 4 R+ 5, (5 + 4).WHAT, "4 R+ 5 is the same type as 5 + 4";
is 4 R- 5, 5 - 4, "4 R- 5";
isa_ok 4 R- 5, (5 - 4).WHAT, "4 R- 5 is the same type as 5 - 4";
is 4 R* 5, 5 * 4, "4 R* 5";
isa_ok 4 R* 5, (5 * 4).WHAT, "4 R* 5 is the same type as 5 * 4";
is 4 R/ 5, 5 / 4, "4 R/ 5";
isa_ok 4 R/ 5, (5 / 4).WHAT, "4 R/ 5 is the same type as 5 / 4";
is 4 Rdiv 5, 5 div 4, "4 Rdiv 5";
isa_ok 4 Rdiv 5, (5 div 4).WHAT, "4 Rdiv 5 is the same type as 5 div 4";
is 4 R% 5, 5 % 4, "4 R% 5";
isa_ok 4 R% 5, (5 % 4).WHAT, "4 R% 5 is the same type as 5 % 4";
is 4 R** 5, 5 ** 4, "4 R** 5";
isa_ok 4 R** 5, (5 ** 4).WHAT, "4 R** 5 is the same type as 5 ** 4";

# and a more or less random sampling of other operators

is 4 R< 5, 5 < 4, "4 R< 5";
isa_ok 4 R< 5, (5 < 4).WHAT, "4 R< 5 is the same type as 5 < 4";
is 4 R> 5, 5 > 4, "4 R> 5";
isa_ok 4 R> 5, (5 > 4).WHAT, "4 R> 5 is the same type as 5 > 4";
is 4 R== 5, 5 == 4, "4 R== 5";
isa_ok 4 R== 5, (5 == 4).WHAT, "4 R== 5 is the same type as 5 == 4";
is 4 Rcmp 5, 5 cmp 4, "4 Rcmp 5";
isa_ok 4 Rcmp 5, (5 cmp 4).WHAT, "4 Rcmp 5 is the same type as 5 cmp 4";

# precedence tests!
is 3 R/ 9 + 5, 8, 'R/ gets precedence of /';
is 4 R- 5 R/ 10, -2, "Rop gets the precedence of op";
is (9 R... 1, 3), (1, 3, 5, 7, 9), "Rop gets list_infix precedence correctly";

# RT #93350
eval_dies_ok '("a" R~ "b") = 1', 'Cannot assign to return value of R~';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-metaops/zip.t0000664000175000017500000000470012237474612017013 0ustar  moritzmoritzuse v6;

use Test;
plan 24;

ok eval(' Z '), 'zip non-meta operator parses';

is ( Z <1 2>), , 'non-meta zip produces expected result';

is (1, 2, 3 Z** 2, 4), (1, 16), 'zip-power works';

ok eval(' Z, '), 'zip metaoperator parses';

is ( Z~ <1 2>), , 'zip-concat produces expected result';

is (1,2 Z* 3,4), (3,8), 'zip-product works';

is (1,2 Zcmp 3,2,0), (Order::Less, Order::Same), 'zip-cmp works';

# tests for laziness
is (1..* Z** 1..*).[^5], (1**1, 2**2, 3**3, 4**4, 5**5), 'zip-power with lazy lists';
is (1..* Z+ (3, 2 ... *)).[^5], (1+3, 2+2, 3+1, 4+0, 5-1), 'zip-plus with lazy lists';

# tests for non-list arguments
is (1 Z* 3,4), (3), 'zip-product works with scalar left side';
is (1, 2 Z* 3), (3), 'zip-product works with scalar right side';
is (1 Z* 3), (3), 'zip-product works with scalar both sides';

# L

#?rakudo todo 'nom regression'
{
#?niecza todo
is ( Z 'x', 'z', *), , 'non-meta zip extends right argument ending with *';
#?niecza todo
is (1, 2, 3, * Z 10, 20, 30, 40, 50),
    (1, 10, 2, 20, 3, 30, 3, 40, 3, 50), 'non-meta zip extends left argument ending with *';
#?niecza skip 'Unable to resolve method munch in class List'
is (2, 10, * Z 3, 4, 5, *).munch(10),
    (2, 3, 10, 4, 10, 5, 10, 5, 10, 5),
    'non-meta zip extends two arguments ending with *';
#?niecza todo
is ( Z~ 'x', 'z', *), , 'zip-concat extends right argument ending with *';
}

#?rakudo skip 'nom regression'
#?niecza skip 'Cannot use value like Whatever as a number'
{
is (1, 2, 3, * Z+ 10, 20, 30, 40, 50), (11, 22, 33, 43, 53), 'zip-plus extends left argument ending with *';
is (2, 10, * Z* 3, 4, 5, *).munch(5),
    (6, 40, 50, 50, 50), 'zip-product extends two arguments ending with *';
}

#?niecza todo
{
    is join(',', [Z+] [1, 2], [20, 10], [100, 200]),
       '121,212', '[Z+] with three arrays';
}

# RT #75818
isa_ok (1 Z 2)[0], Parcel, 'zip returns a list of parcels';

# RT #113800  - multiple Z operators work with list associative
#?niecza skip "Unable to resolve method lol in type Parcel"
{
    my $l = (1,2,3 Z, 4,5,6 Z, 7,8,9);
    is $l.[0].lol.elems, 3, 'Z, retains list associativity';
    is $l.[1].lol.elems, 3, 'Z, retains list associativity';
    is $l.[2].lol.elems, 3, 'Z, retains list associativity';
}

# RT #73948
is (1, 2 Z, 3, 4).join('|'), '1|3|2|4', 'Z, flattens in list context';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/adverbial-modifiers.t0000664000175000017500000001265712224265625022477 0ustar  moritzmoritzuse v6;

use Test;

plan 42;

# L
sub prefix: (Str $foo, Int :$times = 1) {
  ("BLUB" x $times) ~ $foo;
}

is prefix:("bar"), 'BLUBbar', 'user-defined prefix operator, long name';
is prefix:("bar", times => 2), 'BLUBBLUBbar', 'user-defined prefix operator, long name, optional parameter';
is prefix:(:times(2), "bar"), 'BLUBBLUBbar', 'user-defined prefix operator, long name, :times adverb, leading';
is prefix:("bar", :times(2)), 'BLUBBLUBbar', 'user-defined prefix operator, long name, :times adverb, trailing';
is blub "bar", 'BLUBbar', 'user-defined prefix operator, basic call';
is blub "bar" :times(2), 'BLUBBLUBbar', 'user-defined prefix operator, :times adverb, space';
is blub "bar":times(2), 'BLUBBLUBbar', 'user-defined prefix operator, :times adverb, no space';

{
  # These basic adverb tests are copied from a table in A12.
  my $bar = 123;
  my @many = (4,5);
  sub dostuff(){"stuff"}
  my ($v,$e);
  $e = (foo => $bar);
  $v = :foo($bar);
  is ~$v, ~$e, ':foo($bar)';

  $e = (foo => [1,2,3,@many]);
  $v = :foo[1,2,3,@many];
  is ~$v, ~$e, ':foo[1,2,3,@many]';

  $e = (foo => «alice bob charles»);
  $v = :foo«alice bob charles»;
  is ~$v, ~$e, ':foo«alice bob charles»';

  $e = (foo => 'alice');
  $v = :foo«alice»;
  is ~$v, ~$e, ':foo«alice»';

  $e = (foo => { a => 1, b => 2 });
  $v = eval ':foo{ a => 1, b => 2 }';
  is ~$v, ~$e, ':foo{ a => 1, b => 2 }';

  $e = (foo => { dostuff() });
  $v = :foo{ dostuff() };
  is ~$v, ~$e, ':foo{ dostuff() }';

  $e = (foo => 0);
  $v = :foo(0);
  is ~$v, ~$e, ':foo(0)';

  $e = (foo => Bool::True);
  $v = :foo;
  is ~$v, ~$e, ':foo';
}

# Exercise various mixes of "fiddle", parens "()",
# and adverbs with "X' and without "x" an argument.
sub violin($x) { 
    if $x ~~ Bool {
        $x ?? "1" !! "0";
    } else {
        $x;
    }
}
sub fiddle(:$x,:$y){ violin($x) ~ violin($y) }

#?niecza skip 'Multi colonpair syntax not yet understood'
#?rakudo todo 'Multi colonpair syntax not yet understood'
{
  # fiddle(XY) fiddle(YX) fiddle(xY) fiddle(Xy)

  is fiddle(:x("a"):y("b")), "ab", 'fiddle(:x("a"):y("b"))';
  is fiddle(:y("b"):x("a")), "ab", 'fiddle(:y("b"):x("a"))';
  is fiddle(:x:y("b")), "1b", 'fiddle(:x:y("b"))';
  is fiddle(:x("a"):y), "a1", 'fiddle(:x("a"):y)';
}

{
  # fiddle(X)Y fiddle(Y)X fiddle(x)Y fiddle(X)y fiddle(x)y

  is fiddle(:x("a")):y("b"), "ab", 'fiddle(:x("a")):y("b")';
  is fiddle(:y("b")):x("a"), "ab", 'fiddle(:y("b")):x("a")';
  is fiddle(:x):y("b"), "1b", 'fiddle(:x("a")):y("b")';
  is fiddle(:x("a")):y, "a1", 'fiddle(:x("a")):y';
  is fiddle(:x):y, "11", 'fiddle(:x):y';
}

{
  # fiddle()XY fiddle()YX fiddle()xY fiddle()Xy  fiddle()xy

  is fiddle():x("a"):y("b"), "ab", 'fiddle():x("a"):y("b")';
  is fiddle():y("b"):x("a"), "ab", 'fiddle():y("b"):x("a")';
  is fiddle():x:y("b"), "1b", 'fiddle():x:y("b")';
  is fiddle():x("a"):y, "a1", 'fiddle():x("a"):y';
  is fiddle():x:y, "11", 'fiddle():x:y';
}

{
  # f_X(Y) f_X_Y() f_X_Y_() f_XY_() f_XY() fXY ()

  # $v = fiddle :x("a")(:y("b"));
  # is $v, "ab", 'fiddle :x("a")(:y("b"))';
  # Since the demagicalizing of pairs, this test shouldn't and doesn't work any
  # longer.

#  $v = 'eval failed';
#  eval '$v = fiddle :x("a") :y("b")()';
#  #?pugs todo 'bug'
#  is $v, "ab", 'fiddle :x("a") :y("b")()';

#  $v = 'eval failed';
#  eval '$v = fiddle :x("a") :y("b") ()';
#  #?pugs todo 'bug'
#  is $v, "ab", 'fiddle :x("a") :y("b") ()';

#  $v = 'eval failed';
#  eval '$v = fiddle :x("a"):y("b") ()';
#  #?pugs todo 'bug'
#  is $v, "ab", 'fiddle :x("a"):y("b") ()';

#  $v = 'eval failed';
#  eval '$v = fiddle :x("a"):y("b")()';
#  #?pugs todo 'bug'
#  is $v, "ab", 'fiddle :x("a"):y("b")()';

#  $v = fiddle:x("a"):y("b") ();
#  is $v, "ab", 'fiddle:x("a"):y("b") ()';
}

{
  # Exercise mixes of adverbs and positional arguments.

  my $v;
  my sub f($s,:$x) { violin($x) ~ violin($s) }
  my sub g($s1,$s2,:$x) {$s1~$x~$s2}
  my sub h(*@a) {@a.perl}
  my sub i(*%h) {%h.perl}
  my sub j($s1,$s2,*%h) {$s1~%h.perl~$s2}

  # f(X s) f(Xs) f(s X) f(sX) f(xs) f(sx)

  is f(:x("a"), "b"), "ab", 'f(:x("a") "b")';
  is f(:x("a"),"b"), "ab", 'f(:x("a")"b")';
  is f("b", :x("a")), "ab", 'f("b" :x("a"))';
  is f("b",:x("a")), "ab", 'f("b":x("a"))';
  is f(:x, "b"), "1b", 'f(:x "b")';
  is f("b", :x), "1b", 'f("b" :x)';

  # f(s)X

  is f("b"):x("a"), "ab", 'f("b"):x("a")';

  # fs X  fsX  fs x  fsx

#  $v = f "b" :x("a");
#  is $v, "ab", 'f "b" :x("a")';

#  $v = f "b":x("a");
#  is $v, "ab", 'f "b":x("a")';

#  $v = f "b" :x;
#  is $v, "1b", 'f "b" :x';

#  $v = f "b":x;
#  is $v, "1b", 'f "b":x';

  # add more tests...

}

#?niecza skip 'Multi colonpair syntax not yet understood'
#?rakudo todo 'Multi colonpair syntax not yet understood'
{ # adverbs as pairs

  my sub f1($s,:$x){$s.perl~$x}
  is f1(\:bar :x("b")), '("bar" => Bool::True)b', 'f1(\:bar :x("b"))';
}

{
  # adverbs as pairs, cont.
  my sub f2(Pair $p){$p.perl}
  is f2((:bar)), ("bar" => Bool::True).perl, 'f2((:bar))';

  my sub f3(Pair $p1, Pair $p2){$p1.perl~" - "~$p2.perl}
  is f3((:bar),(:hee(3))), "{(bar => Bool::True).perl} - {(hee => 3).perl}", 'f3((:bar),(:hee(3)))';
}


{
  # Exercise adverbs on operators.

  sub prefix:($a,:$x){join(",",$a,$x)}
  is (zpre 4 :x(5)), '4,5', '(zpre 4 :x(5))';

  sub postfix:($a,:$x){join(",",$a,$x)}
  is (4zpost :x(5)), '4,5', '(4 zpost :x(5))';

  sub infix:($a,$b,:$x){join(",",$a,$b,$x)}
  is (3 zin 4 :x(5)), '3,4,5', '(3 zin 4 :x(5))';

}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/also.t0000664000175000017500000000144512224265625017516 0ustar  moritzmoritzuse Test;
plan 8;

# L">

ok ?(1 S& 2),         "basic infix:";
#?niecza skip 'Excess arguments to CORE seqop, used 3 of 4 positionals'
ok ?(1 S& 2 S& 3), "basic infix: (multiple S&'s)";
#?rakudo todo 'nom regression'
ok !(0 S& 1),         "S& has and-semantics (first term 0)";
#?rakudo todo 'nom regression'
ok !(1 S& 0),         "also has and-semantics (second term 0)";

my $x = '';

ok ?('a' ~~ { $x ~= "b"; True } S& { $x ~= "c"; True }), 'S& with two blocks';
#?rakudo todo 'nom regression'
is $x, 'bc', 'blocks called in the right order';

my $executed = 0;

#?rakudo todo 'nom regression'
ok !('a' ~~ 'b' S& { $executed = 1; True }), 'and semantics';
#?niecza todo
ok !$executed,                            'short-circuit';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/andthen.t0000664000175000017500000000071512224265625020200 0ustar  moritzmoritzuse v6;
use Test;

is (1 andthen 2), 2, 'andthen basics';
is (1 andthen 2 andthen 3), 3, 'andthen chained';
is (0 andthen 1), 1, 'definedness, not truthness';
ok Any === (1 andthen Any), 'first undefined value (1)';
ok Any === (Any andthen 2), 'first undefined value (2)';
my $tracker = 0;
nok (Int andthen ($tracker = 1)), 'sanity';
nok $tracker, 'andthen thunks';

my $ = 'some arg' andthen -> $x { is $x, 'some arg', 'andthen passes on arguments' };


done;
rakudo-2013.12/t/spec/S03-operators/arith.t0000664000175000017500000001665612224265625017701 0ustar  moritzmoritzuse v6;
use Test;
plan 144;

my $five = abs(-5);

unless ($five == 5) {
    say "Bail out!";
    say "Unreliable abs()";
    exit();
}

# 2008-May-01 .nextwith tailcalls removed to help rakudo.
# Probably degrades error messages, so restore once rakudo does .nextwith.

#?DOES 1
sub tryeq ($lhs, $rhs) {
    ok($lhs == $rhs, "$lhs == $rhs");
}

#?DOES 1
sub tryeq_sloppy ($lhs, $rhs, $todo1 = '') {
    my $todo = $todo1;  # TODO is rw
    $todo = ' # TODO ' ~ $todo if $todo;
    if ($lhs == $rhs) {
        if ($todo) {
            #&ok.nextwith($lhs==$rhs,$todo, :todo);
            ok($lhs==$rhs,$todo, :todo);
        } else {
            #&ok.nextwith($lhs==$rhs,$todo);
            ok($lhs==$rhs,$todo);
        }
    } else {
        my $error = abs($lhs - $rhs);
        $error   /= $lhs; # Syntax highlighting fix
        if ($todo) {
            #&ok.nextwith($error <1e-9,$todo ~ " # " ~ $lhs ~ " is close to " ~ $rhs, :todo);
            ok($error < 1e-9, $todo ~ " # " ~ $lhs ~ " is close to " ~ $rhs, :todo);
        } else {
            #&ok.nextwith($error <1e-9);
            ok($error < 1e-9);
        }
    }
}

# L
tryeq  13 %  4, 1;
tryeq -13 %  4, 3;
tryeq  13 % -4, -3;
tryeq -13 % -4, -1;

tryeq  13.0 %  4.0, 1;
tryeq -13.0 %  4.0, 3;
tryeq  13.0 % -4.0, -3;
tryeq -13.0 % -4.0, -1;

{
    tryeq 5 % 2.5, 0;
    tryeq 2.5 % 1, .5;
}

# RT #107492
ok 9 % (-9) == 0,    'modulo with negative divisor (1)';
ok (-9) % (-9) == 0, 'modulo with negative divisor (2)';


my $limit = 1e6;

ok abs( 13e21 %  4e21 -  1e21) < $limit;
ok abs(-13e21 %  4e21 -  3e21) < $limit;
ok abs( 13e21 % -4e21 - -3e21) < $limit;
ok abs(-13e21 % -4e21 - -1e21) < $limit;

# Hmm. Don t forget the simple stuff
tryeq 1 + 1, 2;
tryeq 4 + -2, 2;
tryeq -10 + 100, 90;
tryeq -7 + -9, -16;
tryeq -63 + +2, -61;
tryeq 4 + -1, 3;
tryeq -1 + 1, 0;
tryeq +29 + -29, 0;
tryeq -1 + 4, 3;
tryeq +4 + -17, -13;

# subtraction
tryeq 3 - 1, 2;
tryeq 3 - 15, -12;
tryeq 3 - -7, 10;
tryeq -156 - 5, -161;
tryeq -156 - -5, -151;
tryeq -5 - -12, 7;
tryeq -3 - -3, 0;
tryeq 15 - 15, 0;

tryeq 2147483647 - 0, 2147483647;
tryeq 0 - -2147483647, 2147483647;
# No warnings should appear;
{
    my $a;
    $a += 1;
    tryeq $a, 1;
    undefine $a;
    $a += -1;
    tryeq $a, -1;
    undefine $a;
    $a += 4294967290;
    tryeq $a, 4294967290;
    undefine $a;
    $a += -4294967290;
    tryeq $a, -4294967290;
    undefine $a;
    $a += 4294967297;
    tryeq $a, 4294967297;
    undefine $a;
    $a += -4294967297;
    tryeq $a, -4294967297;
}

{
    my $s;
    $s -= 1;
    tryeq $s, -1;
    undefine $s;
    $s -= -1;
    tryeq $s, +1;
    undefine $s;
    $s -= -4294967290;
    tryeq $s, +4294967290;
    undefine $s;
    $s -= 4294967290;
    tryeq $s, -4294967290;
    undefine $s;
    $s -= 4294967297;
    tryeq $s, -4294967297;
    undefine $s;
    $s -= -4294967297;
    tryeq $s, +4294967297;
}

# Multiplication

tryeq 1 * 3, 3;
tryeq -2 * 3, -6;
tryeq 3 * -3, -9;
tryeq -4 * -3, 12;

{   
    # 2147483647 is prime. bah.
    
    tryeq 46339 * 46341, 0x7ffea80f;
    tryeq 46339 * -46341, -0x7ffea80f;
    tryeq -46339 * 46341, -0x7ffea80f;
    tryeq -46339 * -46341, 0x7ffea80f;
}

# leading space should be ignored

tryeq 1 + " 1", 2;
tryeq 3 + " -1", 2;
tryeq 1.2, " 1.2";
tryeq -1.2, " -1.2";

# divide
#?pugs 4 skip 'div'
tryeq 28 div 14, 2;
tryeq 28 div -7, -4;
tryeq -28 div 4, -7;
tryeq -28 div -2, 14;

#?pugs 4 skip 'div'
is(9 div 4, 2, "9 div 4 == 2");
#?rakudo.parrot 2 todo 'negative div'
is(-9 div 4, -3, "-9 div 4 == -3");
is(9 div -4, -3, "9 div -4 == -3");
is(-9 div -4, 2, "-9 div -4 == 2");

# modulo
#?pugs 5 skip 'mod'
is  13 mod  4, 1,  '13 mod 4';
#?rakudo.parrot 2 todo 'negative mod'
is -13 mod  4, 3,  '-13 mod 4';
is  13 mod -4, -3, '13 mod -4';
is -13 mod -4, -1, '-13 mod -4';
is 4850761783423467784 mod 256, 8, '4850761783423467784 mod 256';

tryeq 2.5 / 2, 1.25;
tryeq 3.5 / -2, -1.75;
tryeq -4.5 / 2, -2.25;
tryeq -5.5 / -2, 2.75;

# exponentiation

is 2**2, 4;
is 2.2**2, 4.84;
is_approx 2**2.2,   4.59479341;
is_approx 2.2**2.2, 5.66669577;
is 1**0, 1;
is 1**1, 1;
isnt 2**3**4, 4096, "** is right associative";

# test associativity
is 2 ** 2 ** 3, 256, 'infix:<**> is right associative';

{
    #?pugs todo
    is_approx(-1, (0 + 1i)**2, "i^2 == -1");

    #?pugs todo
    is_approx(-1, (0.7071067811865476 + -0.7071067811865475i)**4, "sqrt(-i)**4 ==-1" );
    is_approx(1i, (-1+0i)**0.5, '(-1+0i)**0.5 == i ');
}

{
# Inf
    is Inf, Inf;
    is -Inf, -Inf;
    isnt Inf, -Inf;
    is (-Inf).abs, Inf;
    is Inf+100, Inf;
    is Inf-100, Inf;
    is Inf*100, Inf;
    is Inf / 100, Inf;
    is Inf*-100, -Inf;
    is Inf / -100, -Inf;
    is 100 / Inf, 0;
    #?pugs todo
    is Inf**100, Inf;
    is Inf*0, NaN;
    is Inf - Inf, NaN;
    is Inf*Inf, Inf;
    is Inf / Inf, NaN;
    is Inf*Inf / Inf, NaN;
    is Inf**0, 1;
    is 0**0, 1;
    is 0**Inf, 0;
}

#?pugs skip 'slow'
{
    my $inf1 = 100**Inf;
    is $inf1, Inf, "100**Inf";
    my $inf2 = Inf**Inf;
    is $inf2, Inf, "Inf**Inf";
}

# See L<"http://mathworld.wolfram.com/Indeterminate.html">
# for why these three values are defined like they are.
#?pugs skip 'slow!'
{
    is 0.9**Inf, 0,   "0.9**Inf converges towards 0";
    is 1.1**Inf, Inf, "1.1**Inf diverges towards Inf";
    #?niecza todo "No agreement over correct behavior here -- above web page not helpful!"
    is 1**Inf, 1;
}

{
    # NaN
    is NaN, NaN;
    is -NaN, NaN;
    is NaN+100, NaN;
    is NaN-100, NaN;
    is NaN*100, NaN;
    is NaN / 100, NaN;
    is NaN**100, NaN;
    is NaN+NaN, NaN;
    is NaN - NaN, NaN;
    is NaN*NaN, NaN;
    is NaN / NaN, NaN;

    is NaN+Inf, NaN;
    is NaN - Inf, NaN;
    is NaN*Inf, NaN;
    is NaN / Inf, NaN;
    is Inf / NaN, NaN;

    my $nan1 = NaN**NaN;
    is $nan1, NaN, "NaN**NaN";
    my $nan2 = NaN**Inf;
    is $nan2, NaN, "NaN**Inf";
    my $nan3 = Inf**NaN;
    is $nan3, NaN, "Inf**NaN";
}

=begin pod

=head2 BEHAVIOUR OF DIVISION AND MODULUS WITH ZERO

This test tests the behaviour of '%' and '/' when used with
a zero modulus resp. divisor.

All uses of a zero modulus or divisor should 'die', and the
'die' should be non-fatal.

=end pod

my $x;

eval_dies_ok('say 3 % 0', 'Modulo zero dies and is catchable');
dies_ok( { $x = 0; say 3 % $x; }, 'Modulo zero dies and is catchable with VInt/VRat variables');
dies_ok( { $x := 0; say 3 % $x; }, 'Modulo zero dies and is catchable with VRef variables');

eval_dies_ok('say 3 div 0', 'Division by zero dies and is catchable');
#?pugs skip 'div'
dies_ok( { $x = 0; say 3 div $x; }, 'Division by zero dies and is catchable with VInt div VRat variables');
#?pugs skip 'div'
dies_ok( { $x := 0; say 3 div $x; }, 'Division by zero dies and is catchable with VRef variables');

# This is a rakudo regression wrt bignum:
{
    my $f = 1; $f *= $_ for 2..25;
    ok $f == 15511210043330985984000000, 
       'Can calculate 25! without loss of precision';
    ok 2**65 == 36893488147419103232,
       'Can calculate 2**65 without loss of precision';
}

# RT #73264
# Rat literals are gone
{
    ok 1/7 / 1/7 == 1/49, 'no more Rat literals, infix: has normal left assoc';
}

# RT #73386
eval_dies_ok '3 !+ 4',  'infix:<+> is not iffy enough';

# RT #100768
eval_lives_ok '-Inf', '-Inf warns (and yields 0) but does not give an error';

# RT #108052
#?pugs skip '-string'
{
    my role orig-string[$o] { method Str() { $o.Str } };
    my $a = 7 but orig-string['7'];
    is ($a - 3).Str, '4',
        'infix:<-> produces a proper Int, even if some of the types invovled have mixins';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/assign-is-not-binding.t0000664000175000017500000000216512224265625022663 0ustar  moritzmoritzuse v6;
use Test;

plan 8;

#                      +---- UTF8 non-breaking space here!
#                      |
#                      V
# L


# very simple assignment

{
    my $foo = 'FOO';
    is  $foo, 'FOO', 'Can assign string to scalar 1';
    my $bar = 'BAR';
    is  $foo, 'FOO', 'Can assign string to scalar 2';

    $foo = $bar;
    is $foo, 'BAR', 'Can assign scalar to scalar';

    $foo = 'FOO';
    is $bar, 'BAR', "Assignment didn't create a binding";
}

# test that assignment from arrays to scalars doesn't create a binding:

{
    my @array = 23, 42;
    is @array[0], 23, 'Could assign first element';
    is @array[1], 42, 'Could assign second element';
    my $temp = @array[0];
    is $temp, 23, 'Could retrieve first element to a scalar';
    #rakudo skip 'Broken in ng1'
    # {
    #     @array[0] = @array[1];
    #     is $temp, 23, "Assignment to scalar didn't create a binding"
    # }
}

{
    my $a = 42;
    my @list = ($a);
    $a = 24;
    is @list[0], 42, "Assignment to scalar didn't create a binding";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/assign.t0000775000175000017500000006404212224265625020051 0ustar  moritzmoritzuse v6;
use Test;

#                      +---- UTF8 non-breaking space here!
#                      |     (in case of 22-char wide screen)
#                      V
# L

plan 286;


# tests various assignment styles
{
    my ($foo, $bar) = ("FOO", "BAR");
    is($foo, "FOO", "assigned correct value to first of two scalars");
    is($bar, "BAR", "... and second");

    ($foo, $bar) = ($bar, $foo);
    is($foo, "BAR", "swap assignment works for the first value");
    is($bar, "FOO", "... and second");
}

{
    my $x = 1;
    &infix:<=>.($x, 0);
    #?pugs todo
    is($x, 0, 'assignment operator called as function');
    my Int $y;
    lives_ok { &infix:<=>($y, 3) }, 'assignment as function with types (1)';
    #?pugs todo
    dies_ok  { &infix:<=>($y, 'foo') }, 'assignment as function with types (2)';

}

#?pugs todo
{
    my $x = 1;
    infix:<=>($x, 0);
    is($x, 0, 'assignment operator called as function');
}

{
    # swap two elements in the same array 
    # (moved this from array.t)
    my @a = 1 .. 5;
    @a[0,1] = @a[1,0];
    is(@a[0], 2, "slice assignment swapping two element in the same array");
    is(@a[1], 1, "slice assignment swapping two element in the same array");
}

{
    # swap two elements as slice, dwim slice from @b subscript
    
    my @a = 1 .. 2;
    my @b = 0 .. 2;
    @a[@b] = @a[1, 0], 3;
    is(@a[0], 2, "slice assignment swapping with array dwim");
    is(@a[1], 1, "slice assignment swapping with array dwim");
    is(@a[2], 3, "slice assignment swapping with array dwim makes listop");
}

{
    # list assignments

    my @a = 1 .. 3;
    my ($one, $two, $three) = @a;
    is($one, 1, 'list assignment my ($, $, $) = @ works');
    is($two, 2, 'list assignment my ($, $, $) = @ works');
    is($three, 3, 'list assignment my ($, $, $) = @ works');

}


#?pugs skip 'skipping assignment with skipped values via $'
{
    # testing list assignments with skipped values
     my ($one, $, $three) = 1..3;
     is("$one $three", "1 3", 'list assignment my ($a, $, $b) = @ works');

     my ($, $two) = 1..2;
     is($two, 2, 'list assignment my ($, $a) = @ works');
     my ($, $, $, $four) = 1..4;
     is($four, 4, 'list assignment my ($, $, $, $a) = @ works');

     my ($, @b, $c) = 1..4;
     is(~@b, "2 3 4", 'list assignment my ($, @) = @ works');
     ok(!defined($c), 'list assignment my ($, @, $c) = @ works');
}

#?pugs skip "skipping assignment with skipped values via * in signature"
{
    # testing list assignments with skipped values
     my ($one, $, $three) = 1..3;
     is("$one $three", "1 3", 'list assignment my ($a, $, $b) = @ works');

     my ($, $two) = 1..2;
     is($two, 2, 'list assignment my ($, $a) = @ works');
     my ($, $, $, $four) = 1..4;
     is($four, 4, 'list assignment my ($, $, $, $a) = @ works');

     my ($, @b, $c) = 1..4;
     is(~@b, "2 3 4", 'list assignment my ($, @) = @ works');
     ok(!defined($c), 'list assignment my ($, @, $c) = @ works');
}

#?pugs skip "skipping assignment with skipped values via * in lvalue"
{
    # testing list assignments with skipped values
     my ($one, $two, $three, $four);
     ($one, *, $three) = 1..3;
     is("$one $three", "1 3", 'list assignment ($a, *, $b) = @ works');

     (*, $two, *) = 1..3;
     is($two, 2, 'list assignment (*, $a, *) = @ works');
     (*, *, *, $four) = 1..4;
     is($four, 4, 'list assignment (*, *, *, $a) = @ works');

     my (@b, $c);
     (*, @b, $c) = 1..4;
     is(~@b, "2 3 4", 'list assignment (*, @) = @ works');
     ok(!defined($c), 'list assignment (*, @, $c) = @ works');
}

#?pugs skip 'NYI'
{
    # testing signature binding with skipped values via *@ in a signature
    my ($one, *@) = 1..4;
    is($one, 1, 'signature binding my ($one, *@) = 1..4 works');
    my ($a, $b, *@) = 1..4;
    is("$a $b", "1 2", 'signature binding my ($a, $b, *@) = 1..4 works');
    my ($c, $d, *@) = 1..2;
    is("$c $d", "1 2", 'signature binding my ($c, $d, *@) = 1..2 works');
}

{
   # testing list assignment syntax

    my ($a,$b,$c,@a);
    ($a,$b,$c) = 1 .. 3;
    @a = 1 .. 3;
    my ($s,@b) = 1 .. 3;

    is($a,1,"'\$a' is '1'?: (\$,\$,\$) = 1 .. 3");
    is($b,2,"'\$b' is '2'?: (\$,\$,\$) = 1 .. 3");
    is($c,3,"'\$c' is '3'?: (\$,\$,\$) = 1 .. 3"); 
    is(@a,'1 2 3',"'{\@a}' is '1 2 3'?:       \@a = 1 .. 3");
    is($s,'1',  "\$s is '1'?:       my (\$s,\@a) = 1 .. 3");
    #?pugs todo
    is(@b,'2 3',"'{\@b}' is '2 3'?: my (\$s,\@a) = 1 .. 3"); 
}

# RT #74302
{
    my ($a, %b) = "!", a => "1", b => "2", c => "3";
    is $a, "!", "got scalar in (scalar,hash) = list";
    #?pugs todo
    is %b.keys.sort.join(", "), "a, b, c", "got hash in (scalar,hash) = list";
}

{
    my @a;
    @a[1, 2, 3] = 100, 200, 300;
    is(@a[1], 100, "assigned correct value from list to sliced array");
    is(@a[2], 200, "... and second");
    is(@a[3], 300, "... and third");
    ok(!defined(@a[0]), "won't modify unassigned one");

    my @b;
    (@b[2, 1, 0]) = 401, 201, 1;
    #?pugs todo
    is(@b[0], 1, "assigned correct value from list to unsorted sliced array");
    #?pugs todo
    is(@b[1], 201, "... and second");
    is(@b[2], 401, "... and third");
}

{ 
    my @c;
    my @d;
    (@c[1, 2], @c[3], @d) = 100, 200, 300, 400, 500;
    is(@c[1], 100, "assigned correct value from list to slice-in-list");
    #?pugs todo
    is(@c[2], 200, "... and second");
    #?pugs 3 todo 'feature'
    #?niecza 3 todo 'feature'
    is(@c[3], 300, "... and third");
    is(@d[0], 400, "... and fourth");
    is(@d[1], 500, "... and fifth");
    ok(!defined(@c[0]), "won't modify unassigned one");

}

{
    # chained @array = %hash = list assignment 
    my (@a, @b, %h);
    @a = %h = 1,2;
    @b = %h;
    is(@a[0], @b[0], 'chained @ = % = list assignment');
    is(@a[1], @b[1], 'chained @ = % = list assignment');
}

{
    # chained my $scalar = my %hash = list assignment 
    my $s = my %h = 1,2;
    my $t = %h;
    is($s, $t, 'chained $ = % = list assignment');
}

#?rakudo skip 'Odd number of elements found where hash expected'
{
    # chained $scalar = %hash = list assignment 
    my ($s, $t, %h);
    $s = %h = 1,2;  # needs (1,2) to work, why???
    $t = %h;
    is($s, $t, 'chained $ = % = list assignment');
}

{
    # (@b, @a) = (@a, @b) assignment
    my (@a, @b);
    @a = 1;
    @b = 2;
    (@b, @a) = (@a, @b);
    #?pugs todo
    ok(!defined(@a[0]), '(@b, @a) = (@a, @b) assignment \@a[0] == undefined');
    is(@b[0], 1,     '(@b, @a) = (@a, @b) assignment \@b[0]');
    #?pugs todo
    is(@b[1], 2,     '(@b, @a) = (@a, @b) assignment \@b[1]');
}

{
    # (@b, @a) = @a, @b assignment
    my (@a, @b);
    @a = (1);
    @b = (2);
    (@b, @a) = @a, @b;
    #?pugs todo
    ok(!defined(@a[0]), '(@b, @a) = @a, @b assignment \@a[0] == undefined');
    is(@b[0], 1,     '(@b, @a) = @a, @b assignment \@b[0]');
    #?pugs todo
    is(@b[1], 2,     '(@b, @a) = @a, @b assignment \@b[1]');
}

my @p;

{
    my $a;
    @p = $a ||= 3, 4;
    is($a,3, "||= operator");
    is(@p[0],3, "||= operator parses as item assignment 1");
    is(@p[1],4, "||= operator parses as item assignment 2");
    @p = $a ||= 10, 11;
    is($a,3, "... and second");
    is(@p[0],3, "||= operator parses as item assignment 3");
    is(@p[1],11, "||= operator parses as item assignment 4");
}

#?niecza todo
#?pugs todo
{
    my $a;
    @p = $a or= 3, 4;
    is($a,3, "or= operator");
    is(@p[0],3, "or= operator parses as item assignment 1");
    is(@p[1],4, "or= operator parses as item assignment 2");
    @p = $a or= 10, 11;
    is($a,3, "... and second");
    is(@p[0],3, "or= operator parses as item assignment 3");
    is(@p[1],11, "or= operator parses as item assignment 4");
}

{
    my $a;
    @p = $a //= 3, 4;
    is($a, 3, "//= operator");
    is(@p[0],3, "//= operator parses as item assignment 1");
    is(@p[1],4, "//= operator parses as item assignment 2");
    @p = $a //= 10, 11;
    is($a, 3, "... and second");
    is(@p[0],3, "//= operator parses as item assignment 3");
    is(@p[1],11, "//= operator parses as item assignment 4");
    my %hash;
    %hash //= hash();
    isa_ok(%hash, Hash, "Verify //= autovivifies correctly");
    %hash //= [];
    isa_ok(%hash, Array, "Verify //= autovivifies correctly");

    my $f //= 5;
    is $f, 5, '//= also works in declaration';
}

#?pugs skip 'Cannot cast from VList [] to Handle'
{
    my $a;
    @p = $a orelse= 3, 4;
    #?niecza 3 todo
    is($a, 3, "orelse= operator");
    is(@p[0],3, "orelse= operator parses as item assignment 1");
    is(@p[1],4, "orelse= operator parses as item assignment 2");

    @p = $a orelse= 10, 11;
    #?niecza 3 todo
    is($a, 3, "... and second");
    is(@p[0],3, "orelse= operator parses as item assignment 3");
    is(@p[1],11, "orelse= operator parses as item assignment 4");

    my %hash;
    %hash orelse= hash();
    isa_ok(%hash, Hash, "Verify orelse= autovivifies correctly");
    %hash orelse= [];
    isa_ok(%hash, Array, "Verify orelse= autovivifies correctly");

    my $f orelse= 5;
    is $f, 5, 'orelse= also works in declaration';
}


{
    my $a = 3;
    @p = $a &&= 42, 43;
    is($a, 42, "&&= operator");
    is(@p[0],42, "&&= operator parses as item assignment 1");
    is(@p[1],43, "&&= operator parses as item assignment 2");
    $a = 0;
    @p = $a &&= 10, 11;
    is($a, 0, "... and second");
    is(@p[0],0, "&&= operator parses as item assignment 3");
    is(@p[1],11, "&&= operator parses as item assignment 4");
    my $x = True; $x &&= False; 
    is($x, False, "&&= operator with True and False");
}

#?pugs skip 'Cannot cast from VInt 42 to Handle'
{
    my $a = 3;
    @p = $a and= 42, 43;
    #?niecza 3 todo
    is($a, 42, "and= operator");
    is(@p[0],42, "and= operator parses as item assignment 1");
    is(@p[1],43, "and= operator parses as item assignment 2");
    $a = 0;
    @p = $a and= 10, 11;
    is($a, 0, "... and second");
    is(@p[0],0, "and= operator parses as item assignment 3");
    #?niecza todo
    is(@p[1],11, "and= operator parses as item assignment 4");
    my $x = True; $x and= False;
    is($x, False, "and= operator with True and False");
}

{
    my $c; 
    (($c = 3) = 4); 
    is($c, 4, '(($c = 3) = 4) return val should be good as an lval');
}

{
    my $x = 42;
    @p = $x += 6, 7;
    is($x, 48, '+= operator');
    is(@p[0],48, "+= operator parses as item assignment 1");
    is(@p[1],7, "+= operator parses as item assignment 2");
}

{
    my $x = 42;
    @p = $x -= 6, 7;
    is($x, 36, '-= operator');
    is(@p[0],36, "-= operator parses as item assignment 1");
    is(@p[1],7, "-= operator parses as item assignment 2");
}

{
    my $x = 4;
    @p = $x *= 3, 2;
    is($x, 12, '*= operator');
    is(@p[0],12, "*= operator parses as item assignment 1");
    is(@p[1],2, "*= operator parses as item assignment 2");
}

#?pugs skip 'div='
{
    my $x = 6;
    @p = $x div= 3, 4;
    is($x, 2, 'div= operator');
    is(@p[0],2, "div= operator parses as item assignment 1");
    is(@p[1],4, "div= operator parses as item assignment 2");
}

{
    my $x = 2;
    @p = $x **= 3, 4;
    is($x, 8, '**= operator');
    is(@p[0],8, "**= operator parses as item assignment 1");
    is(@p[1],4, "**= operator parses as item assignment 2");
}

{
    my $x = "abc";
    @p = $x ~= "yz", "plugh";
    is($x, 'abcyz', '~= operator');
    is(@p[0],'abcyz', "~= operator parses as item assignment 1");
    is(@p[1],'plugh', "~= operator parses as item assignment 2");
}

# RT #64818
#?pugs skip 'R~= NYI'
{
    eval_dies_ok q{my $foo = 'foo'; $foo R~= 'foo';},
                 'use of R~= operator on a non-container dies';
    my ($x, $y) = ; $x R~= $y;
    is("$x $y", "a ba", "R~= operator works");
}

{
    my $x = "abc";
    @p = $x x= 3, 4;
    is($x, 'abcabcabc', 'x= operator');
    is(@p[0],'abcabcabc', "x= operator parses as item assignment 1");
    is(@p[1],4, "x= operator parses as item assignment 2");
}

{
    my @x = ( 'a', 'z' );
    @p = @x xx= 3, 4;
    is(+@x,   6,   'xx= operator elems');
    is(@x[0], 'a', 'xx= operator 0');
    is(@x[1], 'z', 'xx= operator 1');
    is(@x[2], 'a', 'xx= operator 2');
    is(@x[3], 'z', 'xx= operator 3');
    is(@x[4], 'a', 'xx= operator 4');
    is(@x[5], 'z', 'xx= operator 5');
    ok(!defined(@x[6]), 'xx= operator 6');
    is(~@p,~(@x,4), "xx= operator parses as item assignment 1");
}

{
    my $x = 1;
    @p = $x +&= 2, 3;
    is($x, 0, '+&= operator');
    is(@p[0],0, "+&= operator parses as item assignment 1");
    is(@p[1],3, "+&= operator parses as item assignment 2");
}

{
    my $x = 1;
    @p = $x +|= 2, 123;
    is($x, 3, '+|= operator');
    is(@p[0],3, "+|= operator parses as item assignment 1");
    is(@p[1],123, "+|= operator parses as item assignment 2");
}

#?niecza skip "Buffer bitops NYI"
{
    my $x = "z";
    @p = $x ~&= "I", "J";
    is($x, 'H', '~&= operator');
    is(@p[0],'H', "~&= operator parses as item assignment 1");
    is(@p[1],'J', "~&= operator parses as item assignment 2");
}

#?niecza skip "Buffer bitops NYI"
{
    my $x = "z";
    @p = $x ~|= "I", "J";
    is($x, '{', '~|= operator');
    is(@p[0],'{', "~|= operator parses as item assignment 1");
    is(@p[1],'J', "~|= operator parses as item assignment 2");
}

{
    my $x = 4;
    @p = $x %= 3, 4;
    is($x, 1, '%= operator');
    is(@p[0],1, "%= operator parses as item assignment 1");
    is(@p[1],4, "%= operator parses as item assignment 2");
}

{
    my $x = 1;
    @p = $x +^= 3, 4;
    is($x, 2, '+^= operator');
    is(@p[0],2, "+^= operator parses as item assignment 1");
    is(@p[1],4, "+^= operator parses as item assignment 2");
}

#?niecza skip "Buffer bitops NYI"
{
    my $x = "z";
    @p = $x ~^= "C", "D";
    is($x, 9, '~^= operator');
    is(@p[0],9, "~^= operator parses as item assignment 1");
    is(@p[1],'D', "~^= operator parses as item assignment 2");
}

#?niecza skip "No ^^ yet"
{
    my $x;
    @p = $x ^^= 42, 43;
    is($x, 42, '^^= operator');
    is(@p[0],42, "^^= operator parses as item assignment 1");
    is(@p[1],43, "^^= operator parses as item assignment 2");
    $x ^^= 15;
    #?rakudo todo 'unknown'
    is $x, False, '^^= with two true arguments yields False';
    $x ^^= 'xyzzy';
    is $x, 'xyzzy', "^^= doesn't permanently falsify scalars";
}

# RT #76820
#?niecza skip "No xor yet"
#?pugs skip 'Cannot cast from VInt 42 to Handle'
{
    my $x;
    @p = $x xor= 42, 43;
    is($x, 42, 'xor= operator');
    is(@p[0],42, "xor= operator parses as item assignment 1");
    is(@p[1],43, "xor= operator parses as item assignment 2");
    $x xor= 15;
    #?rakudo todo 'unknown'
    is $x, False, 'xor= with two true arguments yields False';
    $x xor= 'xyzzy';
    is $x, 'xyzzy', "xor= doesn't permanently falsify scalars";
}

{
    my $x = 42;
    @p = $x ?|= 24, 25;
    is($x, True, '?|= operator');
    is(@p[0], True, "?|= operator parses as item assignment 1");
    is(@p[1],25, "?|= operator parses as item assignment 2");
}

#?pugs eval 'parsefail'
{
    my $x = 42;
    @p = $x ?&= 24, 25;
    is($x, True, '?&= operator');
    is(@p[0], True, "?&= operator parses as item assignment 1");
    is(@p[1], 25, "?&= operator parses as item assignment 2");
}

{
    my $x = 0;
    @p = $x ?^= 42, 43;
    is($x, True, '?^= operator');
    is(@p[0], True, "?^= operator parses as item assignment 1");
    is(@p[1], 43, "?^= operator parses as item assignment 2");
}

#?pugs eval 'parsefail'
{
    my $x = 1;
    @p = $x +<= 8, 9;
    is($x, 256, '+<= operator');
    is(@p[0],256, "+<= operator parses as item assignment 1");
    is(@p[1],9, "+<= operator parses as item assignment 2");
}

#?pugs eval 'parsefail'
{
    my $x = 511;
    @p = $x +>= 8, 9;
    is($x, 1, '+>= operator');
    is(@p[0],1, "+>= operator parses as item assignment 1");
    is(@p[1],9, "+>= operator parses as item assignment 2");
}

# XXX: The following tests assume autoconvertion between "a" and buf8 type
#?pugs eval 'parsefail'
#?rakudo skip "Two terms in a row"
#?niecza skip "Buffer bitops NYI"
{
    my $x = "a";
    @p = $x ~<= 8, 9;
    is($x, "a\0", '~<= operator');
    is(@p[0],"a\0", "~<= operator parses as item assignment 1");
    is(@p[1],9, "~<= operator parses as item assignment 2");
}

#?pugs eval 'parsefail'
#?rakudo skip "expects a term, found infix >= instead"
#?niecza skip "Buffer bitops NYI"
{
    my $x = "aa";
    @p = $x ~>= 8, 9;
    is($x, "a", '~>= operator');
    is(@p[0],"a", "~>= operator parses as item assignment 1");
    is(@p[1],9, "~>= operator parses as item assignment 2");
}

# Tests of dwimming scalar/listiness of lhs

sub l () { 1, 2 };

{
    my $x;
    $x  = l(), 3, 4;
    is $x.elems, 2, 'item assignment infix:<=> is tighter than the comma';
}

{
    my $x;
    my @a = ($x = l(), 3, 4);
    is $x.elems, 2, 'item assignment infix:<=> is tighter than the comma (2)';
    is @a.elems, 3, 'item assignment infix:<=> is tighter than the comma (3)';
}

{
    package Foo {
	our $b;
	my @z = ($::('Foo::b') = l(), l());
        #?pugs todo
	is($b.elems, 2,    q/lhs treats $::('Foo::b') as scalar (1)/);
	is(@z.elems, 3,    q/lhs treats $::('Foo::b') as scalar (2)/);
    }
}

{
    my @z = ($Foo::c = l, l);
    is($Foo::c.elems, 2,    'lhs treats $Foo::c as scalar (1)');
    is(@z.elems,      3,    'lhs treats $Foo::c as scalar (2)');
}

{
    my @a;
    my @z = ($(@a[0]) = l, l);
    is(@a[0].elems, 2, 'lhs treats $(@a[0]) as scalar (1)');
    #?rakudo todo 'item assignment'
    #?niecza todo
    #?pugs todo
    is(@z.elems,    2, 'lhs treats $(@a[0]) as scalar (2)');
}

#?niecza todo
{
    my $a;
    my @z = (($a) = l, l, l);
    #?pugs todo
    is($a.elems, 6, 'lhs treats ($a) as list');
    #?rakudo todo 'item/list assignment'
    #?pugs todo
    is(@z.elems, 6, 'lhs treats ($a) as list');
}

#?pugs skip "Can't modify constant item: VNum Infinity"
{
    my $a;
    my @z = (($a, *) = l, l, l);
    is($a.elems, 1, 'lhs treats ($a, *) as list (1)');
    #?rakudo todo 'list assignment with ($var, *)'
    #?niecza todo 'assigning to ($a, *)'
    is(@z.elems, 6, 'lhs treats ($a, *) as list (2)');
}

#?rakudo skip 'cannot modifiy an immutable value'
#?niecza skip 'Unable to resolve method LISTSTORE in class List'
{
    my $a;
    my @z = (@$a = l, l, l);
    is($a.elems, 6, 'lhs treats @$a as list (1)');
    is @z.elems, 6, 'lhs treats @$a as list (2)';
}

#?rakudo skip 'cannot modifiy an immutable value'
#?niecza skip '$a[] autovivification (unspecced?)'
#?pugs todo
{
    my $a;
    $a[] = l, l, l;
    is($a.elems, 6, 'lhs treats $a[] as list');
}

{
    my $a;
    my $b;
    my @z = (($a,$b) = l, l);
    is($a,  1,   'lhs treats ($a,$b) as list');
    is($b,  2,   'lhs treats ($a,$b) as list');
    is(+@z, 2,   'lhs treats ($a,$b) as list, and passes only two items on');
}

{
    my @a;
    my @z = (@a[0] = l, l);
    #?rakudo todo 'list assignment to scalar'
    #?niecza todo
    #?pugs todo
    is(@a[0].elems, 1,  'lhs treats @a[0] as one-item list');
    is(@z.elems,    1,  'lhs treats @a[0] as one-item list');
    ok(!defined(@a[1]), 'lhs treats @a[0] as one-item list');
}

{
    my @a;
    my @z = (@a[0,] = l, l);
    is(@a[0,].elems, 1,  'lhs treats @a[0,] as one-item list');
    is(@z.elems,     1,  'lhs treats @a[0,] as one-item list');
    ok(defined(@a[1,]),  'lhs treats @a[0,] as one-item list');
}

{
    my %a;
    my @z = (%a = l, l);
    #?rakudo 2 todo 'list assignment to scalar'
    #?niecza 2 todo
    #?pugs   2 todo
    is(%a{"x"}.elems, 1, 'lhs treats %a as one-item list');
    is(@z[0].elems,   1, 'lhs treats %a as one-item list');
    ok(!defined(@z[1]),  'lhs treats %a as one-item list');
}

{
    my %a;
    my @z = (%a = l, l);
    is(%a, 1,    'lhs treats %a as list');
    is(%a, 2,    'lhs treats %a as list');
    is(%a, 1,    'lhs treats %a as list');
}

{
    my %a;
    my @z = (%a{'x'} = l, l);
    #?rakudo 2 todo 'list assignment to scalar'
    #?niecza 2 todo
    #?pugs   2 todo
    is(%a{"x"}, 1,        q/lhs treats %a{'x'} as list/);
    is(~@z[0], '1',       q/lhs treats %a{'x'} as list/);
    ok(!defined(@z[1]),   q/lhs treats %a{'x'} as list/);
}

{
    my %a;
    my @z = (%a{'x','y','z'} = l, l);
    is(%a, 1,    q/lhs treats %a{'x','y','z'} as list/);
    is(%a, 2,    q/lhs treats %a{'x','y','z'} as list/);
    is(%a, 1,    q/lhs treats %a{'x','y','z'} as list/);
    is(@z[0], 1,    q/lhs treats %a{'x','y','z'} as list/);
    is(@z[1], 2,    q/lhs treats %a{'x','y','z'} as list/);
    is(@z[2], 1,    q/lhs treats %a{'x','y','z'} as list/);
}

{
    my %a;
    my @z = (%a{'x'..'z'} = l, l);
    is(%a, 1,    q/lhs treats %a{'x'..'z'} as list/);
    is(%a, 2,    q/lhs treats %a{'x'..'z'} as list/);
    is(%a, 1,    q/lhs treats %a{'x'..'z'} as list/);
    is(@z[0], 1,    q/lhs treats %a{'x'..'z'} as list/);
    is(@z[1], 2,    q/lhs treats %a{'x'..'z'} as list/);
    is(@z[2], 1,    q/lhs treats %a{'x'..'z'} as list/);
}


{
    my @a;
    my @b = (0,0);
    my $c = 1;
    my @z = (@a[@b[$c]] = l, l);
    #?rakudo 3 todo 'list assignment, autovivification (?)'
    #?niecza 3 todo
    #?pugs   3 todo
    is(~@a,    '1', 'lhs treats @a[@b[$c]] as list');
    is(~@z[0], '1', 'lhs treats @a[@b[$c]] as list');
    is(!defined(@z[1]), 'lhs treats @a[@b[$c]] as list');
}

{
    my @a;
    my @b = (0,0);
    my $c = 1;
    my @z = (@a[@b[$c,]] = l, l);
    is(~@a,     '1',    'lhs treats @a[@b[$c,]] as list');
    #?rakudo todo 'list assignment'
    #?niecza todo
    #?pugs todo
    is(~@z[0],  '2',    'lhs treats @a[@b[$c,]] as list');
    ok(!defined(@z[1]), 'lhs treats @a[@b[$c,]] as list');
}

{
    my @a;
    my $b = 0;
    my sub foo { \@a }
    my @z = (foo()[$b] = l, l);
    #?rakudo todo 'list assignment'
    #?niecza todo
    is(@a.elems,    1,  'lhs treats foo()[$b] as list');
    #?pugs todo
    is(@z[0].elems, 1,  'lhs treats foo()[$b] as list');
    #?rakudo todo 'list assignment'
    #?niecza todo
    ok(!defined(@z[1]), 'lhs treats foo()[$b] as list');
}

{
    my @a;
    my $b = 0;
    my sub foo { \@a }
    my @z = (foo()[$b,] = l, l);
    #?rakudo todo 'list assignment'
    #?niecza todo
    is(@a.elems,    1,  'lhs treats foo()[$b,] as list');
    #?rakudo todo 'list assignment'
    is(@z[0].elems, 1,  'lhs treats foo()[$b,] as list');
    #?niecza todo
    ok(!defined(@z[1]), 'lhs treats foo()[$b,] as list');
}

{
    my @a;
    my $b = 0;
    my @z = ($(@a[$b]) = l, l);
    is(@a.elems,    1, 'lhs treats $(@a[$b]) as item (1)');
    #?rakudo 2 todo 'item assignment'
    #?niecza 2 todo
    #?pugs   2 todo
    is(@a[0].elems, 1, 'lhs treats $(@a[$b]) as item (2)');
    is(@z[1].elems, 3, 'lhs treats $(@a[$b]) as item (3)');
}



# L fails"
{
    class A {};
    my $x = ['a'];
    multi infix:<=> (A $a, Str $value) { $x.push: $value; }  #OK not used
    (A.new() = 'b');
    is $x.join(','), 'a,b', 'New multi infix:<=> works';
    $x = 'c';
    #?pugs todo
    is $x, 'c', '...without screwing up ordinary assignment';
}

# RT #77142
{
    my $cc = 0;
    sub called($ignored) {  #OK not used
        $cc = 1;
    };

    #?pugs todo
    dies_ok { called pi = 4 },
        'correct precedence between sub call and assignment (1)';
    is $cc, 0,
        'correct precedence between sub call and assignment (2)';

}

# RT 77586
{
    my %bughunt = 1 => "foo", 2 => "bar", 3 => "foo";
    my %correct = grep { .value ne "bar" }, %bughunt.pairs;
    %bughunt    = grep { .value ne "bar" }, %bughunt.pairs;  
    is %bughunt, %correct,
       'Assign to hash with the same hash on rhs (RT 77586)';
}

# RT 93972
{
    my $rt93972 = 1, 2, 3;
    $rt93972 = $rt93972.grep({1});
    is $rt93972, [1],
       'Assign to array with the same array on rhs (RT 93972)';
    $rt93972 = (1, 2, 3);
    $rt93972 = $rt93972.grep({1});
    is $rt93972.join(','), '1,2,3', 'same with Parcel';
}

#?pugs skip 'Cannot cast from VList to VCode'
{
    my @bughunt = 1, 2, 3;
    @bughunt = @bughunt.grep(1);
    is @bughunt, [1],
       'Assign to array with the same array on rhs (RT 93972)';
}

# RT #77174
{
    my @a //= (3);
    #?pugs todo
    is @a, "";
    my @b ||= (3);
    is @b, "3";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/autoincrement-range.t0000664000175000017500000002632612224265625022534 0ustar  moritzmoritzuse v6;
use Test;

plan 96;

# TODO: Check that "Failure" results are "Decrement out of range"
#       and not some other unrelated error.

my $x;

{
    diag( "Tests for 'A' .. 'Z'" );
    $x = "ZZ";
    is( ++$x, "AAA", "'ZZ'++ is 'AAA'" );
    $x = "AAA";
    #?niecza skip "Failure NYI"
    #?pugs skip "Failure NYI"
    ok( --$x ~~ Failure, "'AAA'-- fails" );
    $x = "0A";
    is( ++$x, "0B", "'0A'++ is '0B'" );
    $x = "0B";
    #?pugs todo
    is( --$x, "0A", "'0B'-- is '0A'" );
    $x = "0Z";
    is( ++$x, "1A", "'0Z'++ is '1A'" );
    $x = "1A";
    #?pugs todo
    is( --$x, "0Z", "'1A'-- is '0Z'" );
    $x = "A99";
    is( ++$x, "B00", "'A99'++ is 'B00'" );
    $x = "B00";
    #?pugs todo
    is( --$x, "A99", "'B00'-- is 'A99'" );
}
{
    diag( "Tests for 'a' .. 'z'" );
    $x = "zz";
    is( ++$x, "aaa", "'zz'++ is 'aaa'" );
    $x = "aaa";
    #?niecza skip "Failure NYI"
    #?pugs skip "Failure NYI"
    ok( --$x ~~ Failure, "'aaa'-- fails" );
    $x = "0a";
    is( ++$x, "0b", "'0a'++ is '0b'" );
    $x = "0b";
    #?pugs todo
    is( --$x, "0a", "'0b'-- is '0a'" );
    $x = "0z";
    is( ++$x, "1a", "'0z'++ is '1a'" );
    $x = "1a";
    #?pugs todo
    is( --$x, "0z", "'1a'-- is '0z'" );
    $x = "a99";
    is( ++$x, "b00", "'a99'++ is 'b00'" );
    $x = "b00";
    #?pugs todo
    is( --$x, "a99", "'b00'-- is 'a99'" );
}
{
    diag( "Tests for '\x[391]' .. '\x[3a9]' (Greek uppercase)" );
    $x = "\x[3a9]\x[3a9]";
    #?pugs todo
    is( ++$x, "\x[391]\x[391]\x[391]",
        "'\x[3a9]\x[3a9]'++ is '\x[391]\x[391]\x[391]'" );
    $x = "\x[391]\x[391]\x[391]";
    #?niecza skip "Failure NYI"
    #?pugs skip "Failure NYI"
    ok( --$x ~~ Failure, "'\x[391]\x[391]\x[391]'-- fails" );
    $x = "A\x[391]";
    is( ++$x, "A\x[392]", "'A\x[391]'++ is 'A\x[392]'" );
    $x = "A\x[392]";
    #?pugs todo
    is( --$x, "A\x[391]", "'A\x[392]'-- is 'A\x[391]'" );
    $x = "A\x[3a9]";
    #?pugs todo
    is( ++$x, "B\x[391]", "'A\x[3a9]'++ is 'B\x[391]'" );
    $x = "B\x[391]";
    #?pugs todo
    is( --$x, "A\x[3a9]", "'B\x[391]'-- is 'A\x[3a9]'" );
    $x = "\x[391]ZZ";
    is( ++$x, "\x[392]AA", "'\x[391]ZZ'++ is '\x[392]AA'" );
    $x = "\x[392]AA";
    #?pugs todo
    is( --$x, "\x[391]ZZ", "'\x[392]AA'-- is '\x[391]ZZ'" );
}
{
    diag( "Tests for '\x[3b1]' .. '\x[3c9]' (Greek lowercase)" );
    $x = "\x[3c9]\x[3c9]";
    #?pugs todo
    is( ++$x, "\x[3b1]\x[3b1]\x[3b1]",
        "'\x[3c9]\x[3c9]'++ is '\x[3b1]\x[3b1]\x[3b1]'" );
    $x = "\x[3b1]\x[3b1]\x[3b1]";
    #?niecza skip "Failure NYI"
    #?pugs skip "Failure NYI"
    ok( --$x ~~ Failure, "'\x[3b1]\x[3b1]\x[3b1]'-- fails" );
    $x = "A\x[3b1]";
    is( ++$x, "A\x[3b2]", "'A\x[3b1]'++ is 'A\x[3b2]'" );
    $x = "A\x[3b2]";
    #?pugs todo
    is( --$x, "A\x[3b1]", "'A\x[3b2]'-- is 'A\x[3b1]'" );
    $x = "A\x[3c9]";
    #?pugs todo
    is( ++$x, "B\x[3b1]", "'A\x[3c9]'++ is 'B\x[3b1]'" );
    $x = "B\x[3b1]";
    #?pugs todo
    is( --$x, "A\x[3c9]", "'B\x[3b1]'-- is 'A\x[3c9]'" );
    $x = "\x[3b1]ZZ";
    is( ++$x, "\x[3b2]AA", "'\x[3b1]ZZ'++ is '\x[3b2]AA'" );
    $x = "\x[3b2]AA";
    #?pugs todo
    is( --$x, "\x[3b1]ZZ", "'\x[3b2]AA'-- is '\x[3b1]ZZ'" );
}
{
    diag( "Tests for '\x[5d0]' .. '\x[5ea]' (Hebrew)" );
    $x = "\x[5ea]\x[5ea]";
    #?niecza todo 'Hebrew'
    #?pugs todo
    is( ++$x, "\x[5d0]\x[5d0]\x[5d0]", "'\x[5ea]\x[5ea]'++ is '\x[5d0]\x[5d0]\x[5d0]'" );
    $x = "\x[5d0]\x[5d0]\x[5d0]";
    #?niecza skip "Failure NYI"
    #?pugs skip "Failure NYI"
    ok( --$x ~~ Failure, "'\x[5d0]\x[5d0]\x[5d0]'-- fails" );
    $x = "A\x[5d0]";
    #?niecza todo 'Hebrew'
    is( ++$x, "A\x[5d1]", "'A\x[5d0]'++ is 'A\x[5d1]'" );
    $x = "A\x[5d1]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[5d0]", "'A\x[5d1]'-- is 'A\x[5d0]'" );
    $x = "A\x[5ea]";
    #?niecza todo 'Hebrew'
    #?pugs todo
    is( ++$x, "B\x[5d0]", "'A\x[5ea]'++ is 'B\x[5d0]'" );
    $x = "B\x[5d0]";
    #?niecza todo 'Hebrew'
    #?pugs todo
    is( --$x, "A\x[5ea]", "'B\x[5d0]'-- is 'A\x[5ea]'" );
    $x = "\x[5d0]ZZ";
    #?niecza todo "Magical string decrement underflowed"
    is( ++$x, "\x[5d1]AA", "'\x[5d0]ZZ'++ is '\x[5d1]AA'" );
    $x = "\x[5d1]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[5d0]ZZ", "'\x[5d1]AA'-- is '\x[5d0]ZZ'" );
}

{
    diag( "Tests for '0' .. '9'" );
    $x = "99";
    is( ++$x, "100", "'99'++ is '100'" );
    $x = "100";
    #?pugs todo
    is( --$x, "099", "'100'-- is '099'" );
    $x = "A0";
    is( ++$x, "A1", "'A0'++ is 'A1'" );
    $x = "A1";
    #?pugs todo
    is( --$x, "A0", "'A1'-- is 'A0'" );
    $x = "A9";
    is( ++$x, "B0", "'A9'++ is 'B0'" );
    $x = "B0";
    #?pugs todo
    is( --$x, "A9", "'B0'-- is 'A9'" );
    $x = "0ZZ";
    is( ++$x, "1AA", "'0ZZ'++ is '1AA'" );
    $x = "1AA";
    #?pugs todo
    is( --$x, "0ZZ", "'1AA'-- is '0ZZ'" );
}
{
    diag( "Tests for '\x[660]' .. '\x[669]' (Arabic-Indic)" );
    $x = "\x[669]\x[669]";
    #?niecza 3 todo "Arabic-Indic NYI"
    #?pugs todo
    is( ++$x, "\x[661]\x[660]\x[660]",
        "'\x[669]\x[669]'++ is '\x[661]\x[660]\x[660]'" );
    $x = "\x[661]\x[660]\x[660]";
    #?pugs todo
    is( --$x, "\x[660]\x[669]\x[669]",
        "'\x[661]\x[660]\x[660]'-- is '\x[660]\x[669]\x[669]'" );
    $x = "A\x[660]";
    is( ++$x, "A\x[661]", "'A\x[660]'++ is 'A\x[661]'" );
    $x = "A\x[661]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[660]", "'A\x[661]'-- is 'A\x[660]'" );
    $x = "A\x[669]";
    #?niecza 3 todo "Arabic-Indic NYI"
    #?pugs todo
    is( ++$x, "B\x[660]", "'A\x[669]'++ is 'B\x[660]'" );
    $x = "B\x[660]";
    #?pugs todo
    is( --$x, "A\x[669]", "'B\x[660]'-- is 'A\x[669]'" );
    $x = "\x[660]ZZ";
    is( ++$x, "\x[661]AA", "'\x[660]ZZ'++ is '\x[661]AA'" );
    $x = "\x[661]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[660]ZZ", "'\x[661]AA'-- is '\x[660]ZZ'" );
}
{
    diag( "Tests for '\x[966]' .. '\x[96f]' (Devangari)" );
    $x = "\x[96f]\x[96f]";
    #?niecza 3 todo "Devangari NYI"
    #?pugs todo
    is( ++$x, "\x[967]\x[966]\x[966]",
        "'\x[96f]\x[96f]'++ is '\x[967]\x[966]\x[966]'" );
    $x = "\x[967]\x[966]\x[966]";
    #?pugs todo
    is( --$x, "\x[966]\x[96f]\x[96f]",
        "'\x[967]\x[966]\x[966]'-- is '\x[966]\x[96f]\x[96f]'" );
    $x = "A\x[966]";
    is( ++$x, "A\x[967]", "'A\x[966]'++ is 'A\x[967]'" );
    $x = "A\x[967]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[966]", "'A\x[967]'-- is 'A\x[966]'" );
    $x = "A\x[96f]";
    #?niecza 3 todo "Devangari NYI"
    #?pugs todo
    is( ++$x, "B\x[966]", "'A\x[96f]'++ is 'B\x[966]'" );
    $x = "B\x[966]";
    #?pugs todo
    is( --$x, "A\x[96f]", "'B\x[966]'-- is 'A\x[96f]'" );
    $x = "\x[966]ZZ";
    is( ++$x, "\x[967]AA", "'\x[966]ZZ'++ is '\x[967]AA'" );
    $x = "\x[967]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[966]ZZ", "'\x[967]AA'-- is '\x[966]ZZ'" );
}
{
    diag( "Tests for '\x[9e6]' .. '\x[9ef]' (Bengali)" );
    $x = "\x[9ef]\x[9ef]";
    #?niecza 3 todo "Bengali NYI"
    #?pugs todo
    is( ++$x, "\x[9e7]\x[9e6]\x[9e6]",
        "'\x[9ef]\x[9ef]'++ is '\x[9e7]\x[9e6]\x[9e6]'" );
    $x = "\x[9e7]\x[9e6]\x[9e6]";
    #?pugs todo
    is( --$x, "\x[9e6]\x[9ef]\x[9ef]",
        "'\x[9e7]\x[9e6]\x[9e6]'-- is '\x[9e6]\x[9ef]\x[9ef]'" );
    $x = "A\x[9e6]";
    is( ++$x, "A\x[9e7]", "'A\x[9e6]'++ is 'A\x[9e7]'" );
    $x = "A\x[9e7]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[9e6]", "'A\x[9e7]'-- is 'A\x[9e6]'" );
    $x = "A\x[9ef]";
    #?niecza 3 todo "Bengali NYI"
    #?pugs todo
    is( ++$x, "B\x[9e6]", "'A\x[9ef]'++ is 'B\x[9e6]'" );
    $x = "B\x[9e6]";
    #?pugs todo
    is( --$x, "A\x[9ef]", "'B\x[9e6]'-- is 'A\x[9ef]'" );
    $x = "\x[9e6]ZZ";
    is( ++$x, "\x[9e7]AA", "'\x[9e6]ZZ'++ is '\x[9e7]AA'" );
    $x = "\x[9e7]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[9e6]ZZ", "'\x[9e7]AA'-- is '\x[9e6]ZZ'" );
}
{
    diag( "Tests for '\x[a66]' .. '\x[a6f]' (Gurmukhi)" );
    $x = "\x[a6f]\x[a6f]";
    #?niecza 3 todo "Gurmukhi NYI"
    #?pugs todo
    is( ++$x, "\x[a67]\x[a66]\x[a66]",
        "'\x[a6f]\x[a6f]'++ is '\x[a67]\x[a66]\x[a66]'" );
    $x = "\x[a67]\x[a66]\x[a66]";
    #?pugs todo
    is( --$x, "\x[a66]\x[a6f]\x[a6f]",
        "'\x[a67]\x[a66]\x[a66]'-- is '\x[a66]\x[a6f]\x[a6f]'" );
    $x = "A\x[a66]";
    is( ++$x, "A\x[a67]", "'A\x[a66]'++ is 'A\x[a67]'" );
    $x = "A\x[a67]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[a66]", "'A\x[a67]'-- is 'A\x[a66]'" );
    $x = "A\x[a6f]";
    #?niecza 3 todo "Gurmukhi NYI"
    #?pugs todo
    is( ++$x, "B\x[a66]", "'A\x[a6f]'++ is 'B\x[a66]'" );
    $x = "B\x[a66]";
    #?pugs todo
    is( --$x, "A\x[a6f]", "'B\x[a66]'-- is 'A\x[a6f]'" );
    $x = "\x[a66]ZZ";
    is( ++$x, "\x[a67]AA", "'\x[a66]ZZ'++ is '\x[a67]AA'" );
    $x = "\x[a67]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[a66]ZZ", "'\x[a67]AA'-- is '\x[a66]ZZ'" );
}
{
    diag( "Tests for '\x[ae6]' .. '\x[aef]' (Gujarati)" );
    $x = "\x[aef]\x[aef]";
    #?pugs todo
    #?niecza 3 todo "Gujarati NYI"
    is( ++$x, "\x[ae7]\x[ae6]\x[ae6]",
        "'\x[aef]\x[aef]'++ is '\x[ae7]\x[ae6]\x[ae6]'" );
    $x = "\x[ae7]\x[ae6]\x[ae6]";
    #?pugs todo
    is( --$x, "\x[ae6]\x[aef]\x[aef]",
        "'\x[ae7]\x[ae6]\x[ae6]'-- is '\x[ae6]\x[aef]\x[aef]'" );
    $x = "A\x[ae6]";
    is( ++$x, "A\x[ae7]", "'A\x[ae6]'++ is 'A\x[ae7]'" );
    $x = "A\x[ae7]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[ae6]", "'A\x[ae7]'-- is 'A\x[ae6]'" );
    $x = "A\x[aef]";
    #?niecza 3 todo "Gujarati NYI"
    #?pugs todo
    is( ++$x, "B\x[ae6]", "'A\x[aef]'++ is 'B\x[ae6]'" );
    $x = "B\x[ae6]";
    #?pugs todo
    is( --$x, "A\x[aef]", "'B\x[ae6]'-- is 'A\x[aef]'" );
    $x = "\x[ae6]ZZ";
    is( ++$x, "\x[ae7]AA", "'\x[ae6]ZZ'++ is '\x[ae7]AA'" );
    $x = "\x[ae7]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[ae6]ZZ", "'\x[ae7]AA'-- is '\x[ae6]ZZ'" );
}
{
    diag( "Tests for '\x[b66]' .. '\x[b6f]' (Oriya)" );
    $x = "\x[b6f]\x[b6f]";
    #?niecza 3 todo "Oriya NYI"
    #?pugs todo
    is( ++$x, "\x[b67]\x[b66]\x[b66]",
        "'\x[b6f]\x[b6f]'++ is '\x[b67]\x[b66]\x[b66]'" );
    $x = "\x[b67]\x[b66]\x[b66]";
    #?pugs todo
    is( --$x, "\x[b66]\x[b6f]\x[b6f]",
        "'\x[b67]\x[b66]\x[b66]'-- is '\x[b66]\x[b6f]\x[b6f]'" );
    $x = "A\x[b66]";
    is( ++$x, "A\x[b67]", "'A\x[b66]'++ is 'A\x[b67]'" );
    $x = "A\x[b67]";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "A\x[b66]", "'A\x[b67]'-- is 'A\x[b66]'" );
    $x = "A\x[b6f]";
    #?niecza 3 todo "Oriya NYI"
    #?pugs todo
    is( ++$x, "B\x[b66]", "'A\x[b6f]'++ is 'B\x[b66]'" );
    $x = "B\x[b66]";
    #?pugs todo
    is( --$x, "A\x[b6f]", "'B\x[b66]'-- is 'A\x[b6f]'" );
    $x = "\x[b66]ZZ";
    is( ++$x, "\x[b67]AA", "'\x[b66]ZZ'++ is '\x[b67]AA'" );
    $x = "\x[b67]AA";
    #?niecza skip "Magical string decrement underflowed"
    #?pugs todo
    is( --$x, "\x[b66]ZZ", "'\x[b67]AA'-- is '\x[b66]ZZ'" );
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/autoincrement.t0000664000175000017500000001556512224265625021445 0ustar  moritzmoritz
use Test;

# Tests for auto-increment and auto-decrement operators
# originally from Perl 5, by way of t/operators/auto.t

plan 78;

#L

my $base = 10000;

my $x = 10000;
is(0 + ++$x - 1, $base, '0 + ++$x - 1');
is(0 + $x-- - 1, $base, '0 + $x-- - 1');
is(1 * $x,       $base, '1 * $x');
is(0 + $x-- - 0, $base, '0 + $x-- - 0');
is(1 + $x,       $base, '1 + $x');
is(1 + $x++,     $base, '1 + $x++');
is(0 + $x,       $base, '0 + $x');
is(0 + --$x + 1, $base, '0 + --$x + 1');
is(0 + ++$x + 0, $base, '0 + ++$x + 0');
is($x,           $base, '$x');

my @x;
@x[0] = 10000;
is(0 + ++@x[0] - 1, $base, '0 + ++@x[0] - 1');
is(0 + @x[0]-- - 1, $base, '0 + @x[0]-- - 1');
is(1 * @x[0],       $base, '1 * @x[0]');
is(0 + @x[0]-- - 0, $base, '0 + @x[0]-- - 0');
is(1 + @x[0],       $base, '1 + @x[0]');
is(1 + @x[0]++,     $base, '1 + @x[0]++');
is(0 + @x[0],       $base, '0 + @x[0]');
is(0 + ++@x[0] - 1, $base, '0 + ++@x[0] - 1');
is(0 + --@x[0] + 0, $base, '0 + --@x[0] + 0');
is(@x[0],           $base, '@x[0]');

my %z;
%z{0} = 10000;
is(0 + ++%z{0} - 1, $base, '0 + ++%z{0} - 1');
is(0 + %z{0}-- - 1, $base, '0 + %z{0}-- - 1');
is(1 * %z{0},       $base, '1 * %z{0}');
is(0 + %z{0}-- - 0, $base, '0 + %z{0}-- - 0');
is(1 + %z{0},       $base, '1 + %z{0}');
is(1 + %z{0}++,     $base, '1 + %z{0}++');
is(0 + %z{0},       $base, '0 + %z{0}');
is(0 + ++%z{0} - 1, $base, '0 + ++%z{0} - 1');
is(0 + --%z{0} + 0, $base, '0 + --%z{0} + 0');
is(%z{0},           $base, '%z{0}');

# Increment of a Str
#L

# XXX: these need to be re-examined and extended per changes to S03.
# Also, see the thread at
# http://www.nntp.perl.org/group/perl.perl6.compiler/2007/06/msg1598.html
# which prompted many of the changes to Str autoincrement/autodecrement.

{
# These are the ranges specified in S03.
# They might be handy for some DDT later.

    my @rangechar = (
        [ 'A', 'Z' ],
        [ 'a', 'z' ],
        [ "\x[391]", "\x[3a9]" ],
        [ "\x[3b1]", "\x[3c9]" ],
        [ "\x[5d0]", "\x[5ea]" ],

        [ '0', '9' ],
        [ "\x[660]", "\x[669]" ],
        [ "\x[966]", "\x[96f]" ],
        [ "\x[9e6]", "\x[9ef]" ],
        [ "\x[a66]", "\x[a6f]" ],
        [ "\x[ae6]", "\x[aef]" ],
        [ "\x[b66]", "\x[b6f]" ],
    );
}

{
    my $x;

    $x = "123.456";
    #?pugs todo
    is( ++$x, "124.456", "'123.456'++ is '124.456' (NOT 123.457)" );
    $x = "124.456";
    is( --$x, "123.456", "'124.456'-- is '123.456'" );
}

{
    my $x;

    $x = "/tmp/pix000.jpg";
    #?pugs todo
    is( ++$x, "/tmp/pix001.jpg", "'/tmp/pix000.jpg'++ is '/tmp/pix001.jpg'" );
    $x = "/tmp/pix001.jpg";
    #?pugs todo
    is( --$x, "/tmp/pix000.jpg", "'/tmp/pix001.jpg'-- is '/tmp/pix000.jpg'" );
}

{
    my $x;

    # EBCDIC check (i and j not contiguous)
    $x = "zi";
    is( ++$x, "zj", "'zi'++ is 'zj'" );
    $x = "zj";
    #?pugs todo
    is( --$x, "zi", "'zj'-- is 'zi'" );
    $x = "zr";

    # EBCDIC check (r and s not contiguous)
    is( ++$x, "zs", "'zr'++ is 'zs'" );
    $x = "zs";
    #?pugs todo
    is( --$x, "zr", "'zs'-- is 'zr'" );
}

#?niecza skip "Failure NYI"
#?pugs skip "Failure NYI"
{
    my $foo;

    $foo = 'A00';
    ok(--$foo ~~ Failure, "Decrement of 'A00' should fail");

# TODO: Check that the Failure is "Decrement out of range" and not
#       some other unrelated error (for the fail tests above).
}

{
    my $foo;

    $foo = "\x[3a1]";
    #?pugs todo 'weird ranges'
    is( ++$foo, "\x[3a3]", 'there is no \\x[3a2]' );
}

{
    my $foo = "K\x[3c9]";
    #?pugs todo 'weird ranges'
    is( ++$foo, "L\x[3b1]", "increment 'K\x[3c9]'" );
}

{
    my $x;
    is ++$x, 1, 'Can autoincrement a Mu variable (prefix)';

    my $y;
    $y++;
    is $y, 1, 'Can autoincrement a Mu variable (postfix)';
}

#?pugs skip "todo"
#?DOES 2
{
    class Incrementor {
        has $.value;

        method succ() {
            Incrementor.new( value => $.value + 42);
        }
    }

    my $o = Incrementor.new( value => 0 );
    $o++;
    is $o.value, 42, 'Overriding succ catches postfix increment';
    ++$o;
    is $o.value, 84, 'Overriding succ catches prefix increment';
}

#?pugs skip "todo"
#?DOES 2
{
    class Decrementor {
        has $.value;

        method pred() {
            Decrementor.new( value => $.value - 42);
        }
    }

    my $o = Decrementor.new( value => 100 );
    $o--;
    is $o.value, 58, 'Overriding pred catches postfix decrement';
    --$o;
    is $o.value, 16, 'Overriding pred catches prefix decrement';
}

#?pugs skip "todo"
#?DOES 6
{
    # L
   
    my $x = "b";
    is $x.succ, 'c', '.succ for Str';
    is $x.pred, 'a', '.pred for Str';

    my $y = 1;
    is $y.succ, 2, '.succ for Int';
    is $y.pred, 0, '.pred for Int';

    my $z = Num.new();
    is $z.succ, 1 , '.succ for Num';
    is $z.pred, -1, '.pred for Num'
}

# RT #63644
eval_dies_ok 'my $a; $a++ ++;', 'parse error for "$a++ ++"';

# RT #113816 - autoincrement of bools
{
    my Bool $x; 
    my $y;

    #postincrement tests
    $x = Bool;
    $y = $x++;
    #?pugs todo
    is $y, False, "Bool postincrement returns Bool";
    is $x, True, "Bool postincrement sets True";

    $x = False;
    $y = $x++;
    #?pugs todo
    is $y, False, "False postincrement returns False";
    is $x, True, "False postincrement sets True";

    $x = True;
    $y = $x++;
    is $y, True, "True postincrement returns True";
    #?pugs todo
    is $x, True, "True postincrement sets True";

    #postdecrement tests
    $x = Bool;
    $y = $x--;
    #?pugs todo
    is $y, False, "Bool postdecrement returns Bool";
    #?pugs todo
    is $x, False, "Bool postdecrement sets False";

    $x = False;
    $y = $x--;
    is $y, False, "False postdecrement returns False";
    #?pugs todo
    is $x, False, "False postdecrement sets False";

    $x = True;
    $y = $x--;
    is $y, True, "True postdecrement returns True";
    #?pugs todo
    is $x, False, "True postdecrement sets False";

    #preincrement tests
    $x = Bool;
    $y = ++$x;
    is $y, True, "Bool preincrement returns True";
    is $x, True, "Bool postincrement sets True";

    $x = False;
    $y = ++$x;
    is $y, True, "False preincrement returns True";
    is $x, True, "False postincrement sets True";

    $x = True;
    $y = ++$x;
    #?pugs todo
    is $y, True, "True preincrement returns True";
    #?pugs todo
    is $x, True, "True postincrement sets True";
    
    #predecrement tests
    $x = Bool;
    $y = --$x;
    #?pugs todo
    is $y, False, "Bool predecrement returns False";
    #?pugs todo
    is $x, False, "Bool postdecrement sets False";

    $x = False;
    $y = --$x;
    #?pugs todo
    is $y, False, "False predecrement returns False";
    #?pugs todo
    is $x, False, "False postdecrement sets False";

    $x = True;
    $y = --$x;
    #?pugs todo
    is $y, False, "True predecrement returns False";
    #?pugs todo
    is $x, False, "True postdecrement sets False";
};


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/autovivification.t0000664000175000017500000000461112224265625022141 0ustar  moritzmoritzuse Test;
plan 23;

# L

{
    my $x;
    $x++;
    ok $x == 1, 'my $x; $x++ works'
}

{
    my Int $x;
    $x++;
    ok $x == 1, 'my Int $x; $x++ works'
}

{
    my $x;
    $x += 1;
    ok $x == 1, 'my $x; $x += 1 works'
}

{
    my Int $x;
    $x += 1;
    ok $x == 1, 'my Int $x; $x += 1 works'
}

{
    my $x;
    $x -= 1;
    ok $x == -1, 'my $x; $x -= 1 works'
}

{
    my Int $x;
    $x -= 1;
    ok $x == -1, 'my Int $x; $x -= 1 works'
}

{
    my $s;
    $s ~= 'ab';
    is $s, 'ab', 'my $s; $s ~= "ab" works'
}

#?pugs todo
{
    my Str $s;
    $s ~= 'ab';
    is $s, 'ab', 'my Str $s; $s ~= "ab" works'
}

#?niecza todo
#?pugs todo
{
    my $x;
    $x *= 2;
    ok $x == 2, 'my $x; $x *= 2 works'
}

#?niecza todo
#?pugs todo
{
    my $x;
    $x **= 2;
    ok $x == 1, 'my $x; $x **= 2 works'
}

#?niecza todo
#?pugs todo
{
    my Int $x;
    $x *= 2;
    ok $x == 2, 'my Int $x; $x *= 2 works'
}

#?niecza todo
#?pugs todo
{
    my Int $x;
    $x **= 2;
    ok $x == 1, 'my Int $x; $x **= 2 works'
}

{
    my $x;
    $x = $x + 1i;
    is_approx($x, 0 + 1i, 'my $x; $x = $x + 1i; works');
}

{
    my $x;
    $x += 1i;
    is_approx($x, 0 + 1i, 'my $x; $x += 1i; works');
}

{
    my $i **= $i;
    is $i, 1, 'my $i **= $i';
}

#?niecza todo
#?pugs todo
{
    my $x;
    $x *= 1i;
    is_approx($x, 1i, 'my $x; $x *= 1i works');
}

# L
#?niecza todo
#?pugs todo
{
    # yes, this is serious. It's in the specs ;-)
    my Int $x;
    $x *= 5;
    is $x, 5, '*= autovivifies with correct neutral element (with Num proto)';
}

#?niecza todo
#?pugs todo
{
    my $x;
    $x *= 5;
    is $x, 5, '*= autovivifies with correct neutral element (without type constraint)';
}

#?niecza todo
#?pugs todo
{
    my Int %h;
    is  (%h *= 23), 23, '*= autovivifies with correct neutral element (with Int proto on hash items)';
}

#?niecza todo
#?pugs todo
{
    my %h;
    is  (%h *= 23), 23, '*= autovivifies with correct neutral element (without proto on hash items)';
}

{
    my @empty;
    is +@empty, 0, 'Sanity: empty array, @empty, has 0 elements'; 

    my $before =  @empty.perl;
    @empty[5] ~~ /nothing/;
    my $after = @empty.perl;

    #?pugs 2 todo 'bugs'
    is +@empty,0,'empty array, @empty, has 0 elements';

    is $after,$before,"Array elements are not auto-vivified by smartmatch";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/bag.t0000664000175000017500000002235612224265625017315 0ustar  moritzmoritzuse v6;
use Test;

plan 108;

sub showkv($x) {
    $x.keys.sort.map({ $^k ~ ':' ~ $x{$k} }).join(' ')
}

# "We're more of the love, blood, and rhetoric school. Well, we can do you blood
# and love without the rhetoric, and we can do you blood and rhetoric without
# the love, and we can do you all three concurrent or consecutive. But we can't
# give you love and rhetoric without the blood. Blood is compulsory. They're all
# blood, you see." -- Tom Stoppard

my $s = set ;
my $ks = SetHash.new();
my $b = bag ;
my $kb = BagHash.new();

# Bag Union

is showkv($b ∪ $b), showkv($b), "Bag union with itself yields self";
isa_ok ($b ∪ $b), Bag, "... and it's actually a Bag";
is showkv($kb ∪ $kb), showkv($kb), "BagHash union with itself yields (as Bag)";
isa_ok ($kb ∪ $kb), Bag, "... and it's actually a Bag";

is showkv($s ∪ $b), "blood:2 love:2 rhetoric:1", "Set union with Bag works";
isa_ok ($s ∪ $b), Bag, "... and it's actually a Bag";
is showkv($s ∪ $kb), "blood:1 love:2", "Set union with BagHash works";
isa_ok ($s ∪ $kb), Bag, "... and it's actually a Bag";

is showkv($s (|) $b), "blood:2 love:2 rhetoric:1", "Set union with Bag works (texas)";
isa_ok ($s (|) $b), Bag, "... and it's actually a Bag";
is showkv($s (|) $kb), "blood:1 love:2", "Set union with BagHash works (texas)";
isa_ok ($s (|) $kb), Bag, "... and it's actually a Bag";

# Bag Intersection

is showkv($b ∩ $b), showkv($b), "Bag intersection with itself yields self (as Bag)";
isa_ok ($b ∩ $b), Bag, "... and it's actually a Bag";
is showkv($kb ∩ $kb), showkv($kb), "BagHash intersection with itself yields self (as Bag)";
isa_ok ($kb ∩ $kb), Bag, "... and it's actually a Bag";

is showkv($s ∩ $b), "blood:1 love:1", "Set intersection with Bag works";
isa_ok ($s ∩ $b), Bag, "... and it's actually a Bag";
is showkv($s ∩ $kb), "blood:1 love:1", "Set intersection with BagHash works";
isa_ok ($s ∩ $kb), Bag, "... and it's actually a Bag";
#?niecza todo 'Right now this works as $kb ∩ glag ∩ green ∩ blood.  Test may be wrong'
is showkv($kb ∩ ), "blood:1", "BagHash intersection with array of strings works";
isa_ok ($kb ∩ ), Bag, "... and it's actually a Bag";

is showkv($s (&) $b), "blood:1 love:1", "Set intersection with Bag works (texas)";
isa_ok ($s (&) $b), Bag, "... and it's actually a Bag";
is showkv($s (&) $kb), "blood:1 love:1", "Set intersection with BagHash works (texas)";
isa_ok ($s (&) $kb), Bag, "... and it's actually a Bag";
#?niecza todo 'Right now this works as $kb ∩ glag ∩ green ∩ blood.  Test may be wrong?'
is showkv($kb (&) ), "blood:1", "BagHash intersection with array of strings works (texas)";
isa_ok ($kb (&) ), Bag, "... and it's actually a Bag";

# Bag multiplication

is showkv($s ⊍ $s), "blood:1 love:1", "Bag multiplication with itself yields self squared";
isa_ok ($s ⊍ $s), Bag, "... and it's actually a Bag";
is showkv($ks ⊍ $ks), "blood:1 rhetoric:1", "Bag multiplication with itself yields self squared";
isa_ok ($ks ⊍ $ks), Bag, "... and it's actually a Bag";
is showkv($b ⊍ $b), "blood:4 love:4 rhetoric:1", "Bag multiplication with itself yields self squared";
isa_ok ($b ⊍ $b), Bag, "... and it's actually a Bag";
is showkv($kb ⊍ $kb), "blood:1 love:4", "Bag multiplication with itself yields self squared";
isa_ok ($kb ⊍ $kb), Bag, "... and it's actually a Bag";

is showkv($s ⊍ $ks), "blood:1", "Bag multiplication (Set / SetHash) works";
isa_ok ($s ⊍ $ks), Bag, "... and it's actually a Bag";
is showkv($s ⊍ $b), "blood:2 love:2", "Bag multiplication (Set / Bag) works";
isa_ok ($s ⊍ $b), Bag, "... and it's actually a Bag";
is showkv($ks ⊍ $b), "blood:2 rhetoric:1", "Bag multiplication (SetHash / Bag) works";
isa_ok ($ks ⊍ $b), Bag, "... and it's actually a Bag";
is showkv($kb ⊍ $b), "blood:2 love:4", "Bag multiplication (BagHash / Bag) works";
isa_ok ($kb ⊍ $b), Bag, "... and it's actually a Bag";

is showkv($s (.) $ks), "blood:1", "Bag multiplication (Set / SetHash) works (texas)";
isa_ok ($s (.) $ks), Bag, "... and it's actually a Bag (texas)";
is showkv($s (.) $b), "blood:2 love:2", "Bag multiplication (Set / Bag) works (texas)";
isa_ok ($s (.) $b), Bag, "... and it's actually a Bag (texas)";
is showkv($ks (.) $b), "blood:2 rhetoric:1", "Bag multiplication (SetHash / Bag) works (texas)";
isa_ok ($ks (.) $b), Bag, "... and it's actually a Bag (texas)";
is showkv($kb (.) $b), "blood:2 love:4", "Bag multiplication (BagHash / Bag) works (texas)";
isa_ok ($kb (.) $b), Bag, "... and it's actually a Bag";

# Bag addition

is showkv($s ⊎ $s), "blood:2 love:2", "Bag addition with itself yields twice self";
isa_ok ($s ⊎ $s), Bag, "... and it's actually a Bag";
is showkv($ks ⊎ $ks), "blood:2 rhetoric:2", "Bag addition with itself yields twice self";
isa_ok ($ks ⊎ $ks), Bag, "... and it's actually a Bag";
is showkv($b ⊎ $b), "blood:4 love:4 rhetoric:2", "Bag addition with itself yields twice self";
isa_ok ($b ⊎ $b), Bag, "... and it's actually a Bag";
is showkv($kb ⊎ $kb), "blood:2 love:4", "Bag addition with itself yields twice self";
isa_ok ($kb ⊎ $kb), Bag, "... and it's actually a Bag";

is showkv($s ⊎ $ks), "blood:2 love:1 rhetoric:1", "Bag addition (Set / SetHash) works";
isa_ok ($s ⊎ $ks), Bag, "... and it's actually a Bag";
is showkv($s ⊎ $b), "blood:3 love:3 rhetoric:1", "Bag addition (Set / Bag) works";
isa_ok ($s ⊎ $b), Bag, "... and it's actually a Bag";
is showkv($ks ⊎ $b), "blood:3 love:2 rhetoric:2", "Bag addition (SetHash / Bag) works";
isa_ok ($ks ⊎ $b), Bag, "... and it's actually a Bag";
is showkv($kb ⊎ $b), "blood:3 love:4 rhetoric:1", "Bag addition (BagHash / Bag) works";
isa_ok ($kb ⊎ $b), Bag, "... and it's actually a Bag";

is showkv($s (+) $ks), "blood:2 love:1 rhetoric:1", "Bag addition (Set / SetHash) works (texas)";
isa_ok ($s (+) $ks), Bag, "... and it's actually a Bag (texas)";
is showkv($s (+) $b), "blood:3 love:3 rhetoric:1", "Bag addition (Set / Bag) works (texas)";
isa_ok ($s (+) $b), Bag, "... and it's actually a Bag (texas)";
is showkv($ks (+) $b), "blood:3 love:2 rhetoric:2", "Bag addition (SetHash / Bag) works (texas)";
isa_ok ($ks (+) $b), Bag, "... and it's actually a Bag (texas)";
is showkv($kb (+) $b), "blood:3 love:4 rhetoric:1", "Bag addition (BagHash / Bag) works (texas)";
isa_ok ($kb (+) $b), Bag, "... and it's actually a Bag";

# msubset
{
    ok $kb ≼ $b, "Our keybag is a msubset of our bag";
    nok $b ≼ $kb, "Our bag is not a msubset of our keybag";
    ok $b ≼ $b, "Our bag is a msubset of itself";
    ok $kb ≼ $kb, "Our keybag is a msubset of itself";
    #?niecza 4 skip '(<+) NYI - https://github.com/sorear/niecza/issues/178'
    ok $kb (<+) $b, "Our keybag is a msubset of our bag (texas)";
    nok $b (<+) $kb, "Our bag is not a msubset of our keybag (texas)";
    ok $b (<+) $b, "Our bag is a msubset of itself (texas)";
    ok $kb (<+) $kb, "Our keybag is a msubset of itself (texas)";
}

# msuperset
{
    nok $kb ≽ $b, "Our keybag is not a msuperset of our bag";
    ok $b ≽ $kb, "Our keybag is not a msuperset of our bag";
    ok $b ≽ $b, "Our bag is a msuperset of itself";
    ok $kb ≽ $kb, "Our keybag is a msuperset of itself";
    #?niecza 4 skip '(>+) NYI - https://github.com/sorear/niecza/issues/178'
    nok $kb (>+) $b, "Our keybag is not a msuperset of our bag";
    ok $b (>+) $kb, "Our bag is a msuperset of our keybag";
    ok $b (>+) $b, "Our bag is a msuperset of itself";
    ok $kb (>+) $kb, "Our keybag is a msuperset of itself";
}

#?rakudo skip 'Reduction and bag operators'
{
    # my $s = set ;
    # my $ks = SetHash.new();
    # my $b = bag ;
    # my $kb = BagHash.new();
    my @d;
    
    is showkv([⊎] @d), showkv(∅), "Bag sum reduce works on nothing";
    is showkv([⊎] $s), showkv($s.Bag), "Bag sum reduce works on one set";
    is showkv([⊎] $s, $b), showkv({ blood => 3, rhetoric => 1, love => 3 }), "Bag sum reduce works on two sets";
    is showkv([⊎] $s, $b, $kb), showkv({ blood => 4, rhetoric => 1, love => 5 }), "Bag sum reduce works on three sets";

    is showkv([(+)] @d), showkv(∅), "Bag sum reduce works on nothing";
    is showkv([(+)] $s), showkv($s.Bag), "Bag sum reduce works on one set";
    is showkv([(+)] $s, $b), showkv({ blood => 3, rhetoric => 1, love => 3 }), "Bag sum reduce works on two sets";
    is showkv([(+)] $s, $b, $kb), showkv({ blood => 4, rhetoric => 1, love => 5 }), "Bag sum reduce works on three sets";

    is showkv([⊍] @d), showkv(∅), "Bag multiply reduce works on nothing";
    is showkv([⊍] $s), showkv($s.Bag), "Bag multiply reduce works on one set";
    is showkv([⊍] $s, $b), showkv({ blood => 2, love => 2 }), "Bag multiply reduce works on two sets";
    is showkv([⊍] $s, $b, $kb), showkv({ blood => 2, love => 4 }), "Bag multiply reduce works on three sets";

    is showkv([(.)] @d), showkv(∅), "Bag multiply reduce works on nothing";
    is showkv([(.)] $s), showkv($s.Bag), "Bag multiply reduce works on one set";
    is showkv([(.)] $s, $b), showkv({ blood => 2, love => 2 }), "Bag multiply reduce works on two sets";
    is showkv([(.)] $s, $b, $kb), showkv({ blood => 2, love => 4 }), "Bag multiply reduce works on three sets";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/basic-types.t0000664000175000017500000000357312224265625021007 0ustar  moritzmoritzuse v6;

use Test;

plan 19;

# WHAT() on basic types

my $a;
is($a.WHAT.gist, Any.gist, 'empty scalar is Any');

my @a;
ok(@a ~~ Array, 'it is an Array type');
ok @a ~~ Positional, 'An Array does Positional';

my %a;
ok(%a ~~ Hash, 'it is an Hash type');
ok %a ~~ Associative, 'A Hash does Associative';

# WHAT() on reference types

my $b1 = [];
ok($b1 ~~ Array, 'it is a Array type');

# this seems to be the only way to make a hash - ref at the moment
my %b2 = ("one", 1); my $b2 = %b2;
ok($b2 ~~ Hash, 'it is a Hash type'); 

# WHAT() on subroutines

my $s1 = sub {};
isa_ok($s1, Sub, 'it is a Sub type');

# See L
# Quoting A06:
#                                   Code
#                        ____________|________________
#                       |                             |
#                    Routine                        Block
#       ________________|_______________ 
#      |     |       |       |    |     |
#     Sub Method Submethod Multi Rule Macro

# L
my $s2 = {};
ok($s2 ~~ Hash, 'it is a Hash type (bare block)');

# L
my $s2a = { $^aaa };
isa_ok($s2a, Block, 'it is a Parametric type (bare block with placeholder parameters)');

{
    my $s3 = -> {};
    isa_ok($s3, Block, 'it is a Block type (pointy block)');
}

# WHAT() on different types of scalars

my $int = 0;
isa_ok($int, Int, 'it is an Int type');

my $num = '';
ok(+$num ~~ Real, 'it is an Real type');

my $float = 0.5e0;
isa_ok($float, Num, 'it is an Num type');
isa_ok(1 / 4, Rat, 'infix: of integers produces a Rat');

my $string = "Hello World";
isa_ok($string, Str, 'it is a Str type');

my $bool = (0 == 0);
isa_ok($bool, Bool, 'it is a Bool type');

my $pair = ("foo" => "bar");
isa_ok($pair, Pair, 'it is a Pair type');

{
    my $rule = rx/^hello\sworld$/;
    isa_ok($rule, Regex, 'it is a Regex type');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/bit.t0000664000175000017500000001137112224265625017335 0ustar  moritzmoritzuse v6;

use Test;

# Mostly copied from Perl 5.8.4 s t/op/bop.t

plan 33;

# test the bit operators '&', '|', '^', '+<', and '+>'

# numerics

# L
{

  # numeric
  is( 0xdead +& 0xbeef,   0x9ead,    'numeric bitwise +& of hexadecimal' );
  is( 0xdead +| 0xbeef,   0xfeef,    'numeric bitwise +| of hexadecimal' );
  is( 0xdead +^ 0xbeef,   0x6042,    'numeric bitwise +^ of hexadecimal' );
  is( +^0xdead +& 0xbeef, 0x2042,    'numeric bitwise +^ and +& together' );

  # very large numbers
  is 0xdeaddead0000deaddead0000dead +& 0xbeef0000beef0000beef0000beef,
     0x9ead0000000000009ead00009ead,
     'numeric bitwise +& of bigint';
  is 0xdeaddead0000deaddead0000dead +| 0xbeef0000beef0000beef0000beef,
     0xfeefdeadbeefdeadfeef0000feef,
     'numeric bitwise +| of bigint';
  is 0xdeaddead0000deaddead0000dead +^ 0xbeef0000beef0000beef0000beef,
     0x6042deadbeefdead604200006042,
     'numeric bitwise +^ of bigint';
  is +^ 0xdeaddead0000deaddead0000dead, -0xdeaddead0000deaddead0000deae,
     'numeric bitwise negation';

  # string                           
  #?niecza 6 skip 'string bitops'
  is( 'a' ~& 'A',         'A',       'string bitwise ~& of "a" and "A"' );
  is( 'a' ~| 'b',         'c',       'string bitwise ~| of "a" and "b"' );
  is( 'a' ~^ 'B',         '#',       'string bitwise ~^ of "a" and "B"' );
  is( 'AAAAA' ~& 'zzzzz', '@@@@@',   'short string bitwise ~&' );
  is( 'AAAAA' ~| 'zzzzz', '{{{{{',   'short string bitwise ~|' );
  is( 'AAAAA' ~^ 'zzzzz', ';;;;;',   'short string bitwise ~^' );
  
  # long strings
  my $foo = "A" x 150;
  my $bar = "z" x 75;
  my $zap = "A" x 75;
  
  #?niecza 3 skip 'string bitops'
  is( $foo ~& $bar, '@' x 75,        'long string bitwise ~&, truncates' );
  is( $foo ~| $bar, '{' x 75 ~ $zap, 'long string bitwise ~|, no truncation' );
  is( $foo ~^ $bar, ';' x 75 ~ $zap, 'long string bitwise ~^, no truncation' );

  # "interesting" tests from a long time back...
  #?niecza 2 skip 'string bitops'
  is( "ok \xFF\xFF\n" ~& "ok 19\n", "ok 19\n", 'stringwise ~&, arbitrary string' );
  is( "ok 20\n" ~| "ok \0\0\n", "ok 20\n",     'stringwise ~|, arbitrary string' );

  # bit shifting
  is( 32 +< 1,            64,     'shift one bit left' );
  is( 32 +> 1,            16,     'shift one bit right' );
  is( 257 +< 7,           32896,  'shift seven bits left' );
  is( 33023 +> 7,         257,    'shift seven bits right' );

  is 0xdeaddead0000deaddead0000dead +< 4, 0xdeaddead0000deaddead0000dead0, 'shift bigint 4 bits left';
  is 0xdeaddead0000deaddead0000dead +> 4, 0xdeaddead0000deaddead0000dea, 'shift bigint 4 bits right';
}

{
  # Tests to see if you really can do casts negative floats to unsigned properly
  my $neg1 = -1.0.Num;
  my $neg7 = -7.0.Num;

  is(+^ $neg1, 0, 'cast numeric float to unsigned' );
  is(+^ $neg7, 6, 'cast -7 to 6 with +^' );
  ok(+^ $neg7 == 6, 'cast -7 with equality testing' );

}

# RT #77232 - precedence of +< and +>
{
  is( 48 + 0 +< 8, 48 + (0 +< 8), 'RT 77232 precedence of +<' );
  is( 48 + 0 +< 8, 48 + (0 +< 8), 'RT 77232 precedence of +>' );
  is( 2 ** 3 +< 3, (2 ** 3) +< 3, 'RT 77232 precedence of +<' );
  is( 2 ** 5 +> 2, (2 ** 5) +> 2, 'RT 77232 precedence of +>' );
}

# RT #109740
{
    my ($x, $y) = (2**30, 1);
    is +^$x +& $y, 1, 'large-ish bit ops';
}


# signed vs. unsigned
#ok((+^0 +> 0 && do { use integer; ~0 } == -1));

#my $bits = 0;
#for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
#my $cusp = 1 << ($bits - 1);


#ok(($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0);
#ok(($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0);
#ok(($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0);
#ok((1 << ($bits - 1)) == $cusp &&
#    do { use integer; 1 << ($bits - 1) } == -$cusp);
#ok(($cusp >> 1) == ($cusp / 2) &&
#    do { use integer; abs($cusp >> 1) } == ($cusp / 2));

#--
#$Aaz = chr(ord("A") & ord("z"));
#$Aoz = chr(ord("A") | ord("z"));
#$Axz = chr(ord("A") ^ ord("z"));
# instead of $Aaz x 5, literal "@@@@@" is used and thus ascii assumed below
# (for now...)


# currently, pugs recognize octals as "\0o00", not "\o000".
#if ("o\o000 \0" ~ "1\o000" ~^ "\o000k\02\o000\n" eq "ok 21\n") { say "ok 15" } else { say "not ok 15" }

# Pugs does not have \x{}

#
#if ("ok \x{FF}\x{FF}\n" ~& "ok 22\n" eq "ok 22\n") { say "ok 16" } else { say "not ok 16" }
#if ("ok 23\n" ~| "ok \x{0}\x{0}\n" eq "ok 23\n") { say "ok 17" } else { say "not ok 17" }
#if ("o\x{0} \x{0}4\x{0}" ~^ "\x{0}k\x{0}2\x{0}\n" eq "ok 24\n") { say "ok 18" } else { say "not ok 18" }

# Not in Pugs: vstrings, ebcdic, unicode, sprintf

# More variations on 19 and 22
#if ("ok \xFF\x{FF}\n" ~& "ok 41\n" eq "ok 41\n") { say "ok 19" } else { say "not ok 19" }
#if ("ok \x{FF}\xFF\n" ~& "ok 42\n" eq "ok 42\n") { say "ok 20" } else { say "not ok 20" }

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/boolean-bitwise.t0000664000175000017500000001031112224265625021633 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

Tests for Synopsis 3
=end kwid

plan 45;

{ # L
  # work with pure Bool's
  ok( ?(False?|False == False), '?| works with Bools');
  ok( ?(False?|True  == True),  '?| works with Bools');
  ok( ?(True ?|False == True),  '?| works with Bools');
  ok( ?(True ?|True  == True),  '?| works with Bools');

  ok( ?(''   ?| 0    == False), '?| works');
  ok( ?(1    ?| 0    == True),  '?| works');
  ok( ?(0    ?| 72   == True),  '?| works');
  ok( ?(42   ?| 42   == True),  '?| works');
  ok( ?(42   ?| 41   == True),  '?| works');

  #?niecza skip 'No value for parameter $b in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?|"'
  ok( ?(infix:(True) == True), '?| works with one argument');
  #?niecza skip 'No value for parameter $a in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?|"'
  ok( ?(infix:() == False), '?| works with no arguments');

  isa_ok (42 ?| 41), Bool, '?| yields a Bool';
  #?niecza skip 'No value for parameter $b in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?|"'
  isa_ok infix:(True), Bool, '?| with one argument yields a Bool';
  #?niecza skip 'No value for parameter $a in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?|"'
  isa_ok infix:(), Bool, '?| with no arguments yields a Bool';

}

{ # L
  # work with pure Bool's
  ok( ?(False?&False == False), '?& works with Bools');
  ok( ?(False?&True  == False), '?& works with Bools');
  ok( ?(True ?&False == False), '?& works with Bools');
  ok( ?(True ?&True  == True),  '?& works with Bools');

  ok( ?('' ?& 'yes'  == False), '?& works');
  ok( ?(1  ?& False  == False), '?& works');
  ok( ?(42 ?& 42     == True),  '?& works');
  ok( ?(3  ?& 12     == True),  '?& works');
  ok( ?(3  ?& 13     == True),  '?& works');
  ok( ?(13 ?& 3      == True),  '?& works');

  #?niecza skip 'No value for parameter $b in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?&"'
  ok( ?(infix:(False) == False), '?& works with one argument');
  #?niecza skip 'No value for parameter $a in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?&"'
  ok( ?(infix:() == True), '?& works with no arguments');

  isa_ok (42 ?& 41), Bool, '?& yields a Bool';
  #?niecza skip 'No value for parameter $b in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?&"'
  isa_ok infix:(True), Bool, '?& with one argument yields a Bool';
  #?niecza skip 'No value for parameter $a in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?&"'
  isa_ok infix:(), Bool, '?& with no arguments yields a Bool';
}

{ ## L
  # work with pure Bool's
  ok( ?(False?^False == False), '?^ works with Bools');
  ok( ?(False?^True  == True),  '?^ works with Bools');
  ok( ?(True ?^False == True),  '?^ works with Bools');
  ok( ?(True ?^True  == False), '?^ works with Bools');

  ok( ?(''   ?^''    == False), '?^ works');
  ok( ?(Any  ?^ 1    == True),  '?^ works');
  ok( ?(-1   ?^ Any  == True),  '?^ works');
  ok( ?(42   ?^ 42   == False), '?^ works');
  #?niecza todo
  ok( ?(42   ?^ 41   == False),  '?^ works');
 
  #?niecza skip 'No value for parameter $b in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?^"'
  ok( ?(infix:(True) == True), '?^ works with one argument');
  #?niecza skip 'No value for parameter $a in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?^"'
  ok( ?(infix:() == False), '?^ works with no arguments');

  isa_ok (42 ?^ 41), Bool, '?^ yields a Bool';
  #?niecza skip 'No value for parameter $b in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?^"'
  isa_ok infix:(True), Bool, '?^ with one argument yields a Bool';
  #?niecza skip 'No value for parameter $a in CORE infix:'
  #?pugs skip 'No compatible multi variant found: "&infix:?^"'
  isa_ok infix:(), Bool, '?^ with no arguments yields a Bool';
}

ok (?^5) === False, 'prefix ?^ (+)';
ok (?^0) === True,  'prefix ?^ (-)';
rakudo-2013.12/t/spec/S03-operators/brainos.t0000664000175000017500000000165712224265625020222 0ustar  moritzmoritzuse v6;

use Test;

plan 9;

=begin pod

Perl 6 has an explicitly declared C<=~> which should die at compile time
and is intended to catch user "brainos"; it recommends C<~~> to the user
instead. Similar for C.

=end pod

#L

my $str = 'foo';
try { eval '$str =~ m/bar/;' };
ok  $!  ~~ Exception, 'caught "=~" braino';
ok "$!" ~~ /'~~'/, 'error for "=~" usage mentions "~~"';

try { eval '$str !~ m/bar/;' };
ok  $!  ~~ Exception, 'caught "!~" braino';
ok "$!" ~~ /'!~~'/, 'error for "!~" usage mentions "!~~"';

# RT #76878
{
    my $x = 2;
    is eval('"$x =~ b"'), '2 =~ b', '=~ allowed in double quotes';
    is eval('"$x !~ b"'), '2 !~ b', '!~ allowed in double quotes';
    is eval('"$x << b"'), '2 << b', '<< allowed in double quotes';
    is eval('"$x >> b"'), '2 >> b', '>> allowed in double quotes';
    is eval('"$x . b"'),  '2 . b',  '.  allowed in double quotes';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/buf.t0000664000175000017500000000473512237474612017343 0ustar  moritzmoritzuse v6;
use Test;

plan 34;

ok (~^"foo".encode eqv utf8.new(0x99, 0x90, 0x90)), 'prefix:<~^>';

ok ("foo".encode ~& "bar".encode eqv "bab".encode), 'infix:<~&>';
ok ("ber".encode ~| "baz".encode eqv "bez".encode), 'infix:<~|>';
ok ("foo".encode ~^ "bar".encode eqv utf8.new(4, 14, 29)), 'infix:<~^>';

ok ("aaaaa".encode ~& "aa".encode eqv "aa\0\0\0".encode),
    '~& extends rightwards';
ok ("aaaaa".encode ~| "aa".encode eqv "aaaaa".encode),
    '~| extends rightwards';
ok ("aaaaa".encode ~^ "aa".encode eqv "\0\0aaa".encode),
    '~^ extends rightwards';

my $a = Buf.new(1, 2, 3);
my $b = Buf.new(1, 2, 3, 4);

 ok $a eq $a,    'eq +';
nok $a eq $b,    'eq -';
 ok $a ne $b,    'ne +';
nok $a ne $a,    'ne -';
 ok $a lt $b,    'lt +';
nok $a lt $a,    'lt -';
nok $b lt $a,    'lt -';
 ok $b gt $a,    'gt +';
nok $b gt $b,    'gt -';
nok $a gt $b,    'gt -';
is  $a cmp $a, Order::Same, 'cmp (same)';
is  $a cmp $b, Order::Less, 'cmp (smaller)';
is  $b cmp $a, Order::More, 'cmp (larger)';

ok $a ~ $b eq Buf.new(1, 2, 3, 1, 2, 3, 4), '~ and eq work on bufs';

is_deeply Buf.new(1, 2, 3) ~ Buf.new(4, 5), Buf.new(1, 2, 3, 4, 5), '~ concatenates';
nok Buf.new(), 'empty Buf is false';
ok  Buf.new(1), 'non-empty Buf is true';

ok Buf.new(1, 2, 3, 4).subbuf(2) eqv Buf.new(3, 4), '.subbuf(start)';
ok Buf.new(1, 2, 3, 4).subbuf(1, 2) eqv Buf.new(2, 3), '.subbuf(start, len)';

# Length out of bounds. Behave like substr, return elemens available.
ok Buf.new(1, 2).subbuf(0, 3) eqv Buf.new(1,2), '.substr length out of bounds';
ok Buf.new.subbuf(0, 1) eqv Buf.new(), "subbuf on an empty buffer";

{ # Throw on negative range
    Buf.new(1).subbuf(-1, 1);
    ok 0, "throw on negative range";
    CATCH { when X::OutOfRange { ok 1, "throw on negative range" } }
}

{ # Throw on out of bounds
    Buf.new(0xFF).subbuf(2, 1);
    ok 0, "throw on out of range (positive)";
    CATCH { when X::OutOfRange { ok 1, "throw on out of range (positive)" } }
}

{ # Counted from the end
    ok Buf.new(^10).subbuf(*-5, 5) eqv Buf.new(5..9), "counted from the end";
    ok Buf.new(1, 2).subbuf(*-1, 10) eqv Buf.new(2), "counted from the end, length out of bounds";
}

{ # Throw on out of bounds, from the end.
    Buf.new(0xFF).subbuf(*-2, 1);
    ok 0, "throw on out of bounds, counted from the end";
    CATCH { when X::OutOfRange { ok 1, "throw on out of bounds, counted from the end"; } }
}

{ 
    Buf.new().subbuf(0, -1);
    ok 0, "throw on negative len";
    CATCH { when X::OutOfRange { ok 1, "throw on negative len" } }
}

rakudo-2013.12/t/spec/S03-operators/chained-declarators.t0000664000175000017500000000172012224265625022450 0ustar  moritzmoritzuse v6;
use Test;

# L
# This section describes declarators like my, our, etc
# Note that the usage of declarators on the RHS is not spec'ed yet,
# but works like Perl 5. Also note that the list if declarators here
# does not match the list described in the referenced specs. 

plan 5;

# sanity: declarations and very simple use (scoping tests come later)
# we take care to use different names to avoid other *kinds* of insanity.

is((try {  my $a1 = my    $b1 = 42; $b1++; "$a1, $b1" }), '42, 43', "chained my");
is((try {  my $a2 = our   $b2 = 42; $b2++; "$a2, $b2" }), '42, 43', "chained my, our");
is((try {  my $a4 = constant $b4 = 42;     "$a4, $b4" }), '42, 42', "chained my, constant");
is((try {  my $a5 = state $b5 = 42; $b5++; "$a5, $b5" }), '42, 43', "chained my, state");

# scoping

eval_dies_ok '
    {
        our $sa2 = my $sb2 = 42;
    }
    ($sa2, $sb2);
   ', "scoping our, my ('our' doesn't leak)";

# XXX: add more!

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/cmp.t0000664000175000017500000000301512237474612017334 0ustar  moritzmoritzuse v6;
use Test;

plan 22;

# cmp on scalar values
{
    is 5 cmp 6, Order::Less, "cmp on int (1)";
    is 5 cmp 5, Order::Same, "cmp on int (2)";
    is 6 cmp 5, Order::More, "cmp on int (3)";

    is "a" cmp "b", Order::Less, "cmp on characters (1)";
    is "b" cmp "a", Order::More, "cmp on characters (2)";
    is "a" cmp "a", Order::Same, "cmp on characters (3)";
}

# cmp on variables
{
    my Int $a = 11;
    my Int $b = 10;

    is $a cmp $b, Order::More, "cmp on Int variables (1)";
    --$a;
    is $a cmp $b, Order::Same, "cmp on Int variables (2)";
    --$a;
    is $a cmp $b, Order::Less, "cmp on Int variables (3)";

    my Str $c = "aaa";
    my Str $d = "bbb";

    is $c cmp $d, Order::Less, "cmp on Str variables (1)";
    $c = "bbb";
    is $c cmp $d, Order::Same, "cmp on Str variables (2)";
    $c = "ccc";
    is $c cmp $d, Order::More, "cmp on Str variables (3)";
}

# cmp on Pair
{
    is (:a<5> cmp :a<5>), Order::Same, "cmp on Pair (1)";
    is (:a<5> cmp :b<5>), Order::Less, "cmp on Pair (2)";
    is (:b<5> cmp :a<5>), Order::More, "cmp on Pair (3)";
    is (:a<6> cmp :a<5>), Order::More, "cmp on Pair (4)";
    is (:a<5> cmp :a<6>), Order::Less, "cmp on Pair (5)";

    my $cmp5 = { :$^q cmp :q<5> };
    is $cmp5(5), Order::Same, "cmp on Pair from local variable";

    is (:a<5> cmp  Inf), Order::Less, "cmp on Pair/Inf";
    is (:a<5> cmp -Inf), Order::More, "cmp on Pair/-Inf";
    is ( Inf cmp :a<5>), Order::More, "cmp on Inf/Pair";
    is (-Inf cmp :a<5>), Order::Less, "cmp on -Inf/Pair";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/comparison-simple.t0000664000175000017500000000274412237474612022226 0ustar  moritzmoritzuse v6;
use Test;

plan 24;

# N.B.:  relational ops are in relational.t

#L

# spaceship comparisons (Num)
is(1 <=> 1, Order::Same, '1 <=> 1 is same');
is(1 <=> 2, Order::Less, '1 <=> 2 is increase');
is(2 <=> 1, Order::More, '2 <=> 1 is decrease');

is 0 <=> -1,      Order::More, '0 <=> -1 is increase';
is -1 <=> 0,      Order::Less, '-1 <=> 0 is decrease';
is 0 <=> -1/2,    Order::More, '0 <=> -1/2 is increase';
is 0 <=> 1/2,     Order::Less, '0 <=> 1/2 is increase';
is -1/2 <=> 0,    Order::Less, '-1/2 <=> 0 is decrease';
is 1/2 <=> 0,     Order::More, '1/2 <=> 0 is decrease';
is 1/2 <=> 1/2,   Order::Same, '1/2 <=> 1/2 is same';
is -1/2 <=> -1/2, Order::Same, '-1/2 <=> -1/2 is same';
is 1/2 <=> -1/2,  Order::More,  '1/2 <=> -1/2 is decrease';
is -1/2 <=> 1/2,  Order::Less, '-1/2 <=> 1/2 is increase';

# leg comparison (Str)
is('a' leg 'a', Order::Same, 'a leg a is same');
is('a' leg 'b', Order::Less, 'a leg b is increase');
is('b' leg 'a', Order::More, 'b leg a is decrease');
is('a' leg 1,   Order::More, 'leg is in string context');

# cmp comparison
is('a' cmp 'a', Order::Same, 'a cmp a is same');
is('a' cmp 'b', Order::Less, 'a cmp b is increase');
is('b' cmp 'a', Order::More, 'b cmp a is decrease');
is(1 cmp 1,     Order::Same, '1 cmp 1 is same');
is(1 cmp 2,     Order::Less, '1 cmp 2 is increase');
is(2 cmp 1,     Order::More, '2 cmp 1 is decrease');
is('a' cmp 1,   Order::More, '"a" cmp 1 is decrease'); # unspecced but P5 behavior

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/comparison.t0000664000175000017500000000475712237474612020745 0ustar  moritzmoritzuse v6;
use Test;

plan 41;

# N.B.:  relational ops are in relational.t

# L
is(+Order::Less, -1, 'Order::Less numifies to -1');
is(+Order::Same,  0, 'Order::Same numifies to 0');
is(+Order::More,  1, 'Order::More numifies to 1');

#L

# spaceship comparisons (Num)
is(1 <=> 1, Order::Same, '1 <=> 1 is same');
is(1 <=> 2, Order::Less, '1 <=> 2 is less');
is(2 <=> 1, Order::More, '2 <=> 1 is more');

is 0 <=> -1,      Order::More, '0 <=> -1 is less';
is -1 <=> 0,      Order::Less, '-1 <=> 0 is more';
is 0 <=> -1/2,    Order::More, '0 <=> -1/2 is more';
is 0 <=> 1/2,     Order::Less, '0 <=> 1/2 is less';
is -1/2 <=> 0,    Order::Less, '-1/2 <=> 0 is more';
is 1/2 <=> 0,     Order::More, '1/2 <=> 0 is more';
is 1/2 <=> 1/2,   Order::Same, '1/2 <=> 1/2 is same';
is -1/2 <=> -1/2, Order::Same, '-1/2 <=> -1/2 is same';
is 1/2 <=> -1/2,  Order::More, '1/2 <=> -1/2 is more';
is -1/2 <=> 1/2,  Order::Less, '-1/2 <=> 1/2 is less';

# leg comparison (Str)
is('a' leg 'a',     Order::Same, 'a leg a is same');
is('a' leg 'b',     Order::Less, 'a leg b is less');
is('b' leg 'a',     Order::More, 'b leg a is more');
is('a' leg 1,       Order::More, 'leg is in string context');
is("a" leg "a\0",   Order::Less, 'a leg a\0 is less');
is("a\0" leg "a\0", Order::Same, 'a\0 leg a\0 is same');
is("a\0" leg "a",   Order::More, 'a\0 leg a is more');

# cmp comparison
is('a' cmp 'a',     Order::Same, 'a cmp a is same');
is('a' cmp 'b',     Order::Less, 'a cmp b is less');
is('b' cmp 'a',     Order::More, 'b cmp a is more');
is(1 cmp 1,         Order::Same, '1 cmp 1 is same');
is(1 cmp 2,         Order::Less, '1 cmp 2 is less');
is(2 cmp 1,         Order::More, '2 cmp 1 is more');
is('a' cmp 1,       Order::More, '"a" cmp 1 is more'); # unspecced P5 behavior
is("a" cmp "a\0",   Order::Less, 'a cmp a\0 is less');
is("a\0" cmp "a\0", Order::Same, 'a\0 cmp a\0 is same');
is("a\0" cmp "a",   Order::More, 'a\0 cmp a is more');

# compare numerically with non-numeric
{
    class Blue { 
        method Numeric() { 3; }
    } 
    my $a = Blue.new;

    ok +$a == 3, '+$a == 3 (just checking)';
    ok $a == 3, '$a == 3';
    ok $a != 4, '$a != 4';
    nok $a != 3, 'not true that $a != 3';
    
    #?rakudo 4 todo 'nom regression'
    lives_ok { $a < 5 }, '$a < 5 lives okay';
    lives_ok { $a <= 5 }, '$a <= 5 lives okay';
    lives_ok { $a > 5 }, '$a > 5 lives okay';
    lives_ok { $a >= 5 }, '$a => 5 lives okay';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/context-forcers.t0000664000175000017500000001713012224265625021703 0ustar  moritzmoritzuse v6;

use Test;

plan 97;

#?DOES 1
sub iis(Mu $a, Mu $b, $descr) {
    unless ok($a === $b, $descr) {
        diag "Got:      " ~ $a.perl;
        diag "Expected: " ~ $b.perl;
    }

}

{ # L
  iis ?True,    True,  "? context forcer works (1)";
  iis ?False,   False, "? context forcer works (2)";

  iis ?1,       True,  "? context forcer works (3)";
  iis ?0,       False, "? context forcer works (4)";
  iis ?(?1),    True,  "? context forcer works (5)";
  iis ?(?0),    False, "? context forcer works (6)";

  iis ?"hi",    True,  "? context forcer works (7)";
  iis ?"",      False, "? context forcer works (8)";
  iis ?(?"hi"), True,  "? context forcer works (9)";
  iis ?(?""),   False, "? context forcer works (10)";

  iis ?"3",     True,  "? context forcer works (11)";
  iis ?"0",     False, "? context forcer works (12)";
  iis ?(?"3"),  True,  "? context forcer works (13)";
  iis ?(?"0"),  False, "? context forcer works (14)";

  iis ?Mu,      False, "? context forcer works (15)";
}
{ # L
  iis ?[],      False,  "? context forcer: empty container is false";
  iis ?[1],     True,   "? context forcer: non-empty container is true";
}
{ # L
  iis ?{},      False,  "? context forcer: empty hash is false";
  iis ?{:a},    True,   "? context forcer: non-empty hash is true";
}

{ # L
  is +1,           1, "+ context forcer works (1)";
  is +0,           0, "+ context forcer works (2)";
  is +(3/4),     3/4, "+ context forcer works (3)";
  is +(3i),       3i, "+ context forcer works (4)";
  #?pugs todo 'Mu'
  dies_ok { +Mu },    "+ context forcer works (5)";
  is +(?0),        0, "+ context forcer works (13)";
  is +(?3),        1, "+ context forcer works (14)";
}

{ # L
  is -1,          -1, "- context forcer works (1)";
  is -0,          -0, "- context forcer works (2)";
  is -(3/4),    -3/4, "- context forcer works (3)";
  is -(3i),      -3i, "- context forcer works (4)";
  #?pugs todo 'Mu'
  dies_ok { -Mu },    "- context forcer works (5)";
  #?pugs todo
  is -(?0),        0, "- context forcer works (13)";
  is -(?3),       -1, "- context forcer works (14)";
}

{ # L
  is ~1,         "1", "~ context forcer works (1)";
  is ~0,         "0", "~ context forcer works (2)";
  is ~"1",       "1", "~ context forcer works (3)";
  is ~"0",       "0", "~ context forcer works (4)";
  is ~"",         "", "~ context forcer works (5)";
  #?pugs todo 'Mu'
  #?niecza todo 'https://github.com/sorear/niecza/issues/179'
  dies_ok { ~Mu },    "~ context forcer works (6)";
  is ~"Inf",   "Inf", "~ context forcer works (7)";
  is ~"-Inf", "-Inf", "~ context forcer works (8)";
  is ~"NaN",   "NaN", "~ context forcer works (9)";
  is ~"3e5",   "3e5", "~ context forcer works (10)";
}

ok 4.Str ~~ Str, 'Int.Str returns a Str';

sub eval_elsewhere($code){ eval($code) }

# L
# numeric (+) context
#?niecza skip "Failure NYI"
#?pugs skip 'Failure'
{
    my $a = '2 is my favorite number';
    isa_ok(+$a, Failure, 'trailing chars cause failure');

    my $b = 'Did you know that, 2 is my favorite number';
    isa_ok(+$b, Failure, 'it is forced into a Num');
}

# L">
#?rakudo skip 'failure modes of Str.Numeric'
#?niecza skip "Failure NYI"
#?pugs skip 'Failure'
{
    my $a = '2 is my favorite number';
    isa_ok(-$a, Failure, 'trailing chars cause failure');

    my $b = 'Did you know that, 2 is my favorite number';
    ok(-$b, Failure, 'it is forced into a Num');
}

# L
# L
# string context
#?pugs skip 'Stringy'
{
    my $a = 10.500000;
    #?niecza skip "Stringy NYI"
    ok(~$a ~~ Stringy, 'it is forced into a Str');
    is(~$a, '10.5', 'forced into string context');

    my $b = -100;
    #?niecza skip "Stringy NYI"
    ok(~$b ~~ Stringy, 'it is forced into a Str');
    is(~$b, '-100', 'forced into string context');

    my $c = -100.1010;
    #?niecza skip "Stringy NYI"
    ok(~$c ~~ Stringy, 'it is forced into a Str');
    is(~$c, '-100.101', 'forced into string context');
}

# L
# L
# boolean context
{
    my $a = '';
    isa_ok(?$a, Bool, 'it is forced into a Bool');
    ok(!(?$a), 'it is forced into boolean context');

    my $b = 'This will be true';
    isa_ok(?$b, Bool, 'it is forced into a Bool');
    ok(?$b, 'it is forced into boolean context');

    my $c = 0;
    isa_ok(?$c, Bool, 'it is forced into a Bool');
    ok(!(?$c), 'it is forced into boolean context');

    my $d = 1;
    isa_ok(?$d, Bool, 'it is forced into a Bool');
    ok(?$d, 'it is forced into boolean context');
}

#?niecza skip 'Trait dynamic not available on variables'
{
    my $arrayref is dynamic = list(1,2,3);
    my $boo is dynamic = 37;
    ok eval_elsewhere('?(@$*arrayref)'), '?(@$arrayref) syntax works';
    ok eval_elsewhere('?(@($*arrayref))'), '?(@($arrayref)) syntax works';
}

# L">
{
    my $a = '';
    isa_ok(!$a, Bool, 'it is forced into a Bool');
    ok(!$a, 'it is forced into boolean context');

    my $b = 'This will be true';
    isa_ok(!$b, Bool, 'it is forced into a Bool');
    ok(!(!$b), 'it is forced into boolean context');

    my $c = 0;
    isa_ok(!$c, Bool, 'it is forced into a Bool');
    ok(!$c, 'it is forced into boolean context');

    my $d = 1;
    isa_ok(!$d, Bool, 'it is forced into a Bool');
    ok(!(!$d), 'it is forced into boolean context');

}
#?niecza skip 'Trait context not available on variables'
{
    my $arrayref is dynamic = list(1,2,3);

    ok eval_elsewhere('!(!(@$*arrayref))'), '!(@$arrayref) syntax works';
    ok eval_elsewhere('!(!(@($*arrayref)))'), '!(@($arrayref)) syntax works';
}

# int context
# tested in t/spec/S32-num/int.t

{
    my $x = [0, 100, 280, 33, 400, 5665];

    is @($x)[1], 100, '@$x works';

    is @($x)[3]+50, 83, '@$x works inside a larger expression';

    my $y = [601, 700, 888];

    my @total = (@$x, @$y);

    is @total[0], 0, "total[0] is 0";
    is @total[1], 100, "total[1] is 100";
    is @total[6], 601, "total[6] is 601";
    is @total[8], 888, "total[8] is 888";
}

#?niecza skip 'Unmatched key in Hash.LISTSTORE'
{
    ok %() ~~ Hash, '%() returns a Hash';
    is +%(), 0, '%() is an empty Hash';
}

#?pugs skip 'Cannot cast into a Hash'
{
    my $x = %(a => 3, b => 5);
    is $x, 3, 'hash constructor worked (1)';
    is $x, 5, 'hash constructor worked (1)';
    is $x.keys.sort.join(', '), 'a, b', 'hash constructor produced the right keys';
}

# the "upto" operator
# L">

# ^$x is the range 0 .. ($x -1)
{
    #?pugs todo
    ok   0 ~~ ^10, '0 is in ^10';
    #?pugs todo
    ok   9 ~~ ^10, '9 is in ^10';
    #?pugs todo
    ok 9.9 ~~ ^10, '9.99 is in ^10';
    ok 10 !~~ ^10, '10 is not in ^10';
    is (^10).elems, 10, '^10 has 10 elems';
    #?pugs skip 'Range'
    isa_ok ^10, Range;

    # now the same for ^@array, in which case prefix:<^>
    # imposes numeric context

    my @a = ;
    #?pugs todo
    ok   0 ~~ ^@a, '0 is in ^10';
    #?pugs todo
    ok   9 ~~ ^@a, '9 is in ^10';
    #?pugs todo
    ok 9.9 ~~ ^@a, '9.99 is in ^10';
    ok  10 !~~ ^@a, '10 is not in ^10';
    is (^@a).elems, 10, '^10 has 10 elems';
    #?pugs skip 'Range'
    isa_ok ^@a, Range;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/context.t0000664000175000017500000000763412224265625020252 0ustar  moritzmoritzuse v6;

use Test;

plan 32;

# L

{
    my $a = 3;
    my $b = 2;
    my $c = 1;

    # I'm not sure that smart matching is the best operation for comparison here
    # There might be a more specific way to check that prevents false matching
    #?pugs todo
    isa_ok(list($a).WHAT,  List, 'list(values) returns nothing more than a List');
    isa_ok(@($a).WHAT,     List, '@(values) returns nothing more than a List');
    #?pugs todo
    isa_ok((list $a).WHAT, List, '(list values) returns nothing more than a List');

    # These are all no-ops but still need to work correctly
    isa_ok(list($a, $b, $c).WHAT,   List, 'list(values) returns nothing more than a List');
    isa_ok(@($a, $b, $c).WHAT,      List, '@(values) returns nothing more than a List');
    isa_ok((list $a, $b, $c).WHAT,  List, '(list values) returns nothing more than a List');
    is((list $a, $b, $c), ($a, $b, $c), 'list($a, $b, $c) is ($a, $b, $c)');
    is(@($a, $b, $c),     ($a, $b, $c), '@($a, $b, $c) is ($a, $b, $c)');

    # Test the only difference between @() and list()
    is(list(), (), 'list() should return an empty list');
    'foo' ~~ /(o)o/; # run a regex so we have $/ below
    is(@(),  @($/), '@() should be the same as @($/)');
}


# L
# L
{
    my $a = 3;
    my $b = 2;

    is((item $a).WHAT.gist, $a.WHAT.gist, '(item $a).WHAT matches $a.WHAT');
    is((item $a), $a, 'item $a is just $a');
    is(item($a),  $a, 'item($a) is just $a');
    is($($a),     $a, '$($a) is just $a');

    #?niecza skip 'Excess arguments to item, used 1 of 2 positionals'
    isa_ok((item $a, $b).WHAT, Array, '(item $a, $b) makes an Array');
    #?niecza skip 'Excess arguments to item, used 1 of 2 positionals'
    isa_ok(item($a, $b).WHAT,  Array, 'item $a, $b makes an Array');
    #?pugs skip 'Parcel'
    #?niecza skip 'Excess arguments to item, used 1 of 2 positionals'
    isa_ok($($a, $b).WHAT,     Parcel, '$ $a, $b makes a Parcel');
    my @array = ($a, $b);
    #?niecza skip 'Excess arguments to item, used 1 of 2 positionals'
    is((item $a, $b), @array, 'item($a, $b) is the same as <<$a $b>> in an array');
}

{
    # Most of these tests pass in Rakudo, but we must compare with
    # eqv instead of eq, since the order of hashes is not guaranteed
    # with eq. eqv does guarantee the order.
    # also, we assign to a hash since rakudo does not recognize
    # {} as a hash constructor and () does not make a hash
    #?pugs 3 todo
    ok(%('a', 1, 'b', 2)     eqv {a => 1, b => 2}, '%(values) builds a hash');
    ok(hash('a', 1, 'b', 2)  eqv {a => 1, b => 2}, 'hash(values) builds a hash');
    ok((hash 'a', 1, 'b', 2) eqv {a => 1, b => 2}, 'hash values builds a hash');
    eval_dies_ok('hash("a")', 'building a hash of one item fails');
}

# L
#                       ^ non-breaking space
# Deprecated P5 dereferencing operators:
{
    my $scalar = 'abcd';
    eval_dies_ok('${$scalar}', 'Perl 5 form of ${$scalar} dies');

    my $array  = [1, 2, 3];
    eval_dies_ok('@{$array}', 'Perl 5 form of @{$array} dies');

    my $hash  = {a => 1, b => 2, c => 3};
    eval_dies_ok('%{$hash}', 'Perl 5 form of %{$hash} dies');
}

eval_dies_ok('$', 'Anonymous $ variable outside of declaration');
eval_dies_ok('@', 'Anonymous @ variable outside of declaration');
eval_dies_ok('%', 'Anonymous % variable outside of declaration');
eval_dies_ok('&', 'Anonymous & variable outside of declaration');

# RT #76320
#?pugs skip 'Cannot cast into Hash: VRef'
{
    my $h = ;
    is ~%$h.keys.sort, 'a c', '%$var coercion';
    
    my $c = 0;
    $c++ for @$h;
    is $c, 4, '@$var coercion';
}

#?pugs todo
#?niecza skip "Invalid hard reference syntax"
{
    my @a = ;
    my $c = 0;
    $c++ for $@a;
    is $c, 1, '$@var itemization'
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/div.t0000664000175000017500000000050112224265625017332 0ustar  moritzmoritzuse Test;

plan 6;

isa_ok 10 div 0   , Failure, "10 div 0 softfails";
isa_ok 10 / 0     , Rat, "10 / 0 is a Rat.";
isa_ok 10 / 0.0   , Rat, "10 / 0.0 is a rat";
isa_ok 10 / 0e0   , Failure, "10 / 0e0 softfails";
isa_ok (1/1) / 0e0, Failure, "(1/1) / 0e0 softfails";
isa_ok 1e0 / (0/1), Failure, "1e0 / (0/1) softfails";
rakudo-2013.12/t/spec/S03-operators/equality.t0000664000175000017500000000457112224265625020420 0ustar  moritzmoritzuse v6;
use Test;

plan 32;

# adapted from t/operators/eq.t and t/operators/cond.t
# relational ops are in relational.t
# cmp, leq, <=>, etc. are in comparison.t

#L
#L

# string equality & inequality
ok("a" eq "a",     "eq true");
ok(!("a" eq "ab"), "eq false");
ok("a" ne "ab",    "ne true");
ok(!("a" ne "a"),  "ne false");

# potential problem cases
ok("\0" eq "\0",   "eq on strings with null chars");
ok(!("\0" eq "\0\0"),   "!eq on strings with null chars but different lengths");
ok(!("a" eq "a\0"),   "eq doesn't have null-padding semantics");
ok(!("a" eq "a "),   "eq doesn't have space-padding semantics");
ok("a" ne "a\0",   "ne doesn't have null-padding semantics");
ok("a" ne "a ",   "ne doesn't have space-padding semantics");

# string context on undefined values
my $foo;
ok($foo eq "",     "Any eq ''");
ok($foo ne "f",    "Any ne 'f'");

my @foo;
ok(@foo[0] eq "",  "Array Any eq ''");
ok(@foo[0] ne "f",  "Array Any ne 'f'");

# numeric equality & inequality
ok(2 == 2,         "== true");
ok(!(2 == 3),      "== false");
ok(2 != 3,         "!= true");
ok(!(2 != 2),      "!= false");

#?niecza skip 'No value for parameter $r in CORE infix:<==>'
#?pugs skip 'Non-exhaustive patterns in lambda'
ok infix:<==>(False), "== with one argument is correct";
#?niecza skip 'No value for parameter $l in CORE infix:<==>'
#?pugs skip 'Missing required parameters: $?2 $?1'
ok  infix:<==>(),     "== with no arguments is correct";
#?niecza skip 'No value for parameter $r in CORE infix:'
#?pugs skip 'Non-exhaustive patterns in lambda'
ok infix:(False), "!= with one argument is correct";
#?niecza skip 'No value for parameter $l in CORE infix:'
#?pugs skip 'Missing required parameters: $?2 $?1'
ok  infix:(),     "!= with no arguments is correct";

#L
ok(2 !== 3,         "!== true");
ok(!(2 !== 2),      "!== false");
ok($foo !eq "f",    "!eq true undef");
ok("" !eq "f",    "!eq true empty string");
ok(!($foo !eq ""),  "!eq false undef and empty string");
ok(!($foo !eq $foo),  "!eq false undef twice");
ok(!("" !eq ""),  "!eq false empty string twice");
ok(!("xc" !eq "xc"),  "!eq false non-empty string twice");

# numeric context on undefined values
ok($foo == 0,      "Any == 0");
ok(@foo[0] == 0,   "Array Any == 0");

# XXX: need tests for coercion string and numeric coercions

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/eqv.t0000664000175000017500000001063612224265625017355 0ustar  moritzmoritzuse v6;
use Test;

plan 54;

# L
# L

# eqv on values
{
  ok  (1 eqv 1), "eqv on values (1)";
  ok  (0 eqv 0), "eqv on values (2)";
  ok !(0 eqv 1), "eqv on values (3)";
}

# Value types
{
  my $a = 1;
  my $b = 1;

  ok $a eqv $a, "eqv on value types (1-1)";
  ok $b eqv $b, "eqv on value types (1-2)";
  ok $a eqv $b, "eqv on value types (1-3)";
}


{
  my $a = 1;
  my $b = 2;

  ok  ($a eqv $a), "eqv on value types (2-1)";
  ok  ($b eqv $b), "eqv on value types (2-2)";
  ok !($a eqv $b), "eqv on value types (2-3)";
}

#?niecza skip 'Cannot use value like Capture as a number'
{
  my @a = (1,2,3);
  my @b = (1,2,3);

  ok  (\@a eqv \@a), "eqv on array references (1)";
  ok  (\@b eqv \@b), "eqv on array references (2)";
  #?pugs todo
  #?rakudo todo 'huh?'
  ok !(\@a eqv \@b), "eqv on array references (3)";
  @a := @b;
  ok \@a eqv \@b, '\@array of two bound arrays are eqv';
}

#?niecza skip 'Cannot use value like Capture as a number'
{
  my $a = \3;
  my $b = \3;

  ok ($a eqv $a), "eqv on scalar references (1-1)";
  ok ($b eqv $b), "eqv on scalar references (1-2)";
  ok ($a eqv $b), "eqv on scalar references (1-3)";
  #?pugs todo
  #?rakudo todo 'huh?'
  ok (\$a !eqv \$b), "eqv on scalar references (1-4)";
}

#?niecza skip 'Cannot use value like Block as a number'
{
  my $a = { 3 };
  my $b = { 3 };

  ok ($a eqv $a), "eqv on sub references (1-1)";
  ok ($b eqv $b), "eqv on sub references (1-2)";
  # it's impossible to compare blocks for equivalence in general,
  # and they have associations to different source locations
  # (line number, column)
  nok ($a eqv $b), "eqv on sub references (1-3)";
  nok ($a eqv { 5 }), 'eqv on sub references (1-4)';
}

#?niecza skip 'Cannot use value like Sub as a number'
{
  ok  (&say eqv &say), "eqv on sub references (2-1)";
  ok  (&map eqv &map), "eqv on sub references (2-2)";
  ok !(&say eqv &map), "eqv on sub references (2-3)";
}

#?niecza skip 'Cannot use value like Capture as a number'
{
  my $num = 3; my $a   = \$num;
  my $b   = \$num;

  ok  ($a eqv $a), "eqv on scalar references (2-1)";
  ok  ($b eqv $b), "eqv on scalar references (2-2)";
  ok  ($a eqv $b), "eqv on scalar references (2-3)";
}

{
  nok ([1,2,3] eqv [4,5,6]), "eqv on anonymous array references (1)";
  ok ([1,2,3] eqv [1,2,3]), "eqv on anonymous array references (2)";
  ok ([]      eqv []),      "eqv on anonymous array references (3)";
}

{
  ok !({a => 1} eqv {a => 2}), "eqv on anonymous hash references (-)";
  #?pugs todo
  ok  ({a => 1} eqv {a => 1}), "eqv on anonymous hash references (+)";
  #?pugs todo
  ok ({a => 2, b => 1} eqv { b => 1, a => 2}), 'order really does not matter'; 
  ok !({a => 1} eqv {a => 1, b => 2}), 'hashes: different number of pairs';
}

#?niecza skip 'Cannot use value like Capture as a number'
{
  ok !(\3 eqv \4),         "eqv on anonymous scalar references (1)";
  # XXX the following seems bogus nowadays
  #?pugs 2 todo
  #?rakudo todo 'huh?'
  ok !(\3 eqv \3),         "eqv on anonymous scalar references (2)";
  #?rakudo skip 'huh?'
  ok !(\Mu eqv \Mu), "eqv on anonymous scalar references (3)";
}

# Chained eqv (not specced, but obvious)
{
  ok  (3 eqv 3 eqv 3), "chained eqv (1)";
  ok !(3 eqv 3 eqv 4), "chained eqv (2)";
}

# Subparam binding doesn't affect eqv test
{
  my $foo;
  my $test = -> $arg { $foo eqv $arg };

  $foo = 3;
  ok  $test($foo), "subparam binding doesn't affect eqv (1)";
  ok  $test(3),    "subparam binding doesn't affect eqv (2)";

  ok !$test(4),    "subparam binding doesn't affect eqv (3)";
  my $bar = 4;
  ok !$test($bar), "subparam binding doesn't affect eqv (4)";
}

{
    is(1 eqv 1, Bool::True,  'eqv returns Bool::True when true');
    is(0 eqv 1, Bool::False, 'eqv returns Bool::False when false');
}

{
    is Any eqv Any, Bool::True, 'Any eqv Any';
}

#?pugs skip "autothreaded?"
{
    ok 'a' eqv any , "eqv autothreads correctly";
}

# RT #75322 - Rakudo used to be confused when lists began with ()
{
    #?niecza todo
    nok ((), "x") eqv ((), 9), 'list starting with () - 1';
    nok ((), (), 1) eqv ((), 9), 'list starting with () - 1';
    nok ((), (), (), 1) eqv ((), (), ""), 'list starting with () - 1';
    nok ((), (), (), 1) eqv ((), 4), 'list starting with () - 1';
    ok ((), ()) eqv ((), ()), '((), ())';
}

# Nieczabug #142
{
    nok 4 eqv 4.0, "Values should be eqv only if they are the same type";
    nok 4 eqv '4', 'Str vs. Int';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/fiddly.t0000664000175000017500000000033012224265625020023 0ustar  moritzmoritzuse v6;
use Test;
plan 1;

# RT#86340
# The [=] operator is fiddly and complier should not allow it

my $fiddly_code = 'my ($a, $b) = (1,2); my @c = [=] $a, $b;';

eval_dies_ok $fiddly_code , 'dies on fiddly code';

rakudo-2013.12/t/spec/S03-operators/flip-flop.t0000664000175000017500000001206112224265625020444 0ustar  moritzmoritzuse v6;

use Test;

plan 39;

# L


# Basic ff
{
    $_ = "1";
    ok (1 ff 1), 'flip-flop operator implemented';
    
    ok (1 fff 1), 'fff operator implemented';
}


# test basic flip-flop operation
{

    sub test_ff($code, @a) {
        my $ret = '';
        for @a {
            $ret ~= $code.($_) ?? $_ !! 'x';
        }
        return $ret;
    }

    is test_ff({/B/ ff /D/   }, ), 'xBCDx', '/B/ ff /D/, lhs != rhs';
    is test_ff({/B/ ^ff /D/  }, ), 'xxCDx', '/B/ ^ff /D/, lhs != rhs';
    is test_ff({/B/ ff^ /D/  }, ), 'xBCxx', '/B/ ff^ /D/, lhs != rhs';
    is test_ff({/B/ ^ff^ /D/ }, ), 'xxCxx', '/B/ ^ff^ /D/, lhs != rhs';
    
    is test_ff({/B/ fff /D/  }, ), 'xBCDx', '/B/ fff /D/, lhs != rhs';
    is test_ff({/B/ ^fff /D/ }, ), 'xxCDx', '/B/ ^fff /D/, lhs != rhs';
    is test_ff({/B/ fff^ /D/ }, ), 'xBCxx', '/B/ fff^ /D/, lhs != rhs';
    is test_ff({/B/ ^fff^ /D/}, ), 'xxCxx', '/B/ ^fff^ /D/, lhs != rhs';

    is test_ff({/B/ ff /B/   }, ), 'xBxBx', '/B/ ff /B/, lhs == rhs';
    is test_ff({/B/ ^ff /B/  }, ), 'xxxxx', '/B/ ^ff /B/, lhs == rhs';
    is test_ff({/B/ ff^ /B/  }, ), 'xxxxx', '/B/ ff^ /B/, lhs == rhs';
    is test_ff({/B/ ^ff^ /B/ }, ), 'xxxxx', '/B/ ^ff^ /B/, lhs == rhs';
    
    is test_ff({/B/ fff /B/  }, ), 'xBABx', '/B/ fff /B/, lhs == rhs';
    is test_ff({/B/ ^fff /B/ }, ), 'xxABx', '/B/ ^fff /B/, lhs == rhs';
    is test_ff({/B/ fff^ /B/ }, ), 'xBAxx', '/B/ fff^ /B/, lhs == rhs';
    is test_ff({/B/ ^fff^ /B/}, ), 'xxAxx', '/B/ ^fff^ /B/, lhs == rhs';

    is test_ff({/B/ ff *     }, ), 'xBCDE', '/B/ ff *';
}


# test flip-flop sequence management
{
    sub test_ff_cnt($code, @a) {
        my $ret = '';
        for @a {
            my $i;
            $ret ~= (($i = $code.($_)) ?? $_ !! 'x') ~ $i;
        }
        return $ret;
    }

    is test_ff_cnt({/B/ ff /D/   }, ), 'xB1C2D3x', '/B/ ff /D/, seq #s, lhs != rhs';
    is test_ff_cnt({/B/ ^ff /D/  }, ), 'xxC2D3x', '/B/ ^ff /D/, seq #s, lhs != rhs';
    is test_ff_cnt({/B/ ff^ /D/  }, ), 'xB1C2xx', '/B/ ff^ /D/, seq #s, lhs != rhs';
    is test_ff_cnt({/B/ ^ff^ /D/ }, ), 'xxC2xx', '/B/ ^ff^ /D/, seq #s, lhs != rhs';
    
    is test_ff_cnt({/B/ fff /D/  }, ), 'xB1C2D3x', '/B/ fff /D/, seq #s, lhs != rhs';
    is test_ff_cnt({/B/ ^fff /D/ }, ), 'xxC2D3x', '/B/ ^fff /D/, seq #s, lhs != rhs';
    is test_ff_cnt({/B/ fff^ /D/ }, ), 'xB1C2xx', '/B/ fff^ /D/, seq #s, lhs != rhs';
    is test_ff_cnt({/B/ ^fff^ /D/}, ), 'xxC2xx', '/B/ ^fff^ /D/, seq #s, lhs != rhs';

    is test_ff_cnt({/B/ ff /B/   }, ), 'xB1xB1x', '/B/ ff /B/, seq #s, lhs == rhs';
    is test_ff_cnt({/B/ ^ff /B/  }, ), 'xxxxx', '/B/ ^ff /B/, seq #s, lhs == rhs';
    is test_ff_cnt({/B/ ff^ /B/  }, ), 'xxxxx', '/B/ ff^ /B/, seq #s, lhs == rhs';
    is test_ff_cnt({/B/ ^ff^ /B/ }, ), 'xxxxx', '/B/ ^ff^ /B/, seq #s, lhs == rhs';
    
    is test_ff_cnt({/B/ fff /B/  }, ), 'xB1A2B3x', '/B/ fff /B/, seq #s, lhs == rhs';
    is test_ff_cnt({/B/ ^fff /B/ }, ), 'xxA2B3x', '/B/ ^fff /B/, seq #s, lhs == rhs';
    is test_ff_cnt({/B/ fff^ /B/ }, ), 'xB1A2xx', '/B/ fff^ /B/, seq #s, lhs == rhs';
    is test_ff_cnt({/B/ ^fff^ /B/}, ), 'xxA2xx', '/B/ ^fff^ /B/, seq #s, lhs == rhs';
}


# See thread "till (the flipflop operator, formerly ..)" on p6l started by Ingo
# Blechschmidt, especially Larry's reply:
# http://www.nntp.perl.org/group/perl.perl6.language/24098
# make sure calls to external sub uses the same ff each time
{
    sub check_ff($i) {
        $_ = $i;
        return (/B/ ff /D/) ?? $i !! 'x';
    }

    my $ret = "";
    $ret ~= check_ff('A');
    $ret ~= check_ff('B');
    $ret ~= check_ff('C');
    $ret ~= check_ff('D');
    $ret ~= check_ff('E');
    is $ret, 'xBCDx', 'calls from different locations use the same ff';
}

# From the same thread, making sure that clones get different states
{
    my $ret = "";
    for 0,1 {
        sub check_ff($_) { (/B/ ff /D/) ?? $_ !! 'x' }
        $ret ~= check_ff('A');
        $ret ~= check_ff('B');
        $ret ~= check_ff('C');
    }
    is $ret, 'xBCxBC', 'different clones of the sub get different ff'
}

# make sure {lhs,rhs} isn't evaluated when state is {true,false}
#?rakudo skip 'dubious scoping?'
{

    # keep track of # of times lhs and rhs are eval'd by adding
    # a state var to both sides.
    sub ff_eval($code, $lhs, $rhs, @a) {
        my $lhs_run = 0;
        my $rhs_run = 0;

        for @a { $code.({$lhs_run++; ?$lhs}, {$rhs_run++; ?$rhs}); }

        return [$lhs_run, $rhs_run];
    }

    is_deeply ff_eval({@_[0]() ff @_[1]()}, /B/, /B/, ),
        [5, 2], "count lhs & rhs evals for ff";

    
    is_deeply ff_eval({@_[0]() fff @_[1]()}, /B/, /B/, ),
        [3, 2], "count lhs & rhs evals for fff";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/gcd.t0000664000175000017500000000232712224265625017315 0ustar  moritzmoritzuse v6;
use Test;
plan 16;

# L

=begin pod

Basic tests for the gcd operator

=end pod

is 10 gcd 5, 5, "The gcd of 10 and 5 is 5";
isa_ok 10 gcd 5, Int, "The gcd of 10 and 5 is an Int";
is -432 gcd 63, 9, "The gcd of -432 and 63 is 9";
is 4342 gcd 65536, 2, "The gcd of 4342 and 65536 is 2";
isa_ok 4342 gcd 65536, Int, "The gcd of 4342 and 65536 is an Int";

is ([gcd] 25..26), 1, '[gcd] Range works';
{
    my @a = 50, 70, 100, 2005;
    is ([gcd] @a), 5, '[gcd] array works';
}

{
    is 10.1 gcd 5.3, 5, "gcd converts Rats to Ints correctly";
    isa_ok 10.1 gcd 5.3, Int, "and the result is an Int";
    is 10.1e0 gcd 5.3e0, 5, "gcd converts Nums to Ints correctly";
    isa_ok 10.1e0 gcd 5.3e0, Int, "and the result is an Int";
}

{
    is 123123123123123123123123123 gcd 3, 3, "gcd handles big Int and small Int";
    is 123123123123123123123123123 gcd 2, 1, "gcd handles big Int and small Int";
    is 3 gcd 123123123123123123123123123, 3, "gcd handles small Int and big Int";
    is 7 gcd 123123123123123123123123123, 1, "gcd handles small Int and big Int";
    is 123123123123123123123123123123 gcd 123123123123123123123123123, 123, "gcd handles big Int and big Int";
}

done;
# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/identity.t0000664000175000017500000001013612224265625020406 0ustar  moritzmoritzuse v6;

use Test;

plan 45;

# C<=:=> is only for containers, not values

#L

{
  my $foo = 1;
  my $bar = 1;
  ok  ($foo =:= $foo), '$foo =:= $foo is true';
  ok  ($bar =:= $bar), '$bar =:= $bar is true';
  ok !($foo =:= $bar), '$foo =:= $bar is false';
  ok ($foo =:= $foo) ~~ Bool, 'success returns a Bool';
  ok ($foo =:= $bar) ~~ Bool, 'failure returns a Bool';
}

{
  my $f = sub {};
  ok $f =:= $f,        '$subref =:= $subref is true';
  ok &say =:= &say,    '&sub =:= &sub is true';
  ok !($f =:= &say),   '$subref1 =:= $subref2 is false';
}

{
  my ($a, $b, $c, $d);

  ok !($a =:= $b),     "basic sanity";

  $b := $a;
  ok  ($a =:= $b),     "=:= is true after rebinding (1-1)";
  ok  ($a =:= $a),     "=:= is true after rebinding (1-2)";
  ok  ($b =:= $b),     "=:= is true after rebinding (1-3)";

  $c := $b;
  ok  ($c =:= $a),     "=:= is true after rebinding (2-1)";
  ok  ($c =:= $b),     "=:= is true after rebinding (2-2)";
  ok  ($c =:= $c),     "=:= is true after rebinding (2-3)";

  $c := $d;
  ok !($c =:= $a),     "=:= is true after rebinding (3-1)";
  ok !($c =:= $b),     "=:= is true after rebinding (3-2)";
  ok  ($c =:= $c),     "=:= is true after rebinding (3-3)";
  ok  ($a =:= $b),     "=:= is true after rebinding (3-4)";
  ok  ($a =:= $a),     "=:= is true after rebinding (3-5)";
  ok  ($b =:= $b),     "=:= is true after rebinding (3-6)";
}

# Rebinding of array elements - unspecced!
{
  my @a = (1,2,3);
  my @b = (1,2,3);

  ok !(@b[1] =:= @a[1]), "rebinding of array elements (1)";

  try { @b[1] := @a[1] };
  ok  (@b[1] =:= @a[1]), "rebinding of array elements (2)";

  @b = (1,2,3);
  ok !(@b[1] =:= @a[1]), "assignment destroyed the bindings (1)";
  @a[1] = 100;
  is @a[1], 100,         "assignment destroyed the bindings (2)";
  is @b[1], 2,           "assignment destroyed the bindings (3)";
}

# Subparam binding
{
  my ($foo, $bar);
  my $test = -> $arg is rw { $foo =:= $arg };

  ok  $test($foo), "binding of scalar subparam retains =:= (1)";
  ok !$test($bar), "binding of scalar subparam retains =:= (2)";
  $bar := $foo;
  ok  $test($bar), "binding of scalar subparam retains =:= (3)";
}

{
  my ($foo, $bar);
  my $test = -> $arg is rw { $foo =:= $arg };

  ok  $test($foo), "binding of scalar subparam marked is rw retains =:= (1)";
  ok !$test($bar), "binding of scalar subparam marked is rw retains =:= (2)";
  $bar := $foo;
  ok  $test($bar), "binding of scalar subparam marked is rw retains =:= (3)";
}

# Again, unspecced that @args[0] can participate in =:=
{
  my ($foo, $bar);
  my $test = -> *@args { $foo =:= @args[0] };

  #?pugs todo 'unspecced'
  #?rakudo todo 'unspecced'
  ok  $test($foo), "binding of slurpy array subparam retains =:= (1)";
  ok !$test($bar), "binding of slurpy array subparam retains =:= (2)";
  $bar := $foo;
  #?pugs todo 'unspecced'
  #?rakudo todo 'unspecced'
  ok  $test($bar), "binding of slurpy array subparam retains =:= (3)";
}

# Again, unspecced that @args[0] can participate in =:=
{
  my ($foo, $bar);
  my $test = sub { $foo =:= @_[0] };

  #?pugs todo 'unspecced'
  #?rakudo todo 'unspecced'
  ok  $test($foo), "binding of implicit @_ subparam retains =:= (1)";
  ok !$test($bar), "binding of implicit @_ subparam retains =:= (2)";
  $bar := $foo;
  #?pugs todo 'unspecced'
  #?rakudo todo 'unspecced'
  ok  $test($bar), "binding of implicit @_ subparam retains =:= (3)";
}

class TestObj { has $!a }


{
  my $foo = ::TestObj.new(:a<3>);
  my $bar = ::TestObj.new(:a<3>);
  my $baz = $foo;
  my $frop := $foo;

  ok(!($foo =:= $bar), "two identical objects are not the same object");
  ok(!($foo =:= $baz), "two references to one object are still not the same object");
  ok(($foo =:= $frop), "binding makes two objects the same object");
}

#?rakudo todo 'misuse of =:='
#?niecza skip 'Failure NYI'
#?pugs   skip 'Failure NYI'
{
    ok (Mu =:= Mu) ~~ Failure, 'misuse of =:= is failure (Mu)';
    ok (1 =:= '1') ~~ Failure, 'misuse of =:= is failure (literals)';
    ok (1 =:= 2) ~~ Failure, 'misuse of =:= is failure (!=)';
    ok (1 =:= 1) ~~ Failure, 'misuse of =:= is failure (even when ==)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/increment.t0000664000175000017500000000576012224265625020550 0ustar  moritzmoritzuse v6;

use Test;

plan 31;

#L

=begin description

Verify that autoincrement/autodecrement work properly.
(Overflow cases are handled in S03-operators/overflow.t)

=end description

{
    my $a = Mu;
    is($a++, 0, 'Mu++ == 0');

    #?rakudo todo 'nom regression'
    #?niecza todo '#88'
    $a = Mu;
    nok(defined($a--), 'Mu-- is undefined');

    $a = 'x';
    is($a++, 'x', 'magical ++ should not be numified');
    isa_ok($a, "Str", "it isa Str");
}

my %a = ('a' => 1);
%a{"a"}++;
is(%a{'a'}, 2, "hash key"); 


my %b = ('b' => 1);
my $var = 'b';
%b{$var}++;
is(%b{$var}, 2, "hash key via var");

my @a = (1);
@a[0]++;
is(@a[0], 2, "array elem"); 

my @b = (1);
my $moo = 0;
@b[$moo]++;
is(@b[$moo], 2, "array elem via var"); 
is($moo, 0, "var was not touched");

# Test that the expression to increment will only be evaluated once.
{
  my $was_in_foo;
  my sub foo () { $was_in_foo++; 0 };

  my @array = (42);

  is(++@array[+foo()], 43, "++ evaluates the expression to increment only once (1)");
  is($was_in_foo,       1, "++ evaluates the expression to increment only once (2)");
}

# Test case courtesy of Limbic_Region
{
    my $curr  = 4;
    my @array = 1..5;
    is @array[$curr], 5, "postincrements in array subscripts work";
    @array[ --$curr ]++;

    is $curr, 3, "postincrements in array subscripts work";
    is @array[$curr], 5, "postincrements in array subscripts work";
}

# test incrementing literals
# all of those can be detected at compile time, so use eval_dies_ok here
{
    eval_dies_ok ' 4++ ', "can't postincrement a literal number";
    eval_dies_ok ' ++4 ', "can't preincrement a literal number";
    eval_dies_ok ' 4-- ', "can't postdecrement a literal number";
    eval_dies_ok ' --4 ', "can't predecrement a literal number";
    eval_dies_ok ' "x"++ ', "can't postincrement a literal string";
    eval_dies_ok ' ++"x" ', "can't preincrement a literal string";
    eval_dies_ok ' "x"-- ', "can't postdecrement a literal string";
    eval_dies_ok ' --"x" ', "can't predecrement a literal string";
}

# this used to be a rakudo regression
{
    my $x = 2.0;
    $x += 1;
    ok $x == 3.0, 'can add Int to Rat with +=';

    my Rat $y = 2.0;
    $y += 1;
    ok $y == 3.0, 'can add Int to Rat with += and type constraint';
}

{
    my $x = 2.0.Num;
    $x += 1;
    ok $x == 3.0, 'can add Int to Num with +=';

    my Num $y = 2.0.Num;
    $y += 1;
    ok $y == 3.0, 'can add Int to Num with += and type constraint';
}

# also a Rakudo regression
{
    my $x = Bool::False;
    is ++$x, Bool::True, '++ on False works';
    $x = Bool::False;
    #?pugs skip '.succ'
    is $x.succ, Bool::True, '.succ on False works';

    $x = Bool::True;
    #?pugs todo
    is --$x, Bool::False, '-- on True works';
    $x = Bool::True;
    #?pugs skip '.pred'
    is $x.pred, Bool::False, '.succ on False works';
}

# RT #74912
#?niecza todo 'Works fine in niecza...'
eval_dies_ok 'my $x = 0; ++++$x',
    'can not double-increment, because the return value is not a container';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/infixed-function.t0000664000175000017500000000056012224265625022026 0ustar  moritzmoritzuse v6;
use Test;

plan 5;

is 3 [&atan2] 4, atan2(3, 4), "3 [&atan2] 4 == atan2(3, 4)";
is 3 R[&atan2] 4, atan2(4, 3), "3 R[&atan2] 4 == atan2(4, 3)";
is 3 R[&atan2] 4, atan2(4, 3), "... and you can do it twice";

is "%10s" [&sprintf] "step", "      step", "[&sprintf] works";
is ("%04x" X[&sprintf] 7, 11, 42), "0007 000b 002a", "X[&sprint] works";

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/inplace.t0000664000175000017500000000424312224265625020172 0ustar  moritzmoritzuse v6;

use Test;

# L

plan 27;

{
    my @a = (1, 2, 3);
    lives_ok({@a .= map: { $_ + 1 }}, '.= runs with block');
    is(@a[0], 2, 'inplace map [0]');
    is(@a[1], 3, 'inplace map [1]');
    is(@a[2], 4, 'inplace map [2]');
}

{
    my @b = ;
    #?pugs todo
    lives_ok { @b.=grep(/<[a..z]>/)},
             '.= works without surrounding whitespace';
    is @b[0], 'foo', 'inplace grep [0]';
    #?pugs todo
    is @b[1], 'bar', 'inplace grep [1]';
    #?pugs todo
    is @b[2], 'baz', 'inplace grep [2]';
}

{
    my $a=3.14;
    $a .= Int;
    is($a, 3, "inplace int");
}

#?rakudo skip "Method '' not found for invocant of class 'Str'"
{
    my $b = "a_string"; $b .= WHAT;
    my $c =         42; $c .= WHAT;
    my $d =      42.23; $d .= WHAT;
    my @e = ;  @e .= WHAT;
    isa_ok($b,    Str,   "inplace WHAT of a Str");
    isa_ok($c,    Int,   "inplace WHAT of a Num");
    isa_ok($d,    Rat,   "inplace WHAT of a Rat");
    isa_ok(@e[0], Array, "inplace WHAT of an Array");
}

my $f = "lowercase"; $f .= uc;
my $g = "UPPERCASE"; $g .= lc;
my $h = "lowercase"; $h .= tc;
is($f, "LOWERCASE", "inplace uc");
is($g, "uppercase", "inplace lc");
is($h, "Lowercase", "inplace tc");

# L
my @b = ;
@b .= sort;
is ~@b, "a b d e z", "inplace sort";

{
    $_ = -42;
    .=abs;
    is($_, 42, '.=foo form works on $_');
}

# RT #64268
{
    my @a = 1,3,2;
    my @a_orig = @a;

    my @b = @a.sort: {1};
    #?niecza todo "sort is not a stable sort on all platforms"
    #?pugs todo
    is @b, @a_orig,            'worked: @a.sort: {1}';

    @a.=sort: {1};
    #?niecza todo "sort is not a stable sort on all platforms"
    #?pugs todo
    is @a, @a_orig,            'worked: @a.=sort: {1}';

    @a.=sort;
    #?pugs todo
    is @a, [1,2,3],            'worked: @a.=sort';
}

# RT #70676
{
   my $x = 5.5;
   $x .= Int;
   isa_ok $x, Int, '.= Int (type)';
   is $x, 5, '.= Int (value)';

   $x = 3;
   $x .= Str;
   isa_ok $x, Str, '.= Str (type)';
   is $x, '3', '.= Str (value)';

   $x = 15;
   $x .= Bool;
   isa_ok $x, Bool, '.= Bool (type)';
   is $x, True, '.= Bool (value)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/is-divisible-by.t0000664000175000017500000000164712224265625021557 0ustar  moritzmoritzuse v6;

use Test;

plan 15;

# L
{
    ok 6 %% 3, '6 %% 3';
    isa_ok 6 %% 3, Bool, '6 %% 3 isa Bool';
    nok 6 %% 4, '6 %% 4';
    isa_ok 6 %% 4, Bool, '6 %% 4 isa Bool';

    is (1..10).grep({ $_ %% 3 }), <3 6 9>, '%% works with explicit closure';
    is (1..10).grep( * %% 3 ), <3 6 9>, '%% works with whatever *';
} #6

{
    nok 6 !%% 3, '6 !%% 3';
    isa_ok 6 !%% 3, Bool, '6 !%% 3 isa Bool';
    ok 6 !%% 4, '6 !%% 4';
    isa_ok 6 %% 4, Bool, '6 !%% 4 isa Bool';

    is (1..10).grep({ $_ !%% 3 }), <1 2 4 5 7 8 10>, '%% works with explicit closure';
    is (1..10).grep( * !%% 3 ), <1 2 4 5 7 8 10>, '%% works with whatever *';
} #6

# RT #76170
{
    eval_dies_ok "say 9 !% 3", 'RT #76170'
} #1

{
    dies_ok {eval "9  %% 0"}, 'cannot divide by zero using infix:<%%>';
    #?rakudo todo "not sure why this doesn't fire"
    dies_ok {eval "9 !%% 0"}, 'cannot divide by zero using infix:<%%>';
} #2
rakudo-2013.12/t/spec/S03-operators/lcm.t0000664000175000017500000000250412224265625017330 0ustar  moritzmoritzuse v6;
use Test;
plan 15;

# L

=begin pod

Basic tests for the lcm operator

=end pod

is 10 lcm 5, 10, "The lcm of 10 and 5 is 10";
isa_ok 10 lcm 5, Int, "The lcm of 10 and 5 is an Int";
is -432 lcm 63, 3024, "The lcm of -432 and 63 is 3024";
is 4342 lcm 65536, 142278656, "The lcm of 4342 and 65536 is 142278656";
isa_ok 4342 lcm 65536, Int, "The lcm of 4342 and 65536 is an Int";

is ([lcm] 1..3), 6, '[lcm] Range works';

{
    is 10.1 lcm 5.3, 10, "lcm converts Rats to Ints correctly";
    isa_ok 10.1 lcm 5.3, Int, "and the result is an Int";
    is 10.1e0 lcm 5.3e0, 10, "lcm converts Nums to Ints correctly";
    isa_ok 10.1e0 lcm 5.3e0, Int, "and the result is an Int";
}

{
    is 123123123123123123123123123 lcm 3, 123123123123123123123123123, "lcm handles big Int and small Int";
    is 123123123123123123123123123 lcm 2, 246246246246246246246246246, "lcm handles big Int and small Int";
    is 3 lcm 123123123123123123123123123, 123123123123123123123123123, "lcm handles small Int and big Int";
    is 7 lcm 123123123123123123123123123, 861861861861861861861861861, "lcm handles small Int and big Int";
    is 123123123123123123123123123123 lcm 123123123123123123123123123, 
       123246369492615738861985108107984861738615492369246123, "lcm handles big Int and big Int";
}

done;
# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/list-quote-junction.t0000664000175000017500000000241512224265625022513 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

= DESCRIPTION

Tests that the C and list quoting constructs
play well together and match well.

The following should match:

  "foo" ~~ any 
  "foo" ~~ any()
  "bar" ~~ any 
  "bar" ~~ any()

The following should not match:

  "fo"      ~~ any 
  "oo"      ~~ any 
  "bar b"   ~~ any 
  "bar baz" ~~ any()

Note: There is a small caveat regarding the convenient
C<< any  >> syntax, if not used with parentheses:

  say( any ,"Hello World")

is different from

  say( (any ), "Hello World")

=end kwid

# L

my @matching_strings = ;
my @nonmatching_strings = ('fo','foo ', 'foo bar baz', 'oo', 'bar b', 'bar baz');

plan 16;

for @matching_strings -> $str {
  ok( $str ~~ (any ), "'$str' matches any " );
  ok( $str ~~ any(), "'$str' matches any()" );
};

for @nonmatching_strings -> $str {
  ok( ($str !~~ any ), "'$str' does not match any " );
  ok( $str !~~ any(), "'$str' does not match any()" );
};

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/minmax.t0000664000175000017500000000514412224265625020051 0ustar  moritzmoritzuse v6;

use Test;

plan 25;

# L
# L
# L >>, the minmax operator">

=begin description

This test min/max functions in their operator form. To see them tested in their other forms, see C

=end description

#General min/max tests
{    
    is 1 min 2, 1, 'can ye handle that?';
    is 1 max 2, 2, 'how about this?';
    is 1 min 2 min 3, 1, 'ooh! 3 numbers! More difficult';
    is 1 max 2 max 3, 3, 'again! 3 numbers!';
    #?rakudo 2 todo "max/min non-associative NYI"
    eval_dies_ok q{1 min 2 max 3}, 'No! No left-associativeness!';
    eval_dies_ok q{1 max 2 min 3}, 'This is also not OK';
    is "alpha" min "beta", "alpha", 'min works for strings, too';
    is "alpha" max "beta", "beta", 'max works for strings, too';
}

{
    is "foo" min +Inf, "foo";
    is "foo" min -Inf, -Inf;
    is "foo" max +Inf, +Inf;
    is "foo" max -Inf, "foo";
}

#testing the minmax operator
{
    my @a = 1,2,3,4;
    my @b = 9,8,7,1;
    is((@a minmax @b), 1..9, "minmax works on two arrays");
    is((1,2 minmax 9,8), 1..9, "minmax works on two lists");
    is((1,8 minmax 4,5), 1..8, 'minmax works when both are on left list');
    is((4,5 minmax 1,8), 1..8, 'minmax works when both are on right list');
    @a = 1,8,2,9;
    @b = 4,7,5,6;
    is((@a minmax @b), 1..9, 'minmax works when both are on left array');
    is((@b minmax @a), 1..9, 'minmax works when both are on right array');
}

{
    my @a = ;
    my @b = ;
    is (@a minmax @b).perl, ("Barleycorn!".."us").perl, 'minmax works for strings, too';
}

#array vs. scalar
#?rakudo todo "Annoying test that we haven't done the obvious yet unspecced, fails because we have indeed done the obvious"
#?niecza todo
{
    #NYS- Not Yet Specced. C'd only so those sneaky programmers can't get away with coding
    #what `makes sense' and `probably will be anyway' :) --lue
    my @a = 1, 2, 3;
    isnt @a min 4, 1, 'NYS';
    isnt @a max 4, 4, 'NYS';
}

# RT #61836
# RT #77868
{
    # I am very suspicious of the following tests.  As I understand it, cmp can compare 
    # Reals, and cmp can compare two objects of the same type.  Otherwise it is only 
    # required to be consistent, not to have a particular result. --colomon

    #?niecza todo
    is 2 min Any, 2, '2 min Any';
    #?niecza todo
    is Any min 2, 2, 'Any min 2';
    is 2 max Any, 2, '2 max Any';
    #?niecza todo
    is Any max 2, 2, 'Any max 2';
}
rakudo-2013.12/t/spec/S03-operators/misc.t0000664000175000017500000000576512224265625017524 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

Tests for Synopsis 3
=end kwid

plan 33;

my $str1 = "foo";
my $str2 = "bar";
my $str3 = "foobar";
my $str4 = $str1~$str2;

# L
is($str3, $str4, "~");

# L
my $bar = "";
($str3 eq $str4) ?? ($bar = 1) !! ($bar = 0);

ok($bar, "?? !!");

# L
my $five = 5;
my $four = 4;
my $wibble = 4;

ok(!($five == $four), "== (false)");
ok($wibble == $four, "== (true)");
ok(!($wibble != $four), "== (false)");
ok($five != $four, "!= (true)");

ok($five == 5, "== (const on rhs)");
ok(!($five != 5), "!= (const on rhs)");

ok(5 == $five, "== (const on lhs)");
ok(!(5 != $five), "!= (const on lhs)");

ok($five == (2 + 3), "== (sum on rhs)");
ok(!($five != (2 + 3)), "== (sum on rhs)");

is(2 + 3, $five, "== (sum on lhs)");
ok((2 + 3) == 5, "== (sum on lhs)");
ok(!((2 + 3) != $five), "== (sum on lhs)");

# L
is("text " ~ "stitching", "text stitching", 'concatenation with ~ operator');

# Bit Stitching

# L
is(2 || 3, 2, "|| returns first true value");
ok(!(defined( 0 || Mu)), "|| returns last false value of list?");

{
    (my @s)[0] //= 5;
    is @s[0], 5, '(my @s)[0] //= something works';
    (state @t)[0] //= 5;
    is @t[0], 5, '(state @t)[0] //= something works';
}

is(2 ?| 3, True, "boolean or (?|) returns True or False");
is(0 ?| Any, False, "boolean or (?|) returns True or False");

# L
#?pugs skip 'autothread'
ok(?((all((4|5|6) + 3) == one(7|8|9))), "all elements in junction are incremented");
#?pugs skip 'autothread'
ok(?((any(1..6) == one(1|2|3|4|5|6))), "any elements will match via junction");

#?pugs skip 'autothread'
{
    ok( ?(7 > any(4..12)), "any test against scalar" );

    my @oldval  = (5, 8, 12);

    my @newval1 = (17, 15, 14); # all greater
    my @newval2 = (15, 7,  20); # some less some greater
    my @newval3 = (3, 1, 4);    # all less
    my @newval4 = (1,2,40);

    ok( ?(any(@newval4) > any(@oldval)), "any test array against any array" );
    ok( ?(any(@newval4) > all(@oldval)), "any test array against all array" );
    ok( ?(all(@newval2) > any(@oldval)), "all test array against any array" );
    ok( ?(all(@newval1) > all(@oldval)), "all test array against all array" );

    ok(?(42 > 12 & 20 & 32), "test the all infix operator");
}

# L
{
    my @rv;
    @rv = (1,2,3,4) >>+<< (1,2,3,4);
    is(~@rv, "2 4 6 8", 'hyper-add');
}

# L
#?rakudo todo "nom regression"
#?niecza todo
#?pugs todo
{
    is (1, 2, * Z ).join('|'),
       '1|a|2|b|2|c|2|d',
       'A * as the last value extends lists for infix: (zip)';
}

# L
#for RT #73836
my @z=2,3;
is (2 Z 3), @z, 'joining of single items';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/names.t0000664000175000017500000000103212237474612017655 0ustar  moritzmoritzuse v6;
use Test;
plan 7;

is &infix:<+>(3, 8), 11, 'Can refer to &infix:<+>';
is  infix:<+>(3, 8), 11, 'Can refer to  infix:<+>';

is &infix:<->(3, 8), -5, 'Can refer to &infix:<->';
is  infix:<->(3, 8), -5, 'Can refer to  infix:<->';

#?pugs skip 'Order::Less'
is &infix:(3, 4), Order::Less, 'Can refer to &infix:';

#?niecza todo
#?pugs 2 skip 'no compatiable multi ok'
ok ~&infix:<+> ~~ /infix/, 'String value of &infix:<+> contains "infix"';
#?niecza todo
ok ~&infix:<+> ~~ /\+/, 'String value of &infix:<+> contains "+"';
rakudo-2013.12/t/spec/S03-operators/nesting.t0000664000175000017500000000373412224265625020232 0ustar  moritzmoritzuse v6;
use Test;

plan 26;

# L

#?niecza skip 'undeclared name [+]'
ok &infix:<+>  === &[+],  'long and short form are the same (+)';
#?niecza skip 'undeclared name [==]'
ok &infix:<==> === &[==], 'long and short form are the same (==)';
#?niecza skip 'undeclared name [<=>]'
is sort( &[<=>], <5 3 2 1 4> ), <1 2 3 4 5>, 'sort works using &[<=>]';

#?niecza skip 'undeclared name [+]'
is &[+](1, 2), 3, '&[+] as a function';
is 1 [+] 2, 3, '[+] as an infix';   #OK Useless

# test nesting with Rop -- tests stolen from reverse.t and nested in various ways

is 4 R[+] 5, 5 + 4, "4 R[+] 5";
isa_ok 4 R[+] 5, (5 + 4).WHAT, "4 R[+] 5 is the same type as 5 + 4";
is 4 [R-] 5, 5 - 4, "4 [R-] 5";
isa_ok 4 [R-] 5, (5 - 4).WHAT, "4 [R-] 5 is the same type as 5 - 4";
is 4 [R*] 5, 5 * 4, "4 [R*] 5";
isa_ok 4 [R*] 5, (5 * 4).WHAT, "4 [R*] 5 is the same type as 5 * 4";
is 4 R[/] 5, 5 / 4, "4 R[/] 5";
isa_ok 4 R[/] 5, (5 / 4).WHAT, "4 R[/] 5 is the same type as 5 / 4";

is 4 R[cmp] 5, 5 cmp 4, "4 R[cmp] 5";
isa_ok 4 R[cmp] 5, (5 cmp 4).WHAT, "4 R[cmp] 5 is the same type as 5 cmp 4";

is 3 R[/] 9 + 5, 8, 'R[/] gets precedence of /';
is 4 R[-] 5 [R/] 10, -2, "Rop gets the precedence of op";
is (9 R[...] 1, 3), (1, 3, 5, 7, 9), "Rop gets list_infix precedence correctly";

# test nesting with zip -- tests stolen from zip.t and nested

is ( Z[~] <1 2>), , 'zip-concat produces expected result';
is (1,2 [Z*] 3,4), (3,8), 'zip-product works';
is (1,2 [Z[cmp]] 3,2,0).map(*.sign), (-1, 0), 'zip-cmp works';

# reduce

is ([[+]] 1, 20, 300, 4000), 4321, "[[+]] works";
is ([R[+]] 1, 20, 300, 4000), 4321, "[R[+]] works";

# deeper nesting

is (1 R[R[R-]] 2), 1, 'R[R[R-]] works';
is (1 RR[R-] 2),   1, 'RR[R-] works';

# crazy stuff
{
    our sub infix:($a, $b) { 
        $a % $b 
    }
    is 1031 [blue] 4, 3, "1031 [blue] 4 == 3";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/not.t0000664000175000017500000000242112224265625017353 0ustar  moritzmoritzuse v6;
use Test;
plan 22;

# L

nok(not 1,     "not 1 is false");
nok(not -1,    "not -1 is false");
nok(!(not 0),  "!not 0 is false");
nok(not sub{}, 'not sub{} is false');
nok(not "x",   'not "x" is false');

my $a = 1; nok(not $a,    'not $not_var is false');
my $b = 0; nok(!(not $b), 'not $false_var is not false');

#?rakudo todo 'RT 65556'
is (not($b) + 1), ((not $b) + 1), 'not($b) is (not $b)';

ok( not(not 42), "not(not 42) is true");
ok(!not(not  0), "not(not  0) is false");

is(not Bool::True, Bool::False, "'Bool::True' is not 'Bool::False'");
isa_ok(not Bool::True, Bool,    "'not Bool::True' is a Bool");
is(not Bool::True, False,       "'Bool::True' is not 'False'");
is(not True, False,             "'True' is not 'False'");
isa_ok(not True, Bool,          "'not True' is a Bool");
is(not True, Bool::False,       "'True' is not 'Bool::False'");

is(not Bool::False, Bool::True, "'Bool::False' is not 'Bool::True'");
isa_ok(not Bool::False, Bool,   "'not Bool::False' is a Bool");
is(not Bool::False, True,       "'Bool::False' is not 'True'");
is(not False, True,             "'False' is not 'True'");
isa_ok(not False, Bool,         "'not False' is a Bool");
is(not False, Bool::True,       "'False' is not 'Bool::True'");

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/numeric-shift.t0000664000175000017500000000136212224265625021333 0ustar  moritzmoritzuse v6;
use Test;

plan 36;

sub check ($a, $b, $ls, $rs) {
    is $a * 2**$b, $ls, "expected value for shl $a by $b is sane";

    # assume two's complement semantics for negative $a
    is floor($a / 2**$b), $rs, "expected value for shr $a by $b is sane";

    is $a +<  $b, $ls, "got expected value for shl $a by $b";

    #?niecza skip 'shift by negative bit count'
    is $a +< -$b, $rs, "got expected value for shl $a by -$b";

    is $a +>  $b, $rs, "got expected value for shr $a by $b";

    #?niecza skip 'shift by negative bit count'
    is $a +> -$b, $ls, "got expected value for shr $a by -$b";
}

check 15, 3, 120, 1;
check 16, 3, 128, 2;
check 17, 3, 136, 2;

check -15, 3, -120, -2;
check -16, 3, -128, -2;
check -17, 3, -136, -3;

done;
rakudo-2013.12/t/spec/S03-operators/overflow.t0000664000175000017500000002001412224265625020414 0ustar  moritzmoritzuse v6;

use Test;

plan 98;

#L

=begin description

Mostly copied from Perl 5.8.4 s t/op/inc.t

Verify that addition/subtraction properly handle "overflow"
conditions on common architectures.  The current tests are
significant on machines with 32-bit longs, but should not
fail anywhere.

=end description

my $a = 2147483647;
my $c=$a++;
is($a, 2147483648, "var incremented after post-autoincrement");
is($c, 2147483647, "during post-autoincrement return value is not yet incremented");

$a = 2147483647;
$c=++$a;
is($a, 2147483648, "var incremented  after pre-autoincrement");
is($c, 2147483648, "during pre-autoincrement return value is incremented");

$a = 2147483647;
$a=$a+1;
is($a, 2147483648, 'simple assignment: $a = $a+1');

$a = -2147483648;
$c=$a--;
is($a, -2147483649, "var decremented after post-autodecrement");
is($c, -2147483648, "during post-autodecrement return value is not yet decremented");

$a = -2147483648;
$c=--$a;
is($a, -2147483649, "var decremented  after pre-autodecrement");
is($c, -2147483649, "during pre-autodecrement return value is decremented");

$a = -2147483648;
$a=$a-1;
is($a, -2147483649, 'simple assignment: $a = $a-1');

$a = 2147483648;
$a = -$a;
$c=$a--;
is($a, -2147483649, "post-decrement negative value");

$a = 2147483648;
$a = -$a;
$c=--$a;
is($a, -2147483649, "pre-decrement negative value");

$a = 2147483648;
$a = -$a;
$a=$a-1;
is($a, -2147483649, 'assign $a = -$a; $a = $a-1');

$a = 2147483648;
my $b = -$a;
$c=$b--;

is($b, ((-$a)-1), "compare -- to -1 op with same origin var");
is($a, 2147483648, "make sure origin var remains unchanged");

$a = 2147483648;
$b = -$a;
$c=--$b;
is($b, ((-$a)-1), "same thing with predecremenet");

$a = 2147483648;
$b = -$a;
$b= $b - 1;
is($b, -(++$a), 'test oder of predecrement in -(++$a)');

{
    is(0x80000000 div 1, 0x80000000, "0x80000000 div 1 == 0x80000000");
    is(0x80000000 div -1, -0x80000000, "0x80000000 div -1 == -0x80000000");
    is(-0x80000000 div 1, -0x80000000, "-0x80000000 div 1 == -0x80000000");
    is(-0x80000000 div -1, 0x80000000, "-0x80000000 div -1 == 0x80000000");
    is 18446744073709551616 div 1, 18446744073709551616;
    is 18446744073709551616 div 2, 9223372036854775808, "Bignums are not working yet";
    is 18446744073709551616 div 4294967296, 4294967296, "Bignums are not working yet";
    ok 18446744073709551616 div 9223372036854775808 == 2, '$bignum1 div $bignum2';
}

# UVs should behave properly
{
    is 4063328477 % 65535, 27407;
    is 4063328477 % 4063328476, 1;
    is 4063328477 % 2031664238, 1;
    
    is 2031664238 % 4063328477, 2031664238;

    # These should trigger wrapping on 32 bit IVs and UVs

    is 2147483647 + 0, 2147483647;

    # IV + IV promote to UV
    is 2147483647 + 1, 2147483648;
    is 2147483640 + 10, 2147483650;
    is 2147483647 + 2147483647, 4294967294;
    # IV + UV promote to NV
    is 2147483647 + 2147483649, 4294967296;
    # UV + IV promote to NV
    is 4294967294 + 2, 4294967296;
    # UV + UV promote to NV
    is 4294967295 + 4294967295, 8589934590;

    # UV + IV to IV
    is 2147483648 + -1, 2147483647;
    is 2147483650 + -10, 2147483640;
    # IV + UV to IV
    is -1 + 2147483648, 2147483647;
    is -10 + 4294967294, 4294967284;
    # IV + IV to NV
    is -2147483648 + -2147483648, -4294967296;
    is -2147483640 + -10, -2147483650;
}

#?DOES 1
sub tryeq_sloppy ($lhs, $rhs, $todo1 = '') {
    my $todo = $todo1;  # TODO is rw
    $todo = ' # TODO ' ~ $todo if $todo;
    if ($lhs == $rhs) {
        if ($todo) {
            #&ok.nextwith($lhs==$rhs,$todo, :todo);
            ok($lhs==$rhs,$todo, :todo);
        } else {
            #&ok.nextwith($lhs==$rhs,$todo);
            ok($lhs==$rhs,$todo);
        }
    } else {
        my $error = abs($lhs - $rhs);
        $error   /= $lhs; # Syntax highlighting fix
        if ($todo) {
            #&ok.nextwith($error <1e-9,$todo ~ " # " ~ $lhs ~ " is close to " ~ $rhs, :todo);
            ok($error < 1e-9, $todo ~ " # " ~ $lhs ~ " is close to " ~ $rhs, :todo);
        } else {
            #&ok.nextwith($error <1e-9);
            ok($error < 1e-9);
        }
    }
}

{
    is 2147483648 - 0, 2147483648, '2147483648 - 0 == 2147483648';
    is -2147483648 - 0, -2147483648, '-2147483648 - 0 == -2147483648';
    is 2000000000 - 4000000000, -2000000000, '2000000000 - 4000000000 == -2000000000';
}

# Believe it or not, this one overflows on 32-bit Rakduo as of 3/8/2010.
{
    # RT #73262
    is_approx 7**(-1), 0.14285714285714, '7**(-1) works';
}

{
    # The peephole optimiser is wrong to think that it can substitute intops
    # in place of regular ops, because i_multiply can overflow.
    # (Perl 5) Bug reported by "Sisyphus" (kalinabears@hdc.com.au)
    my $n = 1127;
    my $float = ($n % 1000) * 167772160.0;
    tryeq_sloppy $float, 21307064320;
  
    # On a 32 bit machine, if the i_multiply op is used, you will probably get
    # -167772160. It's actually undefined behaviour, so anything may happen.
    my $int = ($n % 1000) * 167772160;
    is $int, 21307064320, '(1127 % 1000) * 167772160 == 21307064320';

}

{
    is -1 - -2147483648, 2147483647, '-1 - -2147483648 == 2147483647';
    is 2 - -2147483648, 2147483650, '2 - -2147483648 == 2147483650';

    is 4294967294 - 3, 4294967291, '4294967294 - 3 == 4294967291';
    is -2147483648 - -1, -2147483647, '-2147483648 - -1 == -2147483647';

    # IV - IV promote to UV
    is 2147483647 - -1, 2147483648, '2147483647 - -1 == 2147483648';
    is 2147483647 - -2147483648, 4294967295, '2147483647 - -2147483648 == 4294967295';
    # UV - IV promote to NV
    is 4294967294 - -3, 4294967297, '4294967294 - -3 == 4294967297';
    # IV - IV promote to NV
    is -2147483648 - +1, -2147483649, '-2147483648 - +1 == -2147483649';
    # UV - UV promote to IV
    is 2147483648 - 2147483650, -2, '2147483648 - 2147483650 == -2';
}

# check with 0xFFFF and 0xFFFF
{
    is 65535 * 65535, 4294836225;
    is 65535 * -65535, -4294836225;
    is -65535 * 65535, -4294836225;
    is -65535 * -65535, 4294836225;

    # check with 0xFFFF and 0x10001
    is 65535 * 65537, 4294967295;
    is 65535 * -65537, -4294967295;
    is -65535 * 65537, -4294967295;
    is -65535 * -65537, 4294967295;
    
    # check with 0x10001 and 0xFFFF
    is 65537 * 65535, 4294967295;
    is 65537 * -65535, -4294967295;
    is -65537 * 65535, -4294967295;
    is -65537 * -65535, 4294967295;
    
    # These should all be dones as NVs
    is 65537 * 65537, 4295098369;
    is 65537 * -65537, -4295098369;
    is -65537 * 65537, -4295098369;
    is -65537 * -65537, 4295098369;
    
    # will overflow an IV (in 32-bit)
    is 46340 * 46342, 0x80001218;
    is 46340 * -46342, -0x80001218;
    is -46340 * 46342, -0x80001218;
    is -46340 * -46342, 0x80001218;
    
    is 46342 * 46340, 0x80001218;
    is 46342 * -46340, -0x80001218;
    is -46342 * 46340, -0x80001218;
    is -46342 * -46340, 0x80001218;
    
    # will overflow a positive IV (in 32-bit)
    is 65536 * 32768, 0x80000000;
    is 65536 * -32768, -0x80000000;
    is -65536 * 32768, -0x80000000;
    is -65536 * -32768, 0x80000000;
    
    is 32768 * 65536, 0x80000000;
    is 32768 * -65536, -0x80000000;
    is -32768 * 65536, -0x80000000;
    is -32768 * -65536, 0x80000000;
}

#overflow tests from radix.t
{
    # some random made up hex strings (these values are checked against perl5)
    is :16("FFACD5FE"), 4289517054, 'got the correct int value from hex FFACD5FE';
    is :16("AAA4872D"), 2862909229, 'got the correct int value from hex AAA4872D';
    is :16,  0xDEADBEEF, 'got the correct int value from hex DEAD_BEEF';

    is(:8<37777777777>, 0xffff_ffff, 'got the correct int value from oct 3777777777');
    is +":16", 0xDEADBEEF, "radix 16 notation works";
    is +":16", 0xDEADBEEF + 0xFACE / 65536.0, "fractional base 16 works";
    
    is( :2<1.1> * 10 ** 10,        15_000_000_000, 'binary number to power of 10' );
    is( :2<1.1*10**10>,        15_000_000_000, 'Power of ten in <> works');
    
}

# RT #77016
{
    ok 1 / 10000000000000000000000000000000 < 1/1000,
        'can construct Rat (or similar) with big denominator';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/precedence.t0000664000175000017500000001277212224265625020662 0ustar  moritzmoritzuse v6;

use Test;

# L

=begin pod

Tests that each level bind tighter than the next by sampling some ops.

In between each precedence level are some tests that demonstrate the
proper separation of the two levels.

=end pod

plan 53;


# terms

# FIXME how do we test this?

# postfix method

my @a = 1,2,3;
is(++@a[2], 4, "bare postfix binds tighter than ++");
is(++@a.[2], 5, "dotted postfix binds tighter than ++");

# autoincrement

my $i = 2;
is(++$i ** 2, 9, "++ bind tighter than **");
is(--$i ** 2, 4, "-- does too");

# exponentiation

is(-2**2, -4, "** bind tighter than unary -");
isa_ok(~2**4, Str, "~4**4 is a string");

# symbolic unary

is(!0 * 2, 2, "unary ! binds tighter than *");
ok(!(0 * 2), "beh");
is(?2*2, 2, "binary -> numify causes reinterpretation as, binds tighter than *");

# multiplicative

is(4 + 3 * 2, 10, "* binds tighter than binary +");
#?pugs skip 'div'
is(2 - 2 div 2, 1, "div binds tighter than binary -");
is(2 - 2 / 2, 1 / 1, "/ binds tighter than binary -");

# additive

is(1 ~ 2 * 3, 16, "~ binds looser than *");
ok(?((1 ~ 2 & 12) == 12), "but tighter than &");
#?pugs skip 'autothread'
ok(?((2 + 2 | 4 - 1) == 4), "and + binds tighter than |");

# replication

is(2 x 2 + 3, "22222", "x binds looser than binary +");
is((2 x 2) + 3, 25, "doublecheck");

# concatenation

is(2 x 2 ~ 3, "223", "x binds tighter than binary ~");
#?pugs skip 'autothread'
ok(?((2 ~ 2 | 4 ~ 1) == 41), "and ~ binds tighter than |");

# junctive and

#?pugs 4 skip 'autothread'
ok(  ?(   (1 & 2 | 3) ==3), '& binds tighter than |');
ok((!(1 & 2 | 3) < 2), "ditto");
ok(?((1 & 2 ^ 3) < 3), "and also ^");
ok(?(!(1 & 2 ^ 4) != 3), "blah blah blah");

# junctive or

#?rakudo todo 'non-associativeness of infix:<^> and |'
#?pugs todo 'autothread, Mu'
{ # test that | and ^ are on the same level but parsefail
    eval_dies_ok 'my Mu $a = (1 | 2 ^ 3)', '| and ^ may not associate';
    eval_dies_ok 'my Mu $a = (1 ^ 2 | 3)', '^ and | may not associate';
};


#?pugs skip 'Mu'
{
    my Mu $b = ((abs -1) ^ -1); # -> (1 ^ -1)
    ok($b == 1, "this is true because only one is == 1");
};

# named unary


ok(0 < 2 <=> 1 < 2, "0 < 2 <=> 1 < 2 means 0 < 1 < 2");

# chaining

is((0 != 1 && "foo"), "foo", "!= binds tighter than &&");
ok((0 || 1 == (2-1) == (0+1) || "foo") ne "foo", "== binds tighter than || also when chaning");

# tight and (&&)

# tight or (||, ^^, //)

is((1 && 0 ?? 2 !! 3), 3, "&& binds tighter than ??");
### FIXME - need also ||, otherwise we don't prove || and ?? are diff

# conditional

{
    my $a = 0 ?? "yes" !! "no";
    is($a, "no", "??!! binds tighter than =");
#    (my $b = 1) ?? "true" !! "false";
#    is($b, 1, "?? !! just thrown away with = in parens");
};


# item assignment

# XXX this should be a todo, not a skip, but that
# messes up the rest of the file, somehow :(
{
    my $c = 1, 2, 3;
    is($c, 1, '$ = binds tighter than ,');
    my $a = (1, 3) X (2, 4);
    is($a, [1, 3], "= binds tighter than X");
}

# loose unary

my $x;
#?pugs skip 'wrong precedence'
is((so $x = 42), True, "item assignment is tighter than true");

# comma

is(((not 1,42)[1]), 42, "not is tighter than comma");

# list infix

{
    my @d;
    ok (@d = 1,3 Z 2,4), "list infix tighter than list assignment, looser t than comma";
    #?pugs todo 'list infix and assignment'
    is(@d, [1 .. 4], "to complicate things further, it dwims");
}

{
    my @b;
    @b = ((1, 3) Z (2, 4));
    is(@b, [1 .. 4], "parens work around this");
};

#?rakudo todo 'RT #77848'
eval_dies_ok('4 X+> 1...2', 'X+> must not associate with ...');

# list prefix

#?pugs todo 'authothread'
{
    my $c = any 1, 2 Z 3, 4;
    ok($c == 3, "any is less tight than comma and Z");
}

my @c = 1, 2, 3;
is(@c, [1,2,3], "@ = binds looser than ,");

# loose and

{
    my $run = 1;
    sub isfive (*@args) {
        is(@args[0], 5, "First arg is 5, run " ~ $run++);
        1;
    }

    # these are two tests per line, actually
    # we should have a better way that doesn't just result in 
    # a wrong plan if gone wrong.
    isfive(5) and isfive(5);
    isfive 5  and isfive 5;
}

# loose or

# terminator

# Contrary to Perl 5 there are no prototypes, and since normal built-ins
# are not defined as prefix ops, 'uc $a eq $A' actually parses as
# uc($a eq $A), not uc($a) eq $A.
# http://irclog.perlgeek.de/perl6/2009-07-14#i_1316200
#
# so uc(False) stringifies False to 'FALSE', and uc('0') is false. Phew.
#?pugs todo 'Bool.Str'
is (uc "a" eq "A"), uc(False.Str), "uc has the correct precedence in comparison to eq";

# L
#?pugs todo
eval_dies_ok 'int 4.5', 'there is no more prefix:';


# http://irclog.perlgeek.de/perl6/2009-07-14#i_1315249
ok ((1 => 2 => 3).key  !~~ Pair), '=> is right-assoc (1)';
ok ((1 => 2 => 3).value ~~ Pair), '=> is right-assoc (2)';


# L

#?rakudo todo 'list associativity bug'
#?pugs todo
eval_dies_ok '1, 2 Z 3, 4 X 5, 6',
    'list associativity only works between identical operators';

#?rakudo skip 'nom regression'
#?niecza skip 'assigning to readonly value'
#?pugs todo
{
    # Check a 3 != 3 vs 3 !=3 parsing issue that can cropped up in Rakudo.
    # Needs careful following of STD to get it right. :-)
    my $r;
    sub foo($x) { $r = $x }
    foo 3 != 3;
    is($r, False, 'sanity 3 != 3');
    foo 3 !=3;
    is($r, False, 'ensure 3 !=3 gives same result as 3 != 3');
}

# RT 73266
{
    try { eval 'say and die 73266' };
    ok ~$! !~~ '73266', 'and after say is not interpreted as infix:';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/range-basic.t0000664000175000017500000001651312224265625020735 0ustar  moritzmoritzuse v6;

use Test;
BEGIN { @*INC.push('t/spec/packages') };
use Test::Util;

plan 144;

{
    my $range = 2..6;
    isa_ok $range, Range, '2..6 is a Range';
    is $range.min, 2, "2..6.min is 2";
    is $range.max, 6, "2..6.max is 6";
    is $range.excludes_min, Bool::False, "2..6.excludes_min is false";
    is $range.excludes_max, Bool::False, "2..6.excludes_max is false";
    is $range.perl, "2..6", '.perl is correct';
}

{
    my $range = -1^..7;
    isa_ok $range, Range, '-1^..7 is a Range';
    is $range.min, -1, "-1^..7.min is -1";
    is $range.max, 7, "-1^..7.max is 7";
    is $range.excludes_min, Bool::True, "-1^..7.excludes_min is true";
    is $range.excludes_max, Bool::False, "-1^..7.excludes_max is false";
    is $range.perl, "-1^..7", '.perl is correct';
}

{
    my $range = 3..^-1;
    isa_ok $range, Range, '3..^-1 is a Range';
    is $range.min, 3, "3..^-1.min is 3";
    is $range.max, -1, "3..^-1.max is -1";
    is $range.excludes_min, Bool::False, "3..^-1.excludes_min is false";
    is $range.excludes_max, Bool::True, "3..^-1.excludes_max is true";
    is $range.perl, "3..^-1", '.perl is correct';
}

{
    my $range = 'a'^..^'g';
    isa_ok $range, Range, "'a'^..^'g' is a Range";
    is $range.min, 'a', "'a'^..^'g'.min is 'a'";
    is $range.max, 'g', "'a'^..^'g'.max is 'g'";
    is $range.excludes_min, Bool::True, "'a'^..^'g'.excludes_min is true";
    is $range.excludes_max, Bool::True, "'a'^..^'g'.excludes_max is true";
    is $range.perl, '"a"^..^"g"', '.perl is correct';
}

{
    my $range = ^5;
    isa_ok $range, Range, '^5 is a Range';
    is $range.min, 0, "^5.min is 0";
    is $range.max, 5, "^5.max is 5";
    is $range.excludes_min, Bool::False, "^5.excludes_min is false";
    is $range.excludes_max, Bool::True, "^5.excludes_max is true";
    is $range.perl, "0..^5", '.perl is correct';
}

{
    my $range = ^5.5;
    isa_ok $range, Range, '^5.5 is a Range';
    is $range.min, 0, "^5.5.min is 0";
    is $range.max, 5.5, "^5.5.max is 5.5";
    is $range.excludes_min, Bool::False, "^5.5.excludes_min is false";
    is $range.excludes_max, Bool::True, "^5.5.excludes_max is true";
}

{
    my $range = ^5.5e0;
    isa_ok $range, Range, '^5.5e0 is a Range';
    is $range.min, 0, "^5.5e0.min is 0";
    is $range.max, 5.5e0, "^5.5e0.max is 5.5e0";
    is $range.excludes_min, Bool::False, "^5.5e0.excludes_min is false";
    is $range.excludes_max, Bool::True, "^5.5e0.excludes_max is true";
}

{
    my $range = 1..*;
    isa_ok $range, Range, '1..* is a Range';
    is $range.min, 1, "1..*.min is 1";
    is $range.max, Inf, "1..*.max is Inf";
    is $range.excludes_min, Bool::False, "1..*.excludes_min is false";
    is $range.excludes_max, Bool::False, "1..*.excludes_max is false";
}

# next three blocks of tests may seem kind of redundant, but actually check that 
# the various Range operators are not mistakenly turned into Whatever
# closures.

{
    my $range = 1^..*;
    isa_ok $range, Range, '1^..* is a Range';
    is $range.min, 1, "1^..*.min is 1";
    is $range.max, Inf, "1^..*.max is Inf";
    is $range.excludes_min, Bool::True, "1^..*.excludes_min is true";
    is $range.excludes_max, Bool::False, "1^..*.excludes_max is false";
}

{
    my $range = *..^1;
    isa_ok $range, Range, '*..^1 is a Range';
    is $range.min, -Inf, "*..^1.min is -Inf";
    is $range.max, 1, "*..^1.max is 1";
    is $range.excludes_min, Bool::False, "*..^1.excludes_min is false";
    is $range.excludes_max, Bool::True, "*..^1.excludes_max is true";
}

{
    my $range = 1^..^*;
    isa_ok $range, Range, '1^..^* is a Range';
    is $range.min, 1, "1^..^*.min is 1";
    is $range.max, Inf, "1^..^*.max is Inf";
    is $range.excludes_min, Bool::True, "1^..^*.excludes_min is true";
    is $range.excludes_max, Bool::True, "1^..^*.excludes_max is true";
}

# some range constructions are invalid
#?niecza skip "No exceptions"
#?DOES 8
{
    throws_like '10 .. ^20', X::Range::InvalidArg ;
    throws_like '^10 .. 20', X::Range::InvalidArg ;
    throws_like '* .. ^20',  X::Range::InvalidArg ;
    throws_like '^10 .. *',  X::Range::InvalidArg ;
}

ok 3 ~~ 1..5,         '3 ~~ 1..5';
ok 2.5 ~~ 1..5,       '2.5 ~~ 1..5';
ok 2.5e0 ~~ 1..5,     '2.5e0 ~~ 1..5';
ok 1 ~~ 1..5,         '1 ~~ 1..5';
ok 1.0 ~~ 1..5,       '1.0 ~~ 1..5';
ok 1.0e0 ~~ 1..5,     '1.0e0 ~~ 1..5';
ok 5 ~~ 1..5,         '5 ~~ 1..5';
ok 5.0 ~~ 1..5,       '5.0 ~~ 1..5';
ok 5.0e0 ~~ 1..5,     '5.0e0 ~~ 1..5';
nok 0 ~~ 1..5,        'not 0 ~~ 1..5';
nok 0.999 ~~ 1..5,    'not 0.999 ~~ 1..5';
nok 0.999e0 ~~ 1..5,  'not 0.999e0 ~~ 1..5';
nok 6 ~~ 1..5,        'not 6 ~~ 1..5';
nok 5.001 ~~ 1..5,    'not 5.001 ~~ 1..5';
nok 5.001e0 ~~ 1..5,  'not 5.001e0 ~~ 1..5';

ok 3 ~~ 1^..5,         '3 ~~ 1^..5';
ok 2.5 ~~ 1^..5,       '2.5 ~~ 1^..5';
ok 2.5e0 ~~ 1^..5,     '2.5e0 ~~ 1^..5';
nok 1 ~~ 1^..5,        'not 1 ~~ 1^..5';
nok 1.0 ~~ 1^..5,      'not 1.0 ~~ 1^..5';
nok 1.0e0 ~~ 1^..5,    'not 1.0e0 ~~ 1^..5';
ok 5 ~~ 1^..5,         '5 ~~ 1^..5';
ok 5.0 ~~ 1^..5,       '5.0 ~~ 1^..5';
ok 5.0e0 ~~ 1^..5,     '5.0e0 ~~ 1^..5';
nok 0 ~~ 1^..5,        'not 0 ~~ 1^..5';
nok 0.999 ~~ 1^..5,    'not 0.999 ~~ 1^..5';
nok 0.999e0 ~~ 1^..5,  'not 0.999e0 ~~ 1^..5';
nok 6 ~~ 1^..5,        'not 6 ~~ 1^..5';
nok 5.001 ~~ 1^..5,    'not 5.001 ~~ 1^..5';
nok 5.001e0 ~~ 1^..5,  'not 5.001e0 ~~ 1^..5';

ok 3 ~~ 1..^5,         '3 ~~ 1..^5';
ok 2.5 ~~ 1..^5,       '2.5 ~~ 1..^5';
ok 2.5e0 ~~ 1..^5,     '2.5e0 ~~ 1..^5';
ok 1 ~~ 1..^5,         '1 ~~ 1..^5';
ok 1.0 ~~ 1..^5,       '1.0 ~~ 1..^5';
ok 1.0e0 ~~ 1..^5,     '1.0e0 ~~ 1..^5';
nok 5 ~~ 1..^5,        'not 5 ~~ 1..^5';
nok 5.0 ~~ 1..^5,      'not 5.0 ~~ 1..^5';
nok 5.0e0 ~~ 1..^5,    'not 5.0e0 ~~ 1..^5';
nok 0 ~~ 1..^5,        'not 0 ~~ 1..^5';
nok 0.999 ~~ 1..^5,    'not 0.999 ~~ 1..^5';
nok 0.999e0 ~~ 1..^5,  'not 0.999e0 ~~ 1..^5';
nok 6 ~~ 1..^5,        'not 6 ~~ 1..^5';
nok 5.001 ~~ 1..^5,    'not 5.001 ~~ 1..^5';
nok 5.001e0 ~~ 1..^5,  'not 5.001e0 ~~ 1..^5';

ok 3 ~~ 1^..^5,         '3 ~~ 1^..^5';
ok 2.5 ~~ 1^..^5,       '2.5 ~~ 1^..^5';
ok 2.5e0 ~~ 1^..^5,     '2.5e0 ~~ 1^..^5';
nok 1 ~~ 1^..^5,        'not 1 ~~ 1^..^5';
nok 1.0 ~~ 1^..^5,      'not 1.0 ~~ 1^..^5';
nok 1.0e0 ~~ 1^..^5,    'not 1.0e0 ~~ 1^..^5';
nok 5 ~~ 1^..^5,        'not 5 ~~ 1^..^5';
nok 5.0 ~~ 1^..^5,      'not 5.0 ~~ 1^..^5';
nok 5.0e0 ~~ 1^..^5,    'not 5.0e0 ~~ 1^..^5';
nok 0 ~~ 1^..^5,        'not 0 ~~ 1^..^5';
nok 0.999 ~~ 1^..^5,    'not 0.999 ~~ 1^..^5';
nok 0.999e0 ~~ 1^..^5,  'not 0.999e0 ~~ 1^..^5';
nok 6 ~~ 1^..^5,        'not 6 ~~ 1^..^5';
nok 5.001 ~~ 1^..^5,    'not 5.001 ~~ 1^..^5';
nok 5.001e0 ~~ 1^..^5,  'not 5.001e0 ~~ 1^..^5';

# Tests which check to see if Range is properly doing numeric 
# comparisons for numbers.

ok 6 ~~ 5..21,          '6 ~~ 5..21';
ok 21 ~~ 3..50,         '21 ~~ 3..50';
nok 3 ~~ 11..50,        'not 3 ~~ 11..50';
nok 21 ~~ 1..5,         'not 21 ~~ 1..5';

ok 'c' ~~ 'b'..'g',     "'c' ~~ 'b'..'g'";
ok 'b' ~~ 'b'..'g',     "'b' ~~ 'b'..'g'";
ok 'g' ~~ 'b'..'g',     "'g' ~~ 'b'..'g'";
nok 'a' ~~ 'b'..'g',    "not 'a' ~~ 'b'..'g'";
nok 'h' ~~ 'b'..'g',    "not 'h' ~~ 'b'..'g'";
nok 0 ~~ 'a'..'g',      "not 0 ~~ 'a'..'g'";

ok 'd' ~~ 'c'..*,       "'d' ~~ 'c'..*";
nok 'b' ~~ 'c'..*,      "not 'b' ~~ 'c'..*";
ok 'b' ~~ *..'c',       "'b' ~~ *..'c'";
nok 'd' ~~ *..'c',      "not 'd' ~~ *..'c'";

# RT#75526: [BUG] Some non-alphanumeric ranges don't work
{
    ok ' ' ~~ ' '..' ', "' ' ~~ ' '..' '";
    ok ' ' ~~ ' '..'A', "' ' ~~ ' '..'A'";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/range-int.t0000664000175000017500000005446412224265625020455 0ustar  moritzmoritzuse v6;
use Test;
plan 480;

is ~(-17..-19), '', '-17..-19';
is ~(-17..^-19), '', '-17..^-19';
#?pugs skip 'empty list'
is ~(-17^..-19), '', '-17^..-19';
#?pugs skip 'empty list'
is ~(-17^..^-19), '', '-17^..^-19';
is ~(-17..-18), '', '-17..-18';
is ~(-17..^-18), '', '-17..^-18';
#?pugs skip 'empty list'
is ~(-17^..-18), '', '-17^..-18';
#?pugs skip 'empty list'
is ~(-17^..^-18), '', '-17^..^-18';
is ~(-17..-17), '-17', '-17..-17';
is ~(-17..^-17), '', '-17..^-17';
is ~(-17^..-17), '', '-17^..-17';
is ~(-17^..^-17), '', '-17^..^-17';
is ~(-17..-16), '-17 -16', '-17..-16';
is ~(-17..^-16), '-17', '-17..^-16';
is ~(-17^..-16), '-16', '-17^..-16';
is ~(-17^..^-16), '', '-17^..^-16';
is ~(-17..-15), '-17 -16 -15', '-17..-15';
is ~(-17..^-15), '-17 -16', '-17..^-15';
is ~(-17^..-15), '-16 -15', '-17^..-15';
is ~(-17^..^-15), '-16', '-17^..^-15';
is ~(-17..-14), '-17 -16 -15 -14', '-17..-14';
is ~(-17..^-14), '-17 -16 -15', '-17..^-14';
is ~(-17^..-14), '-16 -15 -14', '-17^..-14';
is ~(-17^..^-14), '-16 -15', '-17^..^-14';
is ~(-17..-13), '-17 -16 -15 -14 -13', '-17..-13';
is ~(-17..^-13), '-17 -16 -15 -14', '-17..^-13';
is ~(-17^..-13), '-16 -15 -14 -13', '-17^..-13';
is ~(-17^..^-13), '-16 -15 -14', '-17^..^-13';
is ~(-17..-12), '-17 -16 -15 -14 -13 -12', '-17..-12';
is ~(-17..^-12), '-17 -16 -15 -14 -13', '-17..^-12';
is ~(-17^..-12), '-16 -15 -14 -13 -12', '-17^..-12';
is ~(-17^..^-12), '-16 -15 -14 -13', '-17^..^-12';
is ~(-17..-11), '-17 -16 -15 -14 -13 -12 -11', '-17..-11';
is ~(-17..^-11), '-17 -16 -15 -14 -13 -12', '-17..^-11';
is ~(-17^..-11), '-16 -15 -14 -13 -12 -11', '-17^..-11';
is ~(-17^..^-11), '-16 -15 -14 -13 -12', '-17^..^-11';
is ~(-17..-10), '-17 -16 -15 -14 -13 -12 -11 -10', '-17..-10';
is ~(-17..^-10), '-17 -16 -15 -14 -13 -12 -11', '-17..^-10';
is ~(-17^..-10), '-16 -15 -14 -13 -12 -11 -10', '-17^..-10';
is ~(-17^..^-10), '-16 -15 -14 -13 -12 -11', '-17^..^-10';
is ~(-17..-9), '-17 -16 -15 -14 -13 -12 -11 -10 -9', '-17..-9';
is ~(-17..^-9), '-17 -16 -15 -14 -13 -12 -11 -10', '-17..^-9';
is ~(-17^..-9), '-16 -15 -14 -13 -12 -11 -10 -9', '-17^..-9';
is ~(-17^..^-9), '-16 -15 -14 -13 -12 -11 -10', '-17^..^-9';
is ~(-17..-8), '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8', '-17..-8';
is ~(-17..^-8), '-17 -16 -15 -14 -13 -12 -11 -10 -9', '-17..^-8';
is ~(-17^..-8), '-16 -15 -14 -13 -12 -11 -10 -9 -8', '-17^..-8';
is ~(-17^..^-8), '-16 -15 -14 -13 -12 -11 -10 -9', '-17^..^-8';
is ~(-17..-7), '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8 -7', '-17..-7';
is ~(-17..^-7), '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8', '-17..^-7';
is ~(-17^..-7), '-16 -15 -14 -13 -12 -11 -10 -9 -8 -7', '-17^..-7';
is ~(-17^..^-7), '-16 -15 -14 -13 -12 -11 -10 -9 -8', '-17^..^-7';
is ~(-17..0), '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0', '-17..0';
is ~(-17..^0), '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1', '-17..^0';
is ~(-17^..0), '-16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0', '-17^..0';
is ~(-17^..^0), '-16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1', '-17^..^0';
#?pugs skip 'hangs'
is ~(-17..Inf).list.[^20], '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2', '-17..Inf';
#?pugs skip 'hangs'
is ~(-17..^Inf).list.[^20], '-17 -16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2', '-17..^Inf';
#?pugs skip 'hangs'
is ~(-17^..Inf).list.[^20], '-16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3', '-17^..Inf';
#?pugs skip 'hangs'
is ~(-17^..^Inf).list.[^20], '-16 -15 -14 -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3', '-17^..^Inf';
is ~(-3..-5), '', '-3..-5';
is ~(-3..^-5), '', '-3..^-5';
#?pugs skip 'empty list'
is ~(-3^..-5), '', '-3^..-5';
#?pugs skip 'empty list'
is ~(-3^..^-5), '', '-3^..^-5';
is ~(-3..-4), '', '-3..-4';
is ~(-3..^-4), '', '-3..^-4';
#?pugs skip 'empty list'
is ~(-3^..-4), '', '-3^..-4';
#?pugs skip 'empty list'
is ~(-3^..^-4), '', '-3^..^-4';
is ~(-3..-3), '-3', '-3..-3';
is ~(-3..^-3), '', '-3..^-3';
is ~(-3^..-3), '', '-3^..-3';
is ~(-3^..^-3), '', '-3^..^-3';
is ~(-3..-2), '-3 -2', '-3..-2';
is ~(-3..^-2), '-3', '-3..^-2';
is ~(-3^..-2), '-2', '-3^..-2';
is ~(-3^..^-2), '', '-3^..^-2';
is ~(-3..-1), '-3 -2 -1', '-3..-1';
is ~(-3..^-1), '-3 -2', '-3..^-1';
is ~(-3^..-1), '-2 -1', '-3^..-1';
is ~(-3^..^-1), '-2', '-3^..^-1';
is ~(-3..0), '-3 -2 -1 0', '-3..0';
is ~(-3..^0), '-3 -2 -1', '-3..^0';
is ~(-3^..0), '-2 -1 0', '-3^..0';
is ~(-3^..^0), '-2 -1', '-3^..^0';
is ~(-3..1), '-3 -2 -1 0 1', '-3..1';
is ~(-3..^1), '-3 -2 -1 0', '-3..^1';
is ~(-3^..1), '-2 -1 0 1', '-3^..1';
is ~(-3^..^1), '-2 -1 0', '-3^..^1';
is ~(-3..2), '-3 -2 -1 0 1 2', '-3..2';
is ~(-3..^2), '-3 -2 -1 0 1', '-3..^2';
is ~(-3^..2), '-2 -1 0 1 2', '-3^..2';
is ~(-3^..^2), '-2 -1 0 1', '-3^..^2';
is ~(-3..3), '-3 -2 -1 0 1 2 3', '-3..3';
is ~(-3..^3), '-3 -2 -1 0 1 2', '-3..^3';
is ~(-3^..3), '-2 -1 0 1 2 3', '-3^..3';
is ~(-3^..^3), '-2 -1 0 1 2', '-3^..^3';
is ~(-3..4), '-3 -2 -1 0 1 2 3 4', '-3..4';
is ~(-3..^4), '-3 -2 -1 0 1 2 3', '-3..^4';
is ~(-3^..4), '-2 -1 0 1 2 3 4', '-3^..4';
is ~(-3^..^4), '-2 -1 0 1 2 3', '-3^..^4';
is ~(-3..5), '-3 -2 -1 0 1 2 3 4 5', '-3..5';
is ~(-3..^5), '-3 -2 -1 0 1 2 3 4', '-3..^5';
is ~(-3^..5), '-2 -1 0 1 2 3 4 5', '-3^..5';
is ~(-3^..^5), '-2 -1 0 1 2 3 4', '-3^..^5';
is ~(-3..6), '-3 -2 -1 0 1 2 3 4 5 6', '-3..6';
is ~(-3..^6), '-3 -2 -1 0 1 2 3 4 5', '-3..^6';
is ~(-3^..6), '-2 -1 0 1 2 3 4 5 6', '-3^..6';
is ~(-3^..^6), '-2 -1 0 1 2 3 4 5', '-3^..^6';
is ~(-3..7), '-3 -2 -1 0 1 2 3 4 5 6 7', '-3..7';
is ~(-3..^7), '-3 -2 -1 0 1 2 3 4 5 6', '-3..^7';
is ~(-3^..7), '-2 -1 0 1 2 3 4 5 6 7', '-3^..7';
is ~(-3^..^7), '-2 -1 0 1 2 3 4 5 6', '-3^..^7';
is ~(-3..14), '-3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14', '-3..14';
is ~(-3..^14), '-3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13', '-3..^14';
is ~(-3^..14), '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14', '-3^..14';
is ~(-3^..^14), '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13', '-3^..^14';
#?pugs skip 'hangs'
is ~(-3..Inf).list.[^20], '-3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16', '-3..Inf';
#?pugs skip 'hangs'
is ~(-3..^Inf).list.[^20], '-3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16', '-3..^Inf';
#?pugs skip 'hangs'
is ~(-3^..Inf).list.[^20], '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '-3^..Inf';
#?pugs skip 'hangs'
is ~(-3^..^Inf).list.[^20], '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '-3^..^Inf';
is ~(-2..-4), '', '-2..-4';
is ~(-2..^-4), '', '-2..^-4';
#?pugs skip 'empty list'
is ~(-2^..-4), '', '-2^..-4';
#?pugs skip 'empty list'
is ~(-2^..^-4), '', '-2^..^-4';
is ~(-2..-3), '', '-2..-3';
is ~(-2..^-3), '', '-2..^-3';
#?pugs skip 'empty list'
is ~(-2^..-3), '', '-2^..-3';
#?pugs skip 'empty list'
is ~(-2^..^-3), '', '-2^..^-3';
is ~(-2..-2), '-2', '-2..-2';
is ~(-2..^-2), '', '-2..^-2';
is ~(-2^..-2), '', '-2^..-2';
is ~(-2^..^-2), '', '-2^..^-2';
is ~(-2..-1), '-2 -1', '-2..-1';
is ~(-2..^-1), '-2', '-2..^-1';
is ~(-2^..-1), '-1', '-2^..-1';
is ~(-2^..^-1), '', '-2^..^-1';
is ~(-2..0), '-2 -1 0', '-2..0';
is ~(-2..^0), '-2 -1', '-2..^0';
is ~(-2^..0), '-1 0', '-2^..0';
is ~(-2^..^0), '-1', '-2^..^0';
is ~(-2..1), '-2 -1 0 1', '-2..1';
is ~(-2..^1), '-2 -1 0', '-2..^1';
is ~(-2^..1), '-1 0 1', '-2^..1';
is ~(-2^..^1), '-1 0', '-2^..^1';
is ~(-2..2), '-2 -1 0 1 2', '-2..2';
is ~(-2..^2), '-2 -1 0 1', '-2..^2';
is ~(-2^..2), '-1 0 1 2', '-2^..2';
is ~(-2^..^2), '-1 0 1', '-2^..^2';
is ~(-2..3), '-2 -1 0 1 2 3', '-2..3';
is ~(-2..^3), '-2 -1 0 1 2', '-2..^3';
is ~(-2^..3), '-1 0 1 2 3', '-2^..3';
is ~(-2^..^3), '-1 0 1 2', '-2^..^3';
is ~(-2..4), '-2 -1 0 1 2 3 4', '-2..4';
is ~(-2..^4), '-2 -1 0 1 2 3', '-2..^4';
is ~(-2^..4), '-1 0 1 2 3 4', '-2^..4';
is ~(-2^..^4), '-1 0 1 2 3', '-2^..^4';
is ~(-2..5), '-2 -1 0 1 2 3 4 5', '-2..5';
is ~(-2..^5), '-2 -1 0 1 2 3 4', '-2..^5';
is ~(-2^..5), '-1 0 1 2 3 4 5', '-2^..5';
is ~(-2^..^5), '-1 0 1 2 3 4', '-2^..^5';
is ~(-2..6), '-2 -1 0 1 2 3 4 5 6', '-2..6';
is ~(-2..^6), '-2 -1 0 1 2 3 4 5', '-2..^6';
is ~(-2^..6), '-1 0 1 2 3 4 5 6', '-2^..6';
is ~(-2^..^6), '-1 0 1 2 3 4 5', '-2^..^6';
is ~(-2..7), '-2 -1 0 1 2 3 4 5 6 7', '-2..7';
is ~(-2..^7), '-2 -1 0 1 2 3 4 5 6', '-2..^7';
is ~(-2^..7), '-1 0 1 2 3 4 5 6 7', '-2^..7';
is ~(-2^..^7), '-1 0 1 2 3 4 5 6', '-2^..^7';
is ~(-2..8), '-2 -1 0 1 2 3 4 5 6 7 8', '-2..8';
is ~(-2..^8), '-2 -1 0 1 2 3 4 5 6 7', '-2..^8';
is ~(-2^..8), '-1 0 1 2 3 4 5 6 7 8', '-2^..8';
is ~(-2^..^8), '-1 0 1 2 3 4 5 6 7', '-2^..^8';
is ~(-2..15), '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15', '-2..15';
is ~(-2..^15), '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14', '-2..^15';
is ~(-2^..15), '-1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15', '-2^..15';
is ~(-2^..^15), '-1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14', '-2^..^15';
#?pugs skip 'hangs'
is ~(-2..Inf).list.[^20], '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '-2..Inf';
#?pugs skip 'hangs'
is ~(-2..^Inf).list.[^20], '-2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '-2..^Inf';
#?pugs skip 'hangs'
is ~(-2^..Inf).list.[^20], '-1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18', '-2^..Inf';
#?pugs skip 'hangs'
is ~(-2^..^Inf).list.[^20], '-1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18', '-2^..^Inf';
is ~(0..-2), '', '0..-2';
is ~(0..^-2), '', '0..^-2';
#?pugs skip 'empty list'
is ~(0^..-2), '', '0^..-2';
#?pugs skip 'empty list'
is ~(0^..^-2), '', '0^..^-2';
is ~(0..-1), '', '0..-1';
is ~(0..^-1), '', '0..^-1';
#?pugs skip 'empty list'
is ~(0^..-1), '', '0^..-1';
#?pugs skip 'empty list'
is ~(0^..^-1), '', '0^..^-1';
is ~(0..0), '0', '0..0';
is ~(0..^0), '', '0..^0';
is ~(0^..0), '', '0^..0';
is ~(0^..^0), '', '0^..^0';
is ~(0..1), '0 1', '0..1';
is ~(0..^1), '0', '0..^1';
is ~(0^..1), '1', '0^..1';
is ~(0^..^1), '', '0^..^1';
is ~(0..2), '0 1 2', '0..2';
is ~(0..^2), '0 1', '0..^2';
is ~(0^..2), '1 2', '0^..2';
is ~(0^..^2), '1', '0^..^2';
is ~(0..3), '0 1 2 3', '0..3';
is ~(0..^3), '0 1 2', '0..^3';
is ~(0^..3), '1 2 3', '0^..3';
is ~(0^..^3), '1 2', '0^..^3';
is ~(0..4), '0 1 2 3 4', '0..4';
is ~(0..^4), '0 1 2 3', '0..^4';
is ~(0^..4), '1 2 3 4', '0^..4';
is ~(0^..^4), '1 2 3', '0^..^4';
is ~(0..5), '0 1 2 3 4 5', '0..5';
is ~(0..^5), '0 1 2 3 4', '0..^5';
is ~(0^..5), '1 2 3 4 5', '0^..5';
is ~(0^..^5), '1 2 3 4', '0^..^5';
is ~(0..6), '0 1 2 3 4 5 6', '0..6';
is ~(0..^6), '0 1 2 3 4 5', '0..^6';
is ~(0^..6), '1 2 3 4 5 6', '0^..6';
is ~(0^..^6), '1 2 3 4 5', '0^..^6';
is ~(0..7), '0 1 2 3 4 5 6 7', '0..7';
is ~(0..^7), '0 1 2 3 4 5 6', '0..^7';
is ~(0^..7), '1 2 3 4 5 6 7', '0^..7';
is ~(0^..^7), '1 2 3 4 5 6', '0^..^7';
is ~(0..8), '0 1 2 3 4 5 6 7 8', '0..8';
is ~(0..^8), '0 1 2 3 4 5 6 7', '0..^8';
is ~(0^..8), '1 2 3 4 5 6 7 8', '0^..8';
is ~(0^..^8), '1 2 3 4 5 6 7', '0^..^8';
is ~(0..9), '0 1 2 3 4 5 6 7 8 9', '0..9';
is ~(0..^9), '0 1 2 3 4 5 6 7 8', '0..^9';
is ~(0^..9), '1 2 3 4 5 6 7 8 9', '0^..9';
is ~(0^..^9), '1 2 3 4 5 6 7 8', '0^..^9';
is ~(0..10), '0 1 2 3 4 5 6 7 8 9 10', '0..10';
is ~(0..^10), '0 1 2 3 4 5 6 7 8 9', '0..^10';
is ~(0^..10), '1 2 3 4 5 6 7 8 9 10', '0^..10';
is ~(0^..^10), '1 2 3 4 5 6 7 8 9', '0^..^10';
is ~(0..17), '0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '0..17';
is ~(0..^17), '0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16', '0..^17';
is ~(0^..17), '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '0^..17';
is ~(0^..^17), '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16', '0^..^17';
#?pugs skip 'hangs'
is ~(0..Inf).list.[^20], '0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19', '0..Inf';
#?pugs skip 'hangs'
is ~(0..^Inf).list.[^20], '0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19', '0..^Inf';
#?pugs skip 'hangs'
is ~(0^..Inf).list.[^20], '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20', '0^..Inf';
#?pugs skip 'hangs'
is ~(0^..^Inf).list.[^20], '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20', '0^..^Inf';
is ~(1..-1), '', '1..-1';
is ~(1..^-1), '', '1..^-1';
#?pugs skip 'empty list'
is ~(1^..-1), '', '1^..-1';
#?pugs skip 'empty list'
is ~(1^..^-1), '', '1^..^-1';
is ~(1..0), '', '1..0';
is ~(1..^0), '', '1..^0';
#?pugs skip 'empty list'
is ~(1^..0), '', '1^..0';
#?pugs skip 'empty list'
is ~(1^..^0), '', '1^..^0';
is ~(1..1), '1', '1..1';
is ~(1..^1), '', '1..^1';
is ~(1^..1), '', '1^..1';
is ~(1^..^1), '', '1^..^1';
is ~(1..2), '1 2', '1..2';
is ~(1..^2), '1', '1..^2';
is ~(1^..2), '2', '1^..2';
is ~(1^..^2), '', '1^..^2';
is ~(1..3), '1 2 3', '1..3';
is ~(1..^3), '1 2', '1..^3';
is ~(1^..3), '2 3', '1^..3';
is ~(1^..^3), '2', '1^..^3';
is ~(1..4), '1 2 3 4', '1..4';
is ~(1..^4), '1 2 3', '1..^4';
is ~(1^..4), '2 3 4', '1^..4';
is ~(1^..^4), '2 3', '1^..^4';
is ~(1..5), '1 2 3 4 5', '1..5';
is ~(1..^5), '1 2 3 4', '1..^5';
is ~(1^..5), '2 3 4 5', '1^..5';
is ~(1^..^5), '2 3 4', '1^..^5';
is ~(1..6), '1 2 3 4 5 6', '1..6';
is ~(1..^6), '1 2 3 4 5', '1..^6';
is ~(1^..6), '2 3 4 5 6', '1^..6';
is ~(1^..^6), '2 3 4 5', '1^..^6';
is ~(1..7), '1 2 3 4 5 6 7', '1..7';
is ~(1..^7), '1 2 3 4 5 6', '1..^7';
is ~(1^..7), '2 3 4 5 6 7', '1^..7';
is ~(1^..^7), '2 3 4 5 6', '1^..^7';
is ~(1..8), '1 2 3 4 5 6 7 8', '1..8';
is ~(1..^8), '1 2 3 4 5 6 7', '1..^8';
is ~(1^..8), '2 3 4 5 6 7 8', '1^..8';
is ~(1^..^8), '2 3 4 5 6 7', '1^..^8';
is ~(1..9), '1 2 3 4 5 6 7 8 9', '1..9';
is ~(1..^9), '1 2 3 4 5 6 7 8', '1..^9';
is ~(1^..9), '2 3 4 5 6 7 8 9', '1^..9';
is ~(1^..^9), '2 3 4 5 6 7 8', '1^..^9';
is ~(1..10), '1 2 3 4 5 6 7 8 9 10', '1..10';
is ~(1..^10), '1 2 3 4 5 6 7 8 9', '1..^10';
is ~(1^..10), '2 3 4 5 6 7 8 9 10', '1^..10';
is ~(1^..^10), '2 3 4 5 6 7 8 9', '1^..^10';
is ~(1..11), '1 2 3 4 5 6 7 8 9 10 11', '1..11';
is ~(1..^11), '1 2 3 4 5 6 7 8 9 10', '1..^11';
is ~(1^..11), '2 3 4 5 6 7 8 9 10 11', '1^..11';
is ~(1^..^11), '2 3 4 5 6 7 8 9 10', '1^..^11';
is ~(1..18), '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18', '1..18';
is ~(1..^18), '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '1..^18';
is ~(1^..18), '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18', '1^..18';
is ~(1^..^18), '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17', '1^..^18';
#?pugs skip 'hangs'
is ~(1..Inf).list.[^20], '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20', '1..Inf';
#?pugs skip 'hangs'
is ~(1..^Inf).list.[^20], '1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20', '1..^Inf';
#?pugs skip 'hangs'
is ~(1^..Inf).list.[^20], '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21', '1^..Inf';
#?pugs skip 'hangs'
is ~(1^..^Inf).list.[^20], '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21', '1^..^Inf';
is ~(2..0), '', '2..0';
is ~(2..^0), '', '2..^0';
#?pugs skip 'empty list'
is ~(2^..0), '', '2^..0';
#?pugs skip 'empty list'
is ~(2^..^0), '', '2^..^0';
is ~(2..1), '', '2..1';
is ~(2..^1), '', '2..^1';
#?pugs skip 'empty list'
is ~(2^..1), '', '2^..1';
#?pugs skip 'empty list'
is ~(2^..^1), '', '2^..^1';
is ~(2..2), '2', '2..2';
is ~(2..^2), '', '2..^2';
is ~(2^..2), '', '2^..2';
is ~(2^..^2), '', '2^..^2';
is ~(2..3), '2 3', '2..3';
is ~(2..^3), '2', '2..^3';
is ~(2^..3), '3', '2^..3';
is ~(2^..^3), '', '2^..^3';
is ~(2..4), '2 3 4', '2..4';
is ~(2..^4), '2 3', '2..^4';
is ~(2^..4), '3 4', '2^..4';
is ~(2^..^4), '3', '2^..^4';
is ~(2..5), '2 3 4 5', '2..5';
is ~(2..^5), '2 3 4', '2..^5';
is ~(2^..5), '3 4 5', '2^..5';
is ~(2^..^5), '3 4', '2^..^5';
is ~(2..6), '2 3 4 5 6', '2..6';
is ~(2..^6), '2 3 4 5', '2..^6';
is ~(2^..6), '3 4 5 6', '2^..6';
is ~(2^..^6), '3 4 5', '2^..^6';
is ~(2..7), '2 3 4 5 6 7', '2..7';
is ~(2..^7), '2 3 4 5 6', '2..^7';
is ~(2^..7), '3 4 5 6 7', '2^..7';
is ~(2^..^7), '3 4 5 6', '2^..^7';
is ~(2..8), '2 3 4 5 6 7 8', '2..8';
is ~(2..^8), '2 3 4 5 6 7', '2..^8';
is ~(2^..8), '3 4 5 6 7 8', '2^..8';
is ~(2^..^8), '3 4 5 6 7', '2^..^8';
is ~(2..9), '2 3 4 5 6 7 8 9', '2..9';
is ~(2..^9), '2 3 4 5 6 7 8', '2..^9';
is ~(2^..9), '3 4 5 6 7 8 9', '2^..9';
is ~(2^..^9), '3 4 5 6 7 8', '2^..^9';
is ~(2..10), '2 3 4 5 6 7 8 9 10', '2..10';
is ~(2..^10), '2 3 4 5 6 7 8 9', '2..^10';
is ~(2^..10), '3 4 5 6 7 8 9 10', '2^..10';
is ~(2^..^10), '3 4 5 6 7 8 9', '2^..^10';
is ~(2..11), '2 3 4 5 6 7 8 9 10 11', '2..11';
is ~(2..^11), '2 3 4 5 6 7 8 9 10', '2..^11';
is ~(2^..11), '3 4 5 6 7 8 9 10 11', '2^..11';
is ~(2^..^11), '3 4 5 6 7 8 9 10', '2^..^11';
is ~(2..12), '2 3 4 5 6 7 8 9 10 11 12', '2..12';
is ~(2..^12), '2 3 4 5 6 7 8 9 10 11', '2..^12';
is ~(2^..12), '3 4 5 6 7 8 9 10 11 12', '2^..12';
is ~(2^..^12), '3 4 5 6 7 8 9 10 11', '2^..^12';
is ~(2..19), '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19', '2..19';
is ~(2..^19), '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18', '2..^19';
is ~(2^..19), '3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19', '2^..19';
is ~(2^..^19), '3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18', '2^..^19';
#?pugs skip 'hangs'
is ~(2..Inf).list.[^20], '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21', '2..Inf';
#?pugs skip 'hangs'
is ~(2..^Inf).list.[^20], '2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21', '2..^Inf';
#?pugs skip 'hangs'
is ~(2^..Inf).list.[^20], '3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22', '2^..Inf';
#?pugs skip 'hangs'
is ~(2^..^Inf).list.[^20], '3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22', '2^..^Inf';
is ~(5..3), '', '5..3';
is ~(5..^3), '', '5..^3';
#?pugs skip 'empty list'
is ~(5^..3), '', '5^..3';
#?pugs skip 'empty list'
is ~(5^..^3), '', '5^..^3';
is ~(5..4), '', '5..4';
is ~(5..^4), '', '5..^4';
#?pugs skip 'empty list'
is ~(5^..4), '', '5^..4';
#?pugs skip 'empty list'
is ~(5^..^4), '', '5^..^4';
is ~(5..5), '5', '5..5';
is ~(5..^5), '', '5..^5';
is ~(5^..5), '', '5^..5';
is ~(5^..^5), '', '5^..^5';
is ~(5..6), '5 6', '5..6';
is ~(5..^6), '5', '5..^6';
is ~(5^..6), '6', '5^..6';
is ~(5^..^6), '', '5^..^6';
is ~(5..7), '5 6 7', '5..7';
is ~(5..^7), '5 6', '5..^7';
is ~(5^..7), '6 7', '5^..7';
is ~(5^..^7), '6', '5^..^7';
is ~(5..8), '5 6 7 8', '5..8';
is ~(5..^8), '5 6 7', '5..^8';
is ~(5^..8), '6 7 8', '5^..8';
is ~(5^..^8), '6 7', '5^..^8';
is ~(5..9), '5 6 7 8 9', '5..9';
is ~(5..^9), '5 6 7 8', '5..^9';
is ~(5^..9), '6 7 8 9', '5^..9';
is ~(5^..^9), '6 7 8', '5^..^9';
is ~(5..10), '5 6 7 8 9 10', '5..10';
is ~(5..^10), '5 6 7 8 9', '5..^10';
is ~(5^..10), '6 7 8 9 10', '5^..10';
is ~(5^..^10), '6 7 8 9', '5^..^10';
is ~(5..11), '5 6 7 8 9 10 11', '5..11';
is ~(5..^11), '5 6 7 8 9 10', '5..^11';
is ~(5^..11), '6 7 8 9 10 11', '5^..11';
is ~(5^..^11), '6 7 8 9 10', '5^..^11';
is ~(5..12), '5 6 7 8 9 10 11 12', '5..12';
is ~(5..^12), '5 6 7 8 9 10 11', '5..^12';
is ~(5^..12), '6 7 8 9 10 11 12', '5^..12';
is ~(5^..^12), '6 7 8 9 10 11', '5^..^12';
is ~(5..13), '5 6 7 8 9 10 11 12 13', '5..13';
is ~(5..^13), '5 6 7 8 9 10 11 12', '5..^13';
is ~(5^..13), '6 7 8 9 10 11 12 13', '5^..13';
is ~(5^..^13), '6 7 8 9 10 11 12', '5^..^13';
is ~(5..14), '5 6 7 8 9 10 11 12 13 14', '5..14';
is ~(5..^14), '5 6 7 8 9 10 11 12 13', '5..^14';
is ~(5^..14), '6 7 8 9 10 11 12 13 14', '5^..14';
is ~(5^..^14), '6 7 8 9 10 11 12 13', '5^..^14';
is ~(5..15), '5 6 7 8 9 10 11 12 13 14 15', '5..15';
is ~(5..^15), '5 6 7 8 9 10 11 12 13 14', '5..^15';
is ~(5^..15), '6 7 8 9 10 11 12 13 14 15', '5^..15';
is ~(5^..^15), '6 7 8 9 10 11 12 13 14', '5^..^15';
is ~(5..22), '5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22', '5..22';
is ~(5..^22), '5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21', '5..^22';
is ~(5^..22), '6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22', '5^..22';
is ~(5^..^22), '6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21', '5^..^22';
#?pugs skip 'hangs'
is ~(5..Inf).list.[^20], '5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24', '5..Inf';
#?pugs skip 'hangs'
is ~(5..^Inf).list.[^20], '5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24', '5..^Inf';
#?pugs skip 'hangs'
is ~(5^..Inf).list.[^20], '6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25', '5^..Inf';
#?pugs skip 'hangs'
is ~(5^..^Inf).list.[^20], '6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25', '5^..^Inf';
is ~(17..15), '', '17..15';
is ~(17..^15), '', '17..^15';
#?pugs skip 'empty list'
is ~(17^..15), '', '17^..15';
#?pugs skip 'empty list'
is ~(17^..^15), '', '17^..^15';
is ~(17..16), '', '17..16';
is ~(17..^16), '', '17..^16';
#?pugs skip 'empty list'
is ~(17^..16), '', '17^..16';
#?pugs skip 'empty list'
is ~(17^..^16), '', '17^..^16';
is ~(17..17), '17', '17..17';
is ~(17..^17), '', '17..^17';
is ~(17^..17), '', '17^..17';
is ~(17^..^17), '', '17^..^17';
is ~(17..18), '17 18', '17..18';
is ~(17..^18), '17', '17..^18';
is ~(17^..18), '18', '17^..18';
is ~(17^..^18), '', '17^..^18';
is ~(17..19), '17 18 19', '17..19';
is ~(17..^19), '17 18', '17..^19';
is ~(17^..19), '18 19', '17^..19';
is ~(17^..^19), '18', '17^..^19';
is ~(17..20), '17 18 19 20', '17..20';
is ~(17..^20), '17 18 19', '17..^20';
is ~(17^..20), '18 19 20', '17^..20';
is ~(17^..^20), '18 19', '17^..^20';
is ~(17..21), '17 18 19 20 21', '17..21';
is ~(17..^21), '17 18 19 20', '17..^21';
is ~(17^..21), '18 19 20 21', '17^..21';
is ~(17^..^21), '18 19 20', '17^..^21';
is ~(17..22), '17 18 19 20 21 22', '17..22';
is ~(17..^22), '17 18 19 20 21', '17..^22';
is ~(17^..22), '18 19 20 21 22', '17^..22';
is ~(17^..^22), '18 19 20 21', '17^..^22';
is ~(17..23), '17 18 19 20 21 22 23', '17..23';
is ~(17..^23), '17 18 19 20 21 22', '17..^23';
is ~(17^..23), '18 19 20 21 22 23', '17^..23';
is ~(17^..^23), '18 19 20 21 22', '17^..^23';
is ~(17..24), '17 18 19 20 21 22 23 24', '17..24';
is ~(17..^24), '17 18 19 20 21 22 23', '17..^24';
is ~(17^..24), '18 19 20 21 22 23 24', '17^..24';
is ~(17^..^24), '18 19 20 21 22 23', '17^..^24';
is ~(17..25), '17 18 19 20 21 22 23 24 25', '17..25';
is ~(17..^25), '17 18 19 20 21 22 23 24', '17..^25';
is ~(17^..25), '18 19 20 21 22 23 24 25', '17^..25';
is ~(17^..^25), '18 19 20 21 22 23 24', '17^..^25';
is ~(17..26), '17 18 19 20 21 22 23 24 25 26', '17..26';
is ~(17..^26), '17 18 19 20 21 22 23 24 25', '17..^26';
is ~(17^..26), '18 19 20 21 22 23 24 25 26', '17^..26';
is ~(17^..^26), '18 19 20 21 22 23 24 25', '17^..^26';
is ~(17..27), '17 18 19 20 21 22 23 24 25 26 27', '17..27';
is ~(17..^27), '17 18 19 20 21 22 23 24 25 26', '17..^27';
is ~(17^..27), '18 19 20 21 22 23 24 25 26 27', '17^..27';
is ~(17^..^27), '18 19 20 21 22 23 24 25 26', '17^..^27';
is ~(17..34), '17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34', '17..34';
is ~(17..^34), '17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33', '17..^34';
is ~(17^..34), '18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34', '17^..34';
is ~(17^..^34), '18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33', '17^..^34';
#?pugs skip 'hangs'
is ~(17..Inf).list.[^20], '17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36', '17..Inf';
#?pugs skip 'hangs'
is ~(17..^Inf).list.[^20], '17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36', '17..^Inf';
#?pugs skip 'hangs'
is ~(17^..Inf).list.[^20], '18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37', '17^..Inf';
#?pugs skip 'hangs'
is ~(17^..^Inf).list.[^20], '18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37', '17^..^Inf';
 
done;
# # vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/range.t0000664000175000017500000002557212224265625017663 0ustar  moritzmoritzuse v6;

use Test;

plan 124;

# L

# 3..2 must *not* produce "3 2".  Use reverse to get a reversed range. -lwall
is ~(3..6), "3 4 5 6", "(..) works on numbers (1)";
is ~(3..3), "3",       "(..) works on numbers (2)";
is ~(3..2), "",        "(..) works on auto-rev numbers (3)";
is ~(8..11), "8 9 10 11",   "(..) works on carried numbers (3)";

is ~("a".."c"), "a b c", "(..) works on chars (1)";
is ~("a".."a"), "a",     "(..) works on chars (2)";
is ~("b".."a"), "",      "(..) works on chars (3)";
is ~("a".."z"), "a b c d e f g h i j k l m n o p q r s t u v w x y z", "(..) works on char range ending in z";
is ~("A".."Z"), "A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", "(..) works on char range ending in Z";
#?pugs todo
is ~("Y".."AB"), "",     "(..) works on carried chars (3)";

#?rakudo todo 'huh?'
#?niecza 4 skip 'Spec under design here'
is ~('Y'..'z'), 'Y Z', '(..) works on uppercase letter .. lowercase letter (1)';
is ~('z'..'Y'), '',    '(..) works on auto-rev uppercase letter .. lowercase letter (2)';
#?rakudo todo 'huh?'
is ~('Y'..'_'), 'Y Z', '(..) works on letter .. non-letter (1)';
is ~('_'..'Y'), '',    '(..) works on auto-rev letter .. non-letter (2)';
is ~(' '..' '), ' ',    'all-whitespace range works';

is ~(3..9-3), "3 4 5 6", "(..) has correct precedence (1)";
is ~(5..9-5), "",        "(..) has correct precedence (2)";
is ~(2+1..6), "3 4 5 6", "(..) has correct precedence (3)";
is ~(2+5..6), "",        "(..) has correct precedence (4)";

# Test the three exclusive range operators:
# L
is [1^..9], [2..9],  "bottom-exclusive range (^..) works (1)";
is [2^..2], [],      "bottom-exclusive range (^..) works (2)";
#?pugs skip 'empty list'
is [3^..2], [],      "bottom-exclusive auto-rev range (^..) works (3)";
is [1 ..^9], [1..8], "top-exclusive range (..^) works (1)";
is [2 ..^2], [],     "top-exclusive range (..^) works (2)";
is [3 ..^2], [],     "top-exclusive auto-rev range (..^) works (3)";
is [1^..^9], [2..8], "double-exclusive range (^..^) works (1)";
#?pugs skip 'empty list'
is [9^..^1], [],     "double-exclusive auto-rev range (^..^) works (2)";
is [1^..^2], [],     "double-exclusive range (^..^) can produce null range (1)";

# tests of (x ^..^ x) here and below ensure that our implementation
# of double-exclusive range does not blindly remove an element
# from the head and tail of a list
is [1^..^1], [], "double-exclusive range (x ^..^ x) where x is an int";

is ["a"^.."z"], ["b".."z"], "bottom-exclusive string range (^..) works";
#?pugs skip 'empty list'
is ["z"^.."a"], [], "bottom-exclusive string auto-rev range (^..) works";
is ["a"..^"z"], ["a".."y"], "top-exclusive string range (..^) works";
is ["z"..^"a"], [], "top-exclusive string auto-rev range (..^) works";
is ["a"^..^"z"], ["b".."y"], "double-exclusive string range (^..^) works";
#?pugs skip 'empty list'
is ["z"^..^"a"], [], "double-exclusive string auto-rev range (^..^) works";
is ['a'^..^'b'], [], "double-exclusive string range (^..^) can produce null range";
#?pugs skip 'empty list'
is ['b'^..^'a'], [], "double-exclusive string auto-rev range (^..^) can produce null range";
is ['a' ^..^ 'a'], [], "double-exclusive range (x ^..^ x) where x is a char";
is ('a'..'z').list.join(' '), 'a b c d e f g h i j k l m n o p q r s t u v w x y z', '"a".."z"';

#?pugs todo 'bug'
is 1.5 ~~ 1^..^2, Bool::True, "lazy evaluation of the range operator";

# Test the unary ^ operator
is ~(^5), "0 1 2 3 4", "unary ^num produces the range 0..^num";
is [^1],   [0],        "unary ^ on the boundary ^1 works";
is [^0],   [],         "unary ^0 produces null range";
is [^-1],  [],         "unary ^-1 produces null range";
is [^0.1], [0],        "unary ^0.1 produces the range 0..^x where 0 < x < 1";
is ~(^"5"), "0 1 2 3 4", 'unary ^"num" produces the range 0..^num';

{
    my @a = 3, 5, 3;
    #?pugs todo
    is (^@a).perl, (0..^3).perl,    'unary ^@a produces 0..^+@a';
}

# test iterating on infinite ranges
is (1..*).[^5].join('|'), '1|2|3|4|5', '1..*';
is ('a'..*).[^5].join('|'), 'a|b|c|d|e', '"a"..*';

# test that the zip operator works with ranges
#?pugs 4 todo
is (1..5 Z ).join('|'), '1|a|2|b|3|c', 'Ranges and infix:';
is (1..2 Z ).join('|'), '1|a|2|b',     'Ranges and infix:';
is ( Z 1..5).join('|'), 'c|1|b|2|a|3', 'Ranges and infix:';

# two ranges
is (1..6 Z 'a' .. 'c').join, '1a2b3c',   'Ranges and infix:';

{
    # Test with floats
    # 2006-12-05:
    # 16:16  ~(1.9 ^..^ 4.9) should produce 2.9, 3.9
    # 16:17  and ~(1.9 ^..^ 4.5) would produce the same?
    # 16:17  yes
    is ~(1.1 .. 4) , "1.1 2.1 3.1", "range with float .min";
    is ~(1.9 .. 4) , "1.9 2.9 3.9", "range with float .min";
    is ~(1.1 ^.. 4), "2.1 3.1"    , "bottom exclusive range of float";
    is ~(1.9 ^.. 4), "2.9 3.9"    , "bottom exclusive range of float";

    is ~(1 .. 4.1) , "1 2 3 4", "range with float .max";
    is ~(1 .. 4.9) , "1 2 3 4", "range with float .max";
    is ~(1 ..^ 4.1), "1 2 3 4", "top exclusive range of float";
    is ~(1 ..^ 4.9), "1 2 3 4", "top exclusive range of float";

    is ~(1.1 .. 4.1), "1.1 2.1 3.1 4.1", "range with float .min/.max";
    is ~(1.9 .. 4.1), "1.9 2.9 3.9"    , "range with float .min/.max";
    is ~(1.1 .. 4.9), "1.1 2.1 3.1 4.1", "range with float .min/.max";
    is ~(1.9 .. 4.9), "1.9 2.9 3.9 4.9", "range with float .min/.max";

    is ~(1.1 ^..^ 4.1), "2.1 3.1"    , "both exclusive float range";
    is ~(1.9 ^..^ 4.1), "2.9 3.9"    , "both exclusive float range";
    is ~(1.1 ^..^ 4.9), "2.1 3.1 4.1", "both exclusive float range";
    is ~(1.9 ^..^ 4.9), "2.9 3.9"    , "both exclusive float range";
    is [1.1 ^..^ 1.1], [], "double-exclusive range (x ^..^ x) where x is a float";
}

# Test that the operands are forced to scalar context
# Range.new coerces its arguments to numeric context if needed
# RT #58018
# RT #76950
#?niecza skip "Unhandled exception: cannot increment a value of type Array"
{
    my @three = (1, 1, 1);
    my @one = 1;

    is ~(@one .. 3)     , "1 2 3", "lower inclusive limit is in scalar context";
    is ~(@one ^.. 3)    , "2 3"  , "lower exclusive limit is in scalar context";
    #?pugs skip 'empty list'
    is ~(3 ^.. @one)    , ""     , "lower exclusive limit is in scalar context";
    is ~(1 .. @three)   , "1 2 3", "upper inclusive limit is in scalar context";
    is ~(4 .. @three)   , ""     , "upper inclusive limit is in scalar context";
    is ~(1 ..^ @three)  , "1 2"  , "upper exclusive limit is in scalar context";
    is ~(4 ..^ @three)  , ""     , "upper exclusive limit is in scalar context";
    is ~(@one .. @three), "1 2 3", "both limits is in scalar context";
    is ~(@one ^.. @three), "2 3" , "lower exclusive limit scalar context";
    is ~(@one ..^ @three), "1 2" , "upper exclusive limit scalar context";
    is ~(@one ^..^ @three), "2"  , "both exclusive limit scalar context";
}

# test that .map and .grep work on ranges
{
    is (0..3).map({$_ * 2}).join('|'),      '0|2|4|6', '.map works on ranges';
    is (0..3).grep({$_ == 1|3}).join('|'),  '1|3',     '.grep works on ranges';
    is (1..3).first({ $_ % 2 == 0}),        2,         '.first works on ranges';
    is (1..3).reduce({ $^a + $^b}),         6,         '.reduce works on ranges';
}

# test that range operands are handled in string context if strings
{
    my $range;
    my $start = "100.B";
    my $end = "102.B";
    lives_ok { $range = $start..$end },
             'can make range from numeric string vars';
    #?pugs todo
    is $range.min, $start, 'range starts at start';
    #?pugs todo "wrong type"
    is $range.min.WHAT.gist, Str.gist, 'range start is a string';
    #?pugs todo
    is $range.max,   $end, 'range ends at end';
    #?pugs todo "wrong type"
    is $range.max.WHAT.gist, Str.gist, 'range end is a string';
    lives_ok { "$range" }, 'can stringify range';
    #?pugs todo
    is ~$range, "100.B 101.B 102.B", 'range is correct';
}
 
# RT #67882
{
    my $range;
    lives_ok { '1 3' ~~ /(\d+) \s (\d+)/; $range = $0..$1 },
             'can make range from match vars';
    #?pugs todo
    is $range.min, 1, 'range starts at one';
    #?pugs todo
    is $range.max, 3, 'range ends at three';
    #?niecza 2 skip 'cannot increment a value of type Match'
    lives_ok { "$range" }, 'can stringify range';
    #?pugs todo
    is ~$range, "1 2 3", 'range is correct';
}
# and another set, just for the lulz
# RT #67882
#?pugs skip 'Range'
{
    ok '1 3' ~~ /(\d) . (\d)/, 'regex sanity';
    isa_ok $0..$1, Range, '$0..$1 constructs a Range';
    #?niecza skip 'cannot increment a value of type Match'
    is ($0..$1).join('|'), '1|2|3', 'range from $0..$1';
}

{
    my $range;
    lives_ok { '1 3' ~~ /(\d+) \s (\d+)/; $range = +$0..+$1 },
             'can make range from match vars with numeric context forced';
    #?pugs todo
    is $range.min, 1, 'range starts at one';
    #?pugs todo
    is $range.max,   3, 'range ends at three';
    lives_ok { "$range" }, 'can stringify range';
    #?pugs todo
    is ~$range, "1 2 3", 'range is correct';
}

{
    my $range;
    lives_ok { '1 3' ~~ /(\d+) \s (\d+)/; $range = ~$0..~$1 },
             'can make range from match vars with string context forced';
    #?pugs todo
    is $range.min, 1, 'range starts at one';
    #?pugs todo 'wrong type'
    is $range.min.WHAT.gist, Str.gist, 'range start is a string';
    #?pugs todo
    is $range.max,   3, 'range ends at three';
    #?pugs todo 'wrong type'
    is $range.max.WHAT.gist, Str.gist, 'range end is a string';
    lives_ok { "$range" }, 'can stringify range';
    #?pugs todo
    is ~$range, "1 2 3", 'range is correct';
}

# L

#?niecza todo 'forbid Ranges as Range endpoints'
#?pugs todo
{
    ok !defined(try { 0 .. ^10 }), '0 .. ^10 is illegal';
}

# Lists are allowed on the rhs if the lhs is numeric (Real):
is ~(2 .. []), "2 3 4 5", '2 .. @list is legal';

# RT #68788
#?pugs skip 'Missing required parameters: $_'
#?DOES 2
{
    $_ = Any; # unsetting $_ to reproduce bug literally
    lives_ok {(1..$_)}, '(1..$_) lives';
    isa_ok (1..$_), Range, '(..) works on Int .. Any';
}

#?pugs skip 'Numeric'
{
    my $range = 1 .. '10';
    is +$range, 10, "1 .. '10' has ten elements in it";
    is +$range.grep(Numeric), 10, "and they are all numbers";
}

#?pugs skip 'Numeric'
{
    my @array = 1 .. 10;
    my $range = 1 .. @array;
    is +$range, 10, "1 .. @array has ten elements in it";
    is +$range.grep(Numeric), 10, "and they are all numbers";
}

# RT #82620
{
    lives_ok {("a".."b").map({.trans(""=>"")}).perl},
        "range doesn't leak Parrot types";
}

{
    my $big = 2 ** 130;
    my $count = 0;
    ++$count for $big .. $big + 2;
    is $count, 3, 'can iterate over big Int range';
}

# RT #110350
{
    for 1e0 .. 1e0 {
        isa_ok $_, Num, 'Range of nums produces a Num';
    }
}

# RT #77572
eval_dies_ok '1..2..3', '.. is not associative';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/reduce-le1arg.t0000664000175000017500000000526412224265625021203 0ustar  moritzmoritzuse v6;

use Test;
plan 54;

# smartlink to top and bottom of long table
# L
# L

is ([**] ()), 1, "[**] () eq 1 (arguably nonsensical)";
is ([*] ()), 1, "[*] () eq 1";
ok( !([/] ()).defined, "[/] () should fail");
ok( !([%] ()).defined, "[%] () should fail");
ok( !([x] ()).defined, "[x] () should fail");
ok( !([xx] ()).defined, "[xx] () should fail");
is ([+&] ()), +^0, "[+&] () eq +^0";
ok( !([+<] ()).defined, "[+<] () should fail");
ok( !([+>] ()).defined, "[+>] () should fail");
ok( !([~&] ()).defined, "[~&] () should fail");
#?rakudo skip "~< NYI"
ok( !([~<] ()).defined, "[~<] () should fail");
#?rakudo skip "~> NYI"
ok( !([~>] ()).defined, "[~>] () should fail");
is ([+] ()), 0, "[+] () eq 0";
is ([-] ()), 0, "[-] () eq 0";
is ([~] ()), '', "[~] () eq ''";
is ([+|] ()), 0, "[+|] () eq 0";
is ([+^] ()), 0, "[+^] () eq 0";
is ([~|] ()), '', "[~|] () eq ''";
is ([~^] ()), '', "[~^] () eq ''";
is ([&] ()).perl, all().perl, "[&] () eq all()";
is ([|] ()).perl, any().perl, "[|] () eq any()";
is ([^] ()).perl, one().perl, "[^] () eq one()";
is ([!==] ()), Bool::True, "[!==] () eq True";
is ([==] ()), Bool::True, "[==] () eq True";
is ([<] ()), Bool::True, "[<] () eq True";
is ([<=] ()), Bool::True, "[<=] () eq True";
is ([>] ()), Bool::True, "[>] () eq True";
is ([>=] ()), Bool::True, "[>=] () eq True";
is ([before] ()), Bool::True, "[before] () eq True";
is ([after] ()), Bool::True, "[after] () eq True";
is ([~~] ()), Bool::True, "[~~] () eq True";
#?rakudo skip 'expected Any but got Mu instead'
is ([!~~] ()), Bool::True, "[!~~] () eq True";
is ([eq] ()), Bool::True, "[eq] () eq True)";
is ([ne] ()), Bool::True, "[ne] () eq True)";
is ([!eq] ()), Bool::True, "[!eq] () eq True";
is ([lt] ()), Bool::True, "[lt] () eq True";
is ([le] ()), Bool::True, "[le] () eq True";
is ([gt] ()), Bool::True, "[gt] () eq True";
is ([ge] ()), Bool::True, "[ge] () eq True";
is ([=:=] ()), Bool::True, "[=:=] () eq True";
is ([!=:=] ()), Bool::True, "[!=:=] () eq True";
is ([===] ()), Bool::True, "[===] () eq True";
is ([!===] ()), Bool::True, "[!===] () eq True";
is ([eqv] ()), Bool::True, "[eqv] () eq True";
is ([!eqv] ()), Bool::True, "[!eqv] () eq True";
is ([&&] ()), Bool::True, "[&&] () eq True";
is ([||] ()), Bool::False, "[||] () eq False";
# RT #65164 implement [^^]
is ([^^] ()), Bool::False, "[^^] () eq False";
is ([//] ()), Any, "[//] () is Any";
is ([,] ()), (), "[,] () eq ()";
#?rakudo skip '[Z] hangs'
is ([Z] ()), [], "[Z] () eq []";

is ([==] 3), Bool::True, 'unary [==]';
is ([!=] 3), Bool::True, 'unary [!=]';
is ([!==] 3), Bool::True, 'unary [!==]';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/relational.t0000664000175000017500000001360112237474612020711 0ustar  moritzmoritzuse v6;
use Test;

plan 118;

## N.B.:  Tests for infix:«<=>» (spaceship) and infix: belong
## in F.

#L

# from t/operators/relational.t

## numeric relationals ( < , >, <=, >= )

ok(1 < 2, '1 is less than 2');
ok(!(2 < 1), '2 is ~not~ less than 1');

ok 1/4 < 3/4, '1/4 is less than 3/4';
ok !(3/4 < 1/4), '3/4 is not less than 1/4';
ok 1/2 < 1, '1/2 is less than 1';
ok !(1 < 1/2), '1 is not less than 1/2';

ok(2 > 1, '2 is greater than 1');
ok(!(1 > 2), '1 is ~not~ greater than 2');

ok 3/4 > 1/4, '3/4 is greater than 1/4';
ok !(1/4 > 3/4), '1/2 is not greater than 3/4';
ok 1 > 1/2, '1 is greater than 1/2';
ok !(1/2 > 1), '1/2 is not greater than 1';

ok(1 <= 2, '1 is less than or equal to 2');
ok(1 <= 1, '1 is less than or equal to 1');
ok(!(1 <= 0), '1 is ~not~ less than or equal to 0');

ok 1/4 <= 3/4, '1/4 is less than or equal to 3/4';
ok !(3/4 <= 1/4), '3/4 is not less than or equal to 1/4';
ok 1/2 <= 1, '1/2 is less than or equal to 1';
ok !(1 <= 1/2), '1 is not less than or equal to 1/2';
ok 1/2 <= 1/2, '1/2 is less than or equal to 1/2';

ok(2 >= 1, '2 is greater than or equal to 1');
ok(2 >= 2, '2 is greater than or equal to 2');
ok(!(2 >= 3), '2 is ~not~ greater than or equal to 3');

ok !(1/4 >= 3/4), '1/4 is greater than or equal to 3/4';
ok 3/4 >= 1/4, '3/4 is not greater than or equal to 1/4';
ok !(1/2 >= 1), '1/2 is greater than or equal to 1';
ok 1 >= 1/2, '1 is not greater than or equal to 1/2';
ok 1/2 >= 1/2, '1/2 is greater than or equal to 1/2';

# Ensure that these operators actually return Bool::True or Bool::False
is(1 < 2,  Bool::True,  '< true');
is(1 > 0,  Bool::True,  '> true');
is(1 <= 2, Bool::True,  '<= true');
is(1 >= 0, Bool::True,  '>= true');
is(1 < 0,  Bool::False, '< false');
is(1 > 2,  Bool::False, '> false');
is(1 <= 0, Bool::False, '<= false');
is(1 >= 2, Bool::False, '>= false');

## string relationals ( lt, gt, le, ge )

ok('a' lt 'b', 'a is less than b');
ok(!('b' lt 'a'), 'b is ~not~ less than a');

ok('b' gt 'a', 'b is greater than a');
ok(!('a' gt 'b'), 'a is ~not~ greater than b');

ok('a' le 'b', 'a is less than or equal to b');
ok('a' le 'a', 'a is less than or equal to a');
ok(!('b' le 'a'), 'b is ~not~ less than or equal to a');

ok('b' ge 'a', 'b is greater than or equal to a');
ok('b' ge 'b', 'b is greater than or equal to b');
ok(!('b' ge 'c'), 'b is ~not~ greater than or equal to c');

# +'a' is 0. This means 1 is less than 'a' in numeric context but not string
ok(!('a' lt '1'), 'lt uses string context');
ok(!('a' le '1'), 'le uses string context (1)');
ok(!('a' le '0'), 'le uses string context (2)');
ok('a' gt '1',    'gt uses string context');
ok('a' ge '1',    'ge uses string context (1)');
ok('a' ge '0',    'ge uses string context (2)');

# Ensure that these operators actually return Bool::True or Bool::False
is('b' lt 'c', Bool::True,  'lt true');
is('b' gt 'a', Bool::True,  'gt true');
is('b' le 'c', Bool::True,  'le true');
is('b' ge 'a', Bool::True,  'ge true');
is('b' lt 'a', Bool::False, 'lt false');
is('b' gt 'c', Bool::False, 'gt false');
is('b' le 'a', Bool::False, 'le false');
is('b' ge 'c', Bool::False, 'ge false');

## Multiway comparisons (RFC 025)
# L

ok(5 > 4 > 3, "chained >");
ok(3 < 4 < 5, "chained <");
ok(5 == 5 > -5, "chained mixed = and > ");
ok(!(3 > 4 < 5), "chained > and <");
ok(5 <= 5 > -5, "chained <= and >");
ok(-5 < 5 >= 5, "chained < and >=");

is(5 > 1 < 10, 5 > 1 && 1 < 10, 'chained 5 > 1 < 10');
is(5 < 1 < 10, 5 < 1 && 1 < 10, 'chained 5 < 1 < 10');

ok('e' gt 'd' gt 'c', "chained gt");
ok('c' lt 'd' lt 'e', "chained lt");
ok('e' eq 'e' gt 'a', "chained mixed = and gt ");
ok(!('c' gt 'd' lt 'e'), "chained gt and lt");
ok('e' le 'e' gt 'a', "chained le and gt");
ok('a' lt 'e' ge 'e', "chained lt and ge");

is('e' gt 'a' lt 'j', 'e' gt 'a' && 'a' lt 'j', 'e gt a lt j');
is('e' lt 'a' lt 'j', 'e' lt 'a' && 'a' lt 'j', 'e lt a lt j');

ok("5" gt "4" gt "3", "5 gt 4 gt 3 chained str comparison");
ok("3" lt "4" lt "5", "3 lt 4 gt 5 chained str comparison");
ok(!("3" gt "4" lt "5"), "!(3 gt 4 lt 5) chained str comparison");
ok("5" eq "5" gt "0", '"5" eq "5" gt "0" chained str comparison with equality');
ok("5" le "5" gt "0", "5 le 5 gt 0 chained str comparison with le");
ok("0" lt "5" ge "5", "0 lt 5 ge 5 chained comparison with ge");

# make sure we don't have "padding" or "trimming" semantics
ok("a" lt "a\0", 'a lt a\0');
ok("a" lt "a ", 'a lt a\x20');
ok("a\0" gt "a", 'a\0 gt a');
ok("a " gt "a", 'a\x20 gt a');

# test NaN relational ops
is(NaN == 1, Bool::False, 'NaN == 1');
is(NaN <  1, Bool::False, 'NaN <  1');
is(NaN <= 1, Bool::False, 'NaN <= 1');
is(NaN >  1, Bool::False, 'NaN >  1');
is(NaN >= 1, Bool::False, 'NaN >= 1');
is(NaN != 1, Bool::True,  'NaN != 1');

is(1 == NaN, Bool::False, '1 == NaN');
is(1 <  NaN, Bool::False, '1 <  NaN');
is(1 <= NaN, Bool::False, '1 <= NaN');
is(1 >  NaN, Bool::False, '1 >  NaN');
is(1 >= NaN, Bool::False, '1 >= NaN');
is(1 != NaN, Bool::True,  '1 != NaN');

is(NaN == NaN, Bool::False, 'NaN == NaN');
is(NaN <  NaN, Bool::False, 'NaN <  NaN');
is(NaN <= NaN, Bool::False, 'NaN <= NaN');
is(NaN >  NaN, Bool::False, 'NaN >  NaN');
is(NaN >= NaN, Bool::False, 'NaN >= NaN');
is(NaN != NaN, Bool::True,  'NaN != NaN');

# regression test for rakudo failure 2012-07-08 (pmichaud)
# Int,Rat comparisons
is(7 == 2.4, False, 'Int == Rat');
is(7 != 2.4, True , 'Int != Rat');
is(7 <  2.4, False, 'Int <  Rat');
is(7 <= 2.4, False, 'Int <= Rat');
is(7 >  2.4, True , 'Int >  Rat');
is(7 >= 2.4, True , 'Int >= Rat');
#?pugs skip 'Order enum'
is(7 <=> 2.4, Order::More, 'Int <=> Rat');

# Rat,Int comparisons
is(2.4 == 7, False, 'Rat == Int');
is(2.4 != 7, True , 'Rat != Int');
is(2.4 <  7, True , 'Rat <  Int');
is(2.4 <= 7, True , 'Rat <= Int');
is(2.4 >  7, False, 'Rat >  Int');
is(2.4 >= 7, False, 'Rat >= Int');
#?pugs skip 'Order enum'
is(2.4 <=> 7, Order::Less, 'Rat <=> Int');

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/repeat.t0000664000175000017500000000640412224265625020040 0ustar  moritzmoritzuse v6;

use Test;

=begin description

Repeat operators for strings and lists

=end description

plan 32;

#L

is('a' x 3, 'aaa', 'string repeat operator works on single character');
is('ab' x 4, 'abababab', 'string repeat operator works on multiple character');
is(1 x 5, '11111', 'number repeat operator works on number and creates string');
is('' x 6, '', 'repeating an empty string creates an empty string');
is('a' x 0, '', 'repeating zero times produces an empty string');
is('a' x -1, '', 'repeating negative times produces an empty string');
is 'a' x 2.2, 'aa', 'repeating with a fractional number coerces to Int';
# RT #114670
is 'str' x Int, '', 'x with Int type object';

#L
my @foo = 'x' xx 10;
is(@foo[0], 'x', 'list repeat operator created correct array');
is(@foo[9], 'x', 'list repeat operator created correct array');
is(+@foo, 10, 'list repeat operator created array of the right size');

lives_ok { my @foo2 = Mu xx 2; }, 'can repeat Mu';
my @foo3 = (1, 2) xx 2;
is(@foo3[0], 1, 'can repeat lists');
is(@foo3[1], 2, 'can repeat lists');
is(@foo3[2], 1, 'can repeat lists');
is(@foo3[3], 2, 'can repeat lists');

my @foo4 = 'x' xx 0;
is(+@foo4, 0, 'repeating zero times produces an empty list');

my @foo5 = 'x' xx -1;
is(+@foo5, 0, 'repeating negative times produces an empty list');

my @foo_2d = [1, 2] xx 2; # should create 2d
#?pugs todo 'bug'
is(@foo_2d[1], [1, 2], 'can create 2d arrays'); # creates a flat 1d array
# Wrong/unsure: \(1, 2) does not create a ref to the array/list (1,2), but
# returns a list containing two references, i.e. (\1, \2).
#my @foo_2d2 = \(1, 2) xx 2; # just in case it's a parse bug
##?pugs todo 'bug'
#is(@foo_2d[1], [1, 2], 'can create 2d arrays (2)'); # creates a flat 1d array

# test x=
my $twin = 'Lintilla';
ok($twin x= 2, 'operator x= for string works');
is($twin, 'LintillaLintilla', 'operator x= for string repeats correct');

{
    my @array = (4, 2);
    ok(@array xx= 2, 'operator xx= for list works');
    is(@array[0], 4, 'operator xx= for list repeats correct');
    is(@array[3], 2, 'operator xx= for list repeats correct');
    is(+@array, 4, 'operator xx= for list created the right size');
}

# test that xx actually creates independent items
#?DOES 4
{
    my @a = 'a' xx 3;
    is @a.join('|'), 'a|a|a', 'basic infix:';
    @a[0] = 'b';
    is @a.join('|'), 'b|a|a', 'change to one item left the others unchanged';

    my @b =  xx 3;
    is @b.join('|'), 'x|y|x|y|x|y', 'basic sanity with  xx 3';
    @b[0] = 'z';
    @b[3] = 'a';
    is @b.join('|'), 'z|y|x|a|x|y', 'change to one item left the others unchanged';
}


# tests for non-number values on rhs of xx (RT #76720)
#?DOES 2
{
    # make sure repeat numifies rhs, but respects whatever
    my @a = ;
    is(("a" xx @a).join('|'), 'a|a|a', 'repeat properly numifies rhs');

    my @b =  Z (1 xx *);
    #?pugs todo
    is(@b.join('|'), 'a|1|b|1|c|1', 'xx understands Whatevers');
}

# RT #101446
# xxx now thunks the LHS
#?pugs skip 'xx thunks the LHS'
{
    my @a = ['a'] xx 3;
    @a[0][0] = 'b';
    is @a[1][0], 'a', 'xx thunks the LHS';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/scalar-assign.t0000664000175000017500000000103312224265625021300 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# old: L
# L

{
    my $x = 15;
    my $y = 1;
    ($x = $y) = 5;
    is $x, 5, 'order of assignment respected (1)';
    is $y, 1, 'order of assignment respected (2)';
    $x = $y = 7;
    is $y, 7, 'assignment is right-associative';
}

# From p5 "perldoc perlop"
{
    my $x = 1;
    ($x += 2) *= 3;
    is $x, 9, 'lvalue expressions are only evaluated once';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/set.t0000664000175000017500000005256512224265625017364 0ustar  moritzmoritzuse v6;
use Test;

plan 296;

sub showset($s) { $s.keys.sort.join(' ') }
sub showkv($x) { $x.keys.sort.map({ $^k ~ ':' ~ $x{$k} }).join(' ') }

my $s = set ;
my $ks = SetHash.new(); # Tom Stoppard
my $b = bag ; # Seamus Heaney
my $kb = BagHash.new(); # Ecclesiastes 9:7

# Is an element of

ok "afraid" ∈ $s, "afraid is an element of Set";
ok "afraid" ∈ $ks, "afraid is an element of SetHash";
ok "earthly" ∈ $b, "earthly is an element of Bag";
ok "your" ∈ $kb, "heaven is an element of BagHash";
ok "d" ∈ , "d is an element of a b c d e";

ok "afraid" (elem) $s, "afraid is an element of Set (texas)";
ok "afraid" (elem) $ks, "afraid is an element of SetHash (texas)";
ok "earthly" (elem) $b, "earthly is an element of Bag (texas)";
ok "your" (elem) $kb, "heaven is an element of BagHash (texas)";
ok "d" (elem) , "d is an element of a b c d e (texas)";

# Is not an element of

ok "marmoset" ∉ $s, "marmoset is not an element of Set";
ok "marmoset" ∉ $ks, "marmoset is not an element of SetHash";
ok "marmoset" ∉ $b, "marmoset is not an element of Bag";
ok "marmoset" ∉ $kb, "marmoset is not an element of BagHash";
ok "marmoset" ∉ , "marmoset is not an element of a b c d e";

ok "hogwash" !(elem) $s, "hogwash is not an element of Set (texas)";
ok "hogwash" !(elem) $ks, "hogwash is not an element of SetHash (texas)";
ok "hogwash" !(elem) $b, "hogwash is not an element of Bag (texas)";
ok "hogwash" !(elem) $kb, "hogwash is not an element of BagHash (texas)";
ok "hogwash" !(elem) , "hogwash is not an element of a b c d e (texas)";

# Contains

ok $s ∋ "afraid", "afraid is contained by Set";
ok $ks ∋ "afraid", "afraid is contained by SetHash";
ok $b ∋ "earthly", "earthly is contained by Bag";
ok $kb ∋ "your", "heaven is contained by BagHash";
ok  ∋ "d", "d is contained by a b c d e";

ok $s (cont) "afraid", "afraid is contained by Set";
ok $ks (cont) "afraid", "afraid is contained by SetHash";
ok $b (cont) "earthly", "earthly is contained by Bag";
ok $kb (cont) "your", "heaven is contained by BagHash";
ok  (cont) "d", "d is contained by a b c d e";

# Does not contain

ok $s ∌ "marmoset", "marmoset is not contained by Set";
ok $ks ∌ "marmoset", "marmoset is not contained by SetHash";
ok $b ∌ "marmoset", "marmoset is not contained by Bag";
ok $kb ∌ "marmoset", "marmoset is not contained by BagHash";
ok  ∌ "marmoset", "marmoset is not contained by a b c d e";

ok $s !(cont) "marmoset", "marmoset is not contained by Set";
ok $ks !(cont) "marmoset", "marmoset is not contained by SetHash";
ok $b !(cont) "marmoset", "marmoset is not contained by Bag";
ok $kb !(cont) "marmoset", "marmoset is not contained by BagHash";
ok  !(cont) "marmoset", "marmoset is not contained by a b c d e";

# Union

is showset($s ∪ $s), showset($s), "Set union with itself yields self";
isa_ok ($s ∪ $s), Set, "... and it's actually a Set";
is showset($ks ∪ $ks), showset($ks), "SetHash union with itself yields self (as Set)";
isa_ok ($ks ∪ $ks), Set, "... and it's actually a Set";

is showset($s ∪ $ks), showset(set ), "Set union with SetHash works";
isa_ok ($s ∪ $ks), Set, "... and it's actually a Set";
is showset($ks ∪ ), showset(set ), "SetHash union with array of strings works";
isa_ok ($ks ∪ ), Set, "... and it's actually a Set";

is showset($s (|) $ks), showset(set ), "Set union with SetHash works (texas)";
isa_ok ($s (|) $ks), Set, "... and it's actually a Set (texas)";
is showset($ks (|) ), showset(set ), "SetHash union with array of strings works (texas)";
isa_ok ($ks (|) ), Set, "... and it's actually a Set (texas)";

# Intersection

is showset($s ∩ $s), showset($s), "Set intersection with itself yields self";
isa_ok ($s ∩ $s), Set, "... and it's actually a Set";
is showset($ks ∩ $ks), showset($ks), "SetHash intersection with itself yields self (as Set)";
isa_ok ($ks ∩ $ks), Set, "... and it's actually a Set";
is showset($s ∩ $ks), showset(set ), "Set intersection with SetHash works";
isa_ok ($s ∩ $ks), Set, "... and it's actually a Set";

is showset($s (&) $ks), showset(set ), "Set intersection with SetHash works (texas)";
isa_ok ($s (&) $ks), Set, "... and it's actually a Set (texas)";

# set subtraction

#?rakudo skip "∅ NYI"
is showset($s (-) $s), showset(∅), "Set subtracted from Set is correct";
isa_ok ($s (-) $s), Set, "... and it's actually a Set";

is showset($s (-) $ks), showset(set ), "SetHash subtracted from Set is correct";
isa_ok ($s (-) $ks), Set, "... and it's actually a Set";
is showset($ks (-) $s), showset(set ), "Set subtracted from SetHash is correct";
isa_ok ($ks (-) $s), Set, "... and it's actually a Set";

is showkv($b (-) $s), showkv($b), "Set subtracted from Bag is correct";
isa_ok ($b (-) $s), Bag, "... and it's actually a Bag";
is showset($s (-) $b), showset($s), "Bag subtracted from Set is correct";
isa_ok ($s (-) $b), Set, "... and it's actually a Set";

is showset($s (-) $kb), showset(set ), "BagHash subtracted from Set is correct";
isa_ok ($s (-) $kb), Set, "... and it's actually a Set";
is showkv($kb (-) $s), showkv(.Bag), "Set subtracted from BagHash is correct";
isa_ok ($kb (-) $s), Bag, "... and it's actually a Bag";

# symmetric difference

#?rakudo skip "∅ NYI"
is showset($s (^) $s), showset(∅), "Set symmetric difference with Set is correct";
isa_ok ($s (^) $s), Set, "... and it's actually a Set";

is showset($s (^) $ks), showset(set ), "SetHash symmetric difference with Set is correct";
isa_ok ($s (^) $ks), Set, "... and it's actually a Set";
is showset($ks (^) $s), showset(set ), "Set symmetric difference with SetHash is correct";
isa_ok ($ks (^) $s), Set, "... and it's actually a Set";

is showset($s (^) $b), showset($s (|) $b), "Bag symmetric difference with Set is correct";
isa_ok ($s (^) $b), Set, "... and it's actually a Set";
is showset($b (^) $s), showset($s (|) $b), "Set symmetric difference with Bag is correct";
isa_ok ($b (^) $s), Set, "... and it's actually a Set";

#?niecza todo "Test is wrong, implementation is wrong"
#?rakudo todo 'huh?'
is showset($s (^) $kb), showset(($s (|) $kb) (-) set ), "BagHash subtracted from Set is correct";
isa_ok ($s (^) $kb), Set, "... and it's actually a Set";
#?niecza todo "Test is wrong, implementation is wrong"
#?rakudo todo 'huh?'
is showset($kb (^) $s), showset(($s (|) $kb) (-) set ), "Set subtracted from BagHash is correct";
isa_ok ($kb (^) $s), Set, "... and it's actually a Set";

# is subset of

ok  ⊆ $s, "'Your day' is subset of Set";
ok $s ⊆ $s, "Set is subset of itself";
ok $s ⊆ , "Set is subset of string";

ok ($ks (-) set ) ⊆ $ks, "Set is subset of SetHash";
ok $ks ⊆ $ks, "SetHash is subset of itself";
ok $ks ⊆ , "SetHash is subset of string";

nok $s ⊆ $b, "Set is not a subset of Bag";
ok $b ⊆ $b, "Bag is subset of itself";
nok $b ⊆ $s, "Bag is not a subset of Set";

nok $s ⊆ $kb, "Set is not a subset of BagHash";
ok $kb ⊆ $kb, "BagHash is subset of itself";
nok $kb ⊆ $s, "BagHash is not a subset of Set";

ok  (<=) $s, "'Your day' is subset of Set";
ok $s (<=) $s, "Set is subset of itself";
ok $s (<=) , "Set is subset of string";

ok ($ks (-) set ) (<=) $ks, "Set is subset of SetHash (texas)";
ok $ks (<=) $ks, "SetHash is subset of itself (texas)";
ok $ks (<=) , "SetHash is subset of string (texas)";

nok $s (<=) $b, "Set is not a subset of Bag (texas)";
ok $b (<=) $b, "Bag is subset of itself (texas)";
nok $b (<=) $s, "Bag is not a subset of Set (texas)";

nok $s (<=) $kb, "Set is not a subset of BagHash (texas)";
ok $kb (<=) $kb, "BagHash is subset of itself (texas)";
nok $kb (<=) $s, "BagHash is not a subset of Set (texas)";

# is not a subset of
nok  ⊈ $s, "'Your day' is subset of Set";
nok $s ⊈ $s, "Set is subset of itself";
nok $s ⊈ , "Set is subset of string";

nok ($ks (-) set ) ⊈ $ks, "Set is subset of SetHash";
nok $ks ⊈ $ks, "SetHash is subset of itself";
nok $ks ⊈ , "SetHash is subset of string";

ok $s ⊈ $b, "Set is not a subset of Bag";
nok $b ⊈ $b, "Bag is subset of itself";
ok $b ⊈ $s, "Bag is not a subset of Set";

ok $s ⊈ $kb, "Set is not a subset of BagHash";
nok $kb ⊈ $kb, "BagHash is subset of itself";
ok $kb ⊈ $s, "BagHash is not a subset of Set";

nok  !(<=) $s, "'Your day' is subset of Set (texas)";
nok $s !(<=) $s, "Set is subset of itself (texas)";
nok $s !(<=) , "Set is subset of string (texas)";

nok ($ks (-) set ) !(<=) $ks, "Set is subset of SetHash (texas)";
nok $ks !(<=) $ks, "SetHash is subset of itself (texas)";
nok $ks !(<=) , "SetHash is subset of string (texas)";

ok $s !(<=) $b, "Set is not a subset of Bag (texas)";
nok $b !(<=) $b, "Bag is subset of itself (texas)";
ok $b !(<=) $s, "Bag is not a subset of Set (texas)";

ok $s !(<=) $kb, "Set is not a subset of BagHash (texas)";
nok $kb !(<=) $kb, "BagHash is subset of itself (texas)";
ok $kb !(<=) $s, "BagHash is not a subset of Set (texas)";

# is proper subset of

ok  ⊂ $s, "'Your day' is proper subset of Set";
nok $s ⊂ $s, "Set is not proper subset of itself";
ok $s ⊂ , "Set is proper subset of string";

ok ($ks (-) set ) ⊂ $ks, "Set is proper subset of SetHash";
nok $ks ⊂ $ks, "SetHash is not proper subset of itself";
ok $ks ⊂ , "SetHash is proper subset of string";

nok $s ⊂ $b, "Set is not a proper subset of Bag";
nok $b ⊂ $b, "Bag is not proper subset of itself";
nok $b ⊂ $s, "Bag is not a proper subset of Set";

nok $s ⊂ $kb, "Set is not a proper subset of BagHash";
nok $kb ⊂ $kb, "BagHash is not proper subset of itself";
nok $kb ⊂ $s, "BagHash is not a proper subset of Set";

ok  (<) $s, "'Your day' is proper subset of Set";
nok $s (<) $s, "Set is not proper subset of itself";
ok $s (<) , "Set is proper subset of string";

ok ($ks (-) set ) (<) $ks, "Set is proper subset of SetHash (texas)";
nok $ks (<) $ks, "SetHash is not proper subset of itself (texas)";
ok $ks (<) , "SetHash is proper subset of string (texas)";

nok $s (<) $b, "Set is not a proper subset of Bag (texas)";
nok $b (<) $b, "Bag is not proper subset of itself (texas)";
nok $b (<) $s, "Bag is not a proper subset of Set (texas)";

nok $s (<) $kb, "Set is not a proper subset of BagHash (texas)";
nok $kb (<) $kb, "BagHash is not proper subset of itself (texas)";
nok $kb (<) $s, "BagHash is not a proper subset of Set (texas)";

# is not a proper subset of

nok  ⊄ $s, "'Your day' is proper subset of Set";
ok $s ⊄ $s, "Set is not proper subset of itself";
nok $s ⊄ , "Set is proper subset of string";

nok ($ks (-) set ) ⊄ $ks, "Set is proper subset of SetHash";
ok $ks ⊄ $ks, "SetHash is not proper subset of itself";
nok $ks ⊄ , "SetHash is proper subset of string";

ok $s ⊄ $b, "Set is not a proper subset of Bag";
ok $b ⊄ $b, "Bag is not proper subset of itself";
ok $b ⊄ $s, "Bag is not a proper subset of Set";

ok $s ⊄ $kb, "Set is not a proper subset of BagHash";
ok $kb ⊄ $kb, "BagHash is not proper subset of itself";
ok $kb ⊄ $s, "BagHash is not a proper subset of Set";

nok  !(<) $s, "'Your day' is proper subset of Set (texas)";
ok $s !(<) $s, "Set is not proper subset of itself (texas)";
nok $s !(<) , "Set is proper subset of string (texas)";

nok ($ks (-) set ) !(<) $ks, "Set is proper subset of SetHash (texas)";
ok $ks !(<) $ks, "SetHash is not proper subset of itself (texas)";
nok $ks !(<) , "SetHash is proper subset of string (texas)";

ok $s !(<) $b, "Set is not a proper subset of Bag (texas)";
ok $b !(<) $b, "Bag is not proper subset of itself (texas)";
ok $b !(<) $s, "Bag is not a proper subset of Set (texas)";

ok $s !(<) $kb, "Set is not a proper subset of BagHash (texas)";
ok $kb !(<) $kb, "BagHash is not proper subset of itself (texas)";
ok $kb !(<) $s, "BagHash is not a proper subset of Set (texas)";

# is superset of

ok  R⊇ $s, "'Your day' is reversed superset of Set";
ok $s R⊇ $s, "Set is reversed superset of itself";
ok $s R⊇ , "Set is reversed superset of string";

ok ($ks (-) set ) R⊇ $ks, "Set is reversed superset of SetHash";
ok $ks R⊇ $ks, "SetHash is reversed superset of itself";
ok $ks R⊇ , "SetHash is reversed superset of string";

nok $s R⊇ $b, "Set is not a reversed superset of Bag";
ok $b R⊇ $b, "Bag is reversed superset of itself";
nok $b R⊇ $s, "Bag is not a reversed superset of Set";

nok $s R⊇ $kb, "Set is not a reversed superset of BagHash";
ok $kb R⊇ $kb, "BagHash is reversed superset of itself";
nok $kb R⊇ $s, "BagHash is not a reversed superset of Set";

ok  R(>=) $s, "'Your day' is reversed superset of Set";
ok $s R(>=) $s, "Set is reversed superset of itself";
ok $s R(>=) , "Set is reversed superset of string";

ok ($ks (-) set ) R(>=) $ks, "Set is reversed superset of SetHash (texas)";
ok $ks R(>=) $ks, "SetHash is reversed superset of itself (texas)";
ok $ks R(>=) , "SetHash is reversed superset of string (texas)";

nok $s R(>=) $b, "Set is not a reversed superset of Bag (texas)";
ok $b R(>=) $b, "Bag is reversed superset of itself (texas)";
nok $b R(>=) $s, "Bag is not a reversed superset of Set (texas)";

nok $s R(>=) $kb, "Set is not a reversed superset of BagHash (texas)";
ok $kb R(>=) $kb, "BagHash is reversed superset of itself (texas)";
nok $kb R(>=) $s, "BagHash is not a reversed superset of Set (texas)";

# is not a superset of

nok  R⊉ $s, "'Your day' is reversed superset of Set";
nok $s R⊉ $s, "Set is reversed superset of itself";
nok $s R⊉ , "Set is reversed superset of string";

nok ($ks (-) set ) R⊉ $ks, "Set is reversed superset of SetHash";
nok $ks R⊉ $ks, "SetHash is reversed superset of itself";
nok $ks R⊉ , "SetHash is reversed superset of string";

ok $s R⊉ $b, "Set is not a reversed superset of Bag";
nok $b R⊉ $b, "Bag is reversed superset of itself";
ok $b R⊉ $s, "Bag is not a reversed superset of Set";

ok $s R⊉ $kb, "Set is not a reversed superset of BagHash";
nok $kb R⊉ $kb, "BagHash is reversed superset of itself";
ok $kb R⊉ $s, "BagHash is not a reversed superset of Set";

nok  !R(>=) $s, "'Your day' is reversed superset of Set (texas)";
nok $s !R(>=) $s, "Set is reversed superset of itself (texas)";
nok $s !R(>=) , "Set is reversed superset of string (texas)";

nok ($ks (-) set ) !R(>=) $ks, "Set is reversed superset of SetHash (texas)";
nok $ks !R(>=) $ks, "SetHash is reversed superset of itself (texas)";
nok $ks !R(>=) , "SetHash is reversed superset of string (texas)";

ok $s !R(>=) $b, "Set is not a reversed superset of Bag (texas)";
nok $b !R(>=) $b, "Bag is reversed superset of itself (texas)";
ok $b !R(>=) $s, "Bag is not a reversed superset of Set (texas)";

ok $s !R(>=) $kb, "Set is not a reversed superset of BagHash (texas)";
nok $kb !R(>=) $kb, "BagHash is reversed superset of itself (texas)";
ok $kb !R(>=) $s, "BagHash is not a reversed superset of Set (texas)";

# is proper superset of

ok  R⊃ $s, "'Your day' is reversed proper superset of Set";
nok $s R⊃ $s, "Set is not reversed proper superset of itself";
ok $s R⊃ , "Set is reversed proper superset of string";

ok ($ks (-) set ) R⊃ $ks, "Set is reversed proper superset of SetHash";
nok $ks R⊃ $ks, "SetHash is not reversed proper superset of itself";
ok $ks R⊃ , "SetHash is reversed proper superset of string";

nok $s R⊃ $b, "Set is not a reversed proper superset of Bag";
nok $b R⊃ $b, "Bag is not reversed proper superset of itself";
nok $b R⊃ $s, "Bag is not a reversed proper superset of Set";

nok $s R⊃ $kb, "Set is not a reversed proper superset of BagHash";
nok $kb R⊃ $kb, "BagHash is not reversed proper superset of itself";
nok $kb R⊃ $s, "BagHash is not a reversed proper superset of Set";

ok  R(>) $s, "'Your day' is reversed proper superset of Set";
nok $s R(>) $s, "Set is not reversed proper superset of itself";
ok $s R(>) , "Set is reversed proper superset of string";

ok ($ks (-) set ) R(>) $ks, "Set is reversed proper superset of SetHash (texas)";
nok $ks R(>) $ks, "SetHash is not reversed proper superset of itself (texas)";
ok $ks R(>) , "SetHash is reversed proper superset of string (texas)";

nok $s R(>) $b, "Set is not a reversed proper superset of Bag (texas)";
nok $b R(>) $b, "Bag is not reversed proper superset of itself (texas)";
nok $b R(>) $s, "Bag is not a reversed proper superset of Set (texas)";

nok $s R(>) $kb, "Set is not a reversed proper superset of BagHash (texas)";
nok $kb R(>) $kb, "BagHash is not reversed proper superset of itself (texas)";
nok $kb R(>) $s, "BagHash is not a reversed proper superset of Set (texas)";

# is not a proper superset of

nok  R⊅ $s, "'Your day' is reversed proper superset of Set";
ok $s R⊅ $s, "Set is not reversed proper superset of itself";
nok $s R⊅ , "Set is reversed proper superset of string";

nok ($ks (-) set ) R⊅ $ks, "Set is reversed proper superset of SetHash";
ok $ks R⊅ $ks, "SetHash is not reversed proper superset of itself";
nok $ks R⊅ , "SetHash is reversed proper superset of string";

ok $s R⊅ $b, "Set is not a reversed proper superset of Bag";
ok $b R⊅ $b, "Bag is not reversed proper superset of itself";
ok $b R⊅ $s, "Bag is not a reversed proper superset of Set";

ok $s R⊅ $kb, "Set is not a reversed proper superset of BagHash";
ok $kb R⊅ $kb, "BagHash is not reversed proper superset of itself";
ok $kb R⊅ $s, "BagHash is not a reversed proper superset of Set";

nok  !R(>) $s, "'Your day' is reversed proper superset of Set (texas)";
ok $s !R(>) $s, "Set is not reversed proper superset of itself (texas)";
nok $s !R(>) , "Set is reversed proper superset of string (texas)";

nok ($ks (-) set ) !R(>) $ks, "Set is reversed proper superset of SetHash (texas)";
ok $ks !R(>) $ks, "SetHash is not reversed proper superset of itself (texas)";
nok $ks !R(>) , "SetHash is reversed proper superset of string (texas)";

ok $s !R(>) $b, "Set is not a reversed proper superset of Bag (texas)";
ok $b !R(>) $b, "Bag is not reversed proper superset of itself (texas)";
ok $b !R(>) $s, "Bag is not a reversed proper superset of Set (texas)";

ok $s !R(>) $kb, "Set is not a reversed proper superset of BagHash (texas)";
ok $kb !R(>) $kb, "BagHash is not reversed proper superset of itself (texas)";
ok $kb !R(>) $s, "BagHash is not a reversed proper superset of Set (texas)";

#?rakudo skip 'Reduction and set operators'
{
    my $a = set ;
    my $b = set ;
    my $c = [];
    my @d;
    
    is showset([∪] @d), showset(∅), "Union reduce works on nothing";
    is showset([∪] $a), showset($a), "Union reduce works on one set";
    is showset([∪] $a, $b), showset(set($a.keys, $b.keys)), "Union reduce works on two sets";
    is showset([∪] $a, $b, $c), showset(set($a.keys, $b.keys, $c.values)), "Union reduce works on three sets";

    is showset([(|)] @d), showset(∅), "Union reduce works on nothing (texas)";
    is showset([(|)] $a), showset($a), "Union reduce works on one set (texas)";
    is showset([(|)] $a, $b), showset(set($a.keys, $b.keys)), "Union reduce works on two sets (texas)";
    is showset([(|)] $a, $b, $c), showset(set($a.keys, $b.keys, $c.values)), "Union reduce works on three sets (texas)";

    is showset([∩] @d), showset(∅), "Intersection reduce works on nothing";
    is showset([∩] $a), showset($a), "Intersection reduce works on one set";
    is showset([∩] $a, $b), showset(set("Apollo")), "Intersection reduce works on two sets";
    is showset([∩] $a, $b, $c), showset(set("Apollo")), "Intersection reduce works on three sets";

    is showset([(&)] @d), showset(∅), "Intersection reduce works on nothing (texas)";
    is showset([(&)] $a), showset($a), "Intersection reduce works on one set (texas)";
    is showset([(&)] $a, $b), showset(set("Apollo")), "Intersection reduce works on two sets (texas)";
    is showset([(&)] $a, $b, $c), showset(set("Apollo")), "Intersection reduce works on three sets (texas)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/short-circuit.t0000664000175000017500000001775112224265625021366 0ustar  moritzmoritzuse v6;

use Test;

=begin description

Tests that || and && and // really short circuit, and do not call their
rhs when the lhs is enough to deduce the result.

Also, test new ^^ operator here: even though it does not short circuit,
it is closely related to || and && and //.

=end description

plan 83;

my $accum = '';
sub f1($s)   { $accum ~= $s; 1 }
sub f0($s)   { $accum ~= $s; 0 }
sub fAny($s) { $accum ~= $s; Any }

#?DOES 1
sub accumtest($expect, $op) {
    is $accum, $expect, "$op operator short circuiting exactly when needed";
    $accum = '';
}

{
    my $x = 1;
    my $y = 2;
    $x == 1 || ($y = 42);

    is($y, 2, "|| operator short circuiting");

    f0('a') || f0('b') || f1('c') || f0('d') || f1('e');
    accumtest 'abc', '||';
}

{
    my $x = 1;
    my $y = 2;
    $x == 1 or $y = 42;

    is($y, 2, "'or' operator short circuiting");

    f0('a') or f0('b') or f1('c') or f0('d') or f1('e');
    accumtest 'abc', "'or'";
}

{
    my $x = 1;
    my $y = 2;
    $x != 1 && ($y = 42);

    is($y, 2, "&& operator short circuiting");

    f1('a') && f1('b') && f1('c') && f0('d') && f1('e');
    accumtest 'abcd', '&&';
}

{
    my $x = 1;
    my $y = 2;
    $x != 1 and $y = 42;

    is($y, 2, "'and' operator short circuiting");

    f1('a') and f1('b') and f1('c') and f0('d') and f1('e');
    accumtest 'abcd', "'and'";
}

{
    my $x = 1;
    my $y = 2;
    $x // ($y = 42);

    is($y, 2, "// operator short circuiting");

    fAny('a') // fAny('b') // f0('c') // f1('d') // fAny('e');
    accumtest 'abc', '//';

    fAny('a') // f1('b') // f0('c');
    accumtest 'ab', '//';
}

{
    my $x = 1;
    my $y = 2;
    $x orelse $y = 42;

    is($y, 2, "'orelse' operator short circuiting");

    fAny('a') orelse fAny('b') orelse f0('c') orelse f1('d') orelse fAny('e');
    accumtest 'abc', "'orelse'";

    fAny('a') orelse f1('b') orelse f0('c');
    accumtest 'ab', "'orelse'";
}

{
    my $x;      # should be Mu
    my $y = 2;
    $x // ($y = 42);

    is($y, 42, "// operator working");
}

{
    my $x;      # should be Mu
    my $y = 2;
    $x orelse $y = 42;

    is($y, 42, "'orelse' operator working");
}

#?niecza skip "^^ NYI"
#?pugs skip '^^ short circuit'
{
    my $x;      # should be Mu
    my $y = 2;
    $x ^^ ($y = 42);

    is($y, 42, "^^ operator not short circuiting");

    $x = 0;
    1 ^^ 2 ^^ ($x = 5);
    is($x, 0, "^^ operator short circuiting");

    f0('a') ^^ f0('b') ^^ f1('c') ^^ f0('d') ^^
        f0('e') ^^ f1('f') ^^ f0('g') ^^ f0('h');
    accumtest 'abcdef', '^^';
}

#?niecza skip "xor NYI"
#?pugs skip "xor shortcircuit"
{
    my $x;      # should be Mu
    my $y = 2;
    $x xor $y = 42;

    is($y, 42, "xor operator not short circuiting");

    $x = 0;
    1 xor 2 xor ($x = 5);
    is($x, 0, "xor operator short circuiting");

    f0('a') xor f0('b') xor f1('c') xor f0('d') xor
        f0('e') xor f1('f') xor f0('g') xor f0('h');
    accumtest 'abcdef', 'xor';
}

{
    is(1 && 42,        42, "&&   operator working");
    is((1 and 42),     42, "and  operator working");

    is(0 || 42,        42, "||   operator working");
    is((0 or 42),      42, "or   operator working");

    is((Mu // 42),  42, "//   operator working"); #"
    is((Mu orelse 42), 42, "orelse  operator working");

    #?niecza 10 skip "^^ xor NYI"
    is(0 ^^ 42,        42, "^^  operator working (one true)");
    is(42 ^^ 0,        42, "^^  operator working (one true)");
    #?rakudo todo 'wrong return type'
    is(1 ^^ 42,     False, "^^  operator working (both true)");
    #?pugs todo
    is(0 ^^ 0,          0, "^^  operator working (both false)");
    is((0 xor 42),     42, "xor operator working (one true)");
    is((42 xor 0),     42, "xor operator working (one true)");
    is((0 xor 42),     42, "xor operator working (one true)");
    is((42 xor 0),     42, "xor operator working (one true)");
    ok(!(1 xor 42),        "xor operator working (both true)");
    ok(!(0 xor 0),         "xor operator working (both false)");
}

# L
# RT #72826 infix ^^ return wrong types
#?niecza skip "^^ NYI"
{
    is 0 ^^ False ^^ '', '', '^^ given all false values returns last (1)';
    #?pugs todo
    is False ^^ '' ^^ 0, 0, '^^ given all false values returns last (2)';
    is False ^^ 42 ^^ '', 42, '^^ given one true value returns it (1)';
    is 0 ^^ Int ^^ 'plugh', 'plugh', '^^ given one true value returns it (2)';
    #?rakudo todo 'wrong return type'
    is 15 ^^ 0 ^^ 'quux', False, '^^ given two true values returns False (1)';
    #?rakudo todo 'wrong return type'
    is 'a' ^^ 'b' ^^ 0, False, '^^ given two true values returns False (2)';

    #?pugs 6 skip 'xor'
    is (0 xor False xor ''), '', 'xor given all false values returns last (1)';
    is (False xor '' xor 0), 0, 'xor given all false values returns last (2)';
    is (False xor 42 xor ''), 42, 'xor given one true value returns it (1)';
    is (0 xor Int xor 'plugh'), 'plugh', 'xor given one true value returns it (2)';
    #?rakudo todo 'wrong return type'
    is (15 xor 0 xor 'quux'), False, 'xor given two true values returns False (1)';
    #?rakudo todo 'wrong return type'
    is ('a' xor 'b' xor 0), False, 'xor given two true values returns False (2)';

    #?rakudo todo 'wrong return type'
    isa_ok 7 ^^ 7, Bool, '^^ can return a Bool';
    isa_ok 7 ^^ Mu, Int, '^^ can return an Int';
    #?pugs 2 skip 'Range'
    isa_ok 0 ^^ ^7, Range, '^^ can return a Range';
    isa_ok ^7 ^^ 0, Range, '^^ can return a Range';
    isa_ok 7.5i ^^ Mu, Complex, '^^ can return a Complex';
    isa_ok Inf ^^ Mu, Num, '^^ can return a Num';
    isa_ok 'Inf' ^^ Mu, Str, '^^ can return a Str';

    my @a = (1,2,3);
    my @b = (4,5,6);
    my (@c, @d);

    is (@a ^^ @c), '1 2 3', 'Array ^^ true returns true array';
    is (@c ^^ @a), '1 2 3', 'Array ^^ true returns true array';
    ok (@a ^^ @b) == (), 'Array ^^ true returns empty list';
    ok (@c ^^ @d) == (), 'Array ^^ true returns empty list';
    is (@a ^^ ()), '1 2 3', 'True array ^^ empty list returns array';
    is (() ^^ @a), '1 2 3', 'Empty list ^^ true array returns array';
    ok (() ^^ @c) == (), 'Empty list ^^ empty array returns ()';
}

{
    my $x0 = 0;
    my @a0 = () and $x0 = 1;
    is($x0, 0,    "'and' operator short circuiting");
    ok(+@a0 == 0, "'and' operator working with list assignment");
}

{
    my $x0 = 0;
    my @a0 = () or $x0 = 1;
    is($x0,  1, "'or' operator short circuiting");
    is(+@a0, 0, "'or' operator working with list assignment");
}

# L
{
    my $x = 0;
    my $y = 0;
    #?niecza todo
    ok(($x++ < ++$y < ++$y), "chained comparison (truth - 1)");
    # expect x=1, y=2
    is($y, 2, "chained comparison short-circuit: not re-evaluating middle");
}

# L
{
    my $x = 0;
    my $y = 0;
    ok(not(++$x < $y++ < $y++), "chained comparison (truth - 2)");
    # expect x=1, y=1
    is($y, 1, "chained comparison short-circuit: stopping soon enough");
}

# a pugs regression 

{
    my $a = sub { 1 };
    my $b;
    sub c($code) { if $code and $code() { return 1 }; return 2 }

    is c($a), 1, 'shortcircuit idiom given coderef works';

    # This one will just kill pugs with the cast failure, so force fail
    #?pugs eval 'short circuiting'
    is c($b), 2, 'shortcircuit idiom given Mu works';
}

# a rakudo regression
ok (0 || 0 || 1), '0 || 0 || 1 is true';

# RT #77864
{
    my $x;
    $x &&= 5;
    ok !defined($x), '&&= on a fresh variable works';
    my $y ||= 'moin';
    is $y, 'moin', '||= on a fresh variable works';

}

{
    my $a = 0;
    my $b = 0;
    $a //= ($b = 1);
    is $a, 0, 'basic //=';
    is $b, 0, '//= short-circuits';

    $a = 1;
    $b = 0;
    $a ||= ($b = 2);
    is $a, 1, 'basic ||=';
    is $b, 0, '||= short-circuits';

}

# RT #90158
{
    my @a = 1;
    @a ||= ();
    is ~@a, '1', '||= works with array on the LHS';
}

# RT #116230
{
    my role SomeRole { };
    my $x = SomeRole;
    $x //= SomeRole.new;
    ok $x.defined, '//= can cope with role type objects';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/shortcuts.t0000664000175000017500000000055512224265625020617 0ustar  moritzmoritzuse v6;
use Test;

plan 6;

class C {
  method @.[$i] { $i }
  method %.{$k} { $k }
  method &.($a) { 'karma ' ~ $a }
}

my $o = C.new;
ok  $o.[42] == 42, '@.[]';
ok  $o[42] == 42, '@.[] again';
ok  $o.{'thanks'} eq 'thanks', '%.{}';
ok  $o{'fish'} eq 'fish', '%.{} again';
ok  $o.('gnole') eq 'karma gnole', '@.()';
ok  $o('gnole') eq 'karma gnole', '@.() again';
rakudo-2013.12/t/spec/S03-operators/so.t0000664000175000017500000000133112224265625017173 0ustar  moritzmoritzuse v6;
use Test;
plan 15;

# L

ok(so 1,     "so 1 is true");
ok(so -1,    "so -1 is true");
ok(not so 0,  "not so 0 is true");
ok(so sub{}, 'so sub{} is true');
ok(so "x",   'so "x" is true');

my $a = 1; ok(so $a,    'so $true_var is true');
my $b = 0; ok(!(so $b), 'so $false_var is not true');

ok( so(so 42), "so(so 42) is true");
ok(not so(so 0), "so(so 0) is false");

ok(so Bool::True, "'Bool::True' is true");
#?niecza todo
ok Bool.so === False, 'Bool.so returns false';
ok(so True, "'True' is true");

#?rakudo todo 'check test and rakudo'
is (so($b) + 1), ((so $b) + 1), 'so($b) is (so $b)';

ok (so my $x = 5), 'so + declaration';
is $x, 5, 'assignment after so worked';

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/spaceship-and-containers.t0000664000175000017500000000076612237474612023451 0ustar  moritzmoritzuse v6;

use Test;

plan 6;
#L operator>

my %h = ("a" => 1, "b" => 2);
ok(%h{"a"} < %h{"b"}, 'comparing hash values');
ok(%h{"a"} <= %h{"b"}, 'comparing hash values');
#?pugs skip 'Order::Less'
is(%h{"a"} <=> %h{"b"}, Order::Less, 'comparing hash values');

my @a = (1, 2);
ok(@a[0] < @a[1], 'comparing array values');
ok(@a[0] <= @a[1], 'comparing array values');
#?pugs skip 'Order::Less'
is(@a[0] <=> @a[1], Order::Less, 'comparing array values');

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/spaceship.t0000664000175000017500000000146712237474612020545 0ustar  moritzmoritzuse v6;

use Test;

# L

plan 5;

my %ball = map {; $_ => 1 }, 1..12;
is(
    (%ball{12}) <=> (%ball{11}),
    Order::Same,
    'parens with spaceship parse incorrectly',
);

my $result_1 = ([+] %ball{10..12}) <=> ([+] %ball{1..3});

is($result_1, Order::Same, 'When spaceship terms are non-trivial members it parses incorrectly'); 
my $result_2 = ([+] %ball{11,12}) <=> ([+] %ball{1,2});
is($result_2, Order::Same, 'When spaceship terms are non-trivial members it parses incorrectly'); 
{
my $result_3 = ([0] <=> [0,1]);
is($result_3, Order::Less, 'When spaceship terms are non-trivial members it parses incorrectly'); 
}

%ball{12} = 0.5;
is(%ball{12} <=> %ball{11}, Order::Less, 'When spaceship terms are non-integral numbers it parses incorrectly');

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/subscript-adverbs.t0000664000175000017500000003115012224265625022216 0ustar  moritzmoritzuse v6;

use Test;

plan 108;

# L

# Adverbs on array subscripts
# :p
{
    my @array = ;

    isa_ok @array[0]:p, Pair,
        ":p on an array returned a Pair";
    is ~(@array[0]:p), "0\tA",
        ":p on an array returned the correct pair";

    lives_ok { (@array[0]:p).value = "a" }, 'can assign to (@array[0]:p).value';
    is @array[0], "a",
        ":p on an array returns lvalues (like normal subscripts do as well)";

    is +(@array[0,1]:p), 2,
        ":p on an array returned a two-elem array";
    is ~(@array[0,1]:p), "0\ta 1\tB",
        ":p on an array returned a two-elem array consisting of the correct pairs";

    #?niecza todo 'Cannot use value like Pair as a number'
    is +(@array[42,23]:p),  0, ":p on an array weeded out non-existing entries (1)";
    #?niecza todo
    is ~(@array[42,23]:p), "", ":p on an array weeded out non-existing entries (2)";
} #8

# :kv
{
    my @array = ;

    is +(@array[0]:kv), 2,
        ":kv on an array returned a two-elem array";
    is ~(@array[0]:kv), "0 A",
        ":kv on an array returned the correct two-elem array";

    lives_ok {(@array[0]:kv)[1] = "a"}, 'can assign to :kv subscripts';
    is @array[0], "a",
        ":kv on an array returns lvalues (like normal subscripts do as well)";

    #?niecza todo
    is +(@array[0,1]:kv), 4,
        ":kv on an array returned a four-elem array";
    is ~(@array[0,1]:kv), "0 a 1 B",
        ":kv on an array returned the correct four-elem array";

    #?niecza todo
    is +(@array[42,23]:kv),  0, ":kv on an array weeded out non-existing entries (1)";
    #?niecza todo
    is ~(@array[42,23]:kv), "", ":kv on an array weeded out non-existing entries (2)";
} #8

# :k
{
    my @array = ;

    ok @array[0]:k ~~ Int,
        ":k on an array returned an integer index";
    is ~(@array[0]:k), "0",
        ":k on an array returned the correct index";

    is +(@array[0,1]:k), 2,
        ":k on an array returned a two-elem array";
    is ~(@array[0,1]:k), "0 1",
        ":k on an array returned the correct two-elem array";

    #?niecza todo
    is +(@array[42,23]:k),  0, ":k on an array weeded out non-existing entries (1)";
    #?niecza todo
    is ~(@array[42,23]:k), "", ":k on an array weeded out non-existing entries (2)";
} #6

# :v
{
    my @array = ;

    #?niecza 2 skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    ok @array[0]:v ~~ Str,
        ":v on an array returned the right type of value";
    is ~(@array[0]:v), "A",
        ":v on an array returned the correct value";

    #?niecza todo
    dies_ok {@array[0]:v = "a"}, 'cannot assign to @array[0]:v';
    #?niecza todo
    is @array[0], "A",
        ":v on an array returns rvalues (unlike normal subscripts)";

    #?niecza skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    is +(@array[0,1]:v), 2,
        ":v on an array returned a tow-elem array";
    #?niecza skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    is ~(@array[0,1]:v), "A B",
        ":v on an array returned the correct two-elem array";

    #?niecza skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    is +(@array[42,23]:v),  0, ":v on an array weeded out non-existing entries (1)";
    #?niecza skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    is ~(@array[42,23]:v), "", ":v on an array weeded out non-existing entries (2)";
} #8

# Adverbs on hash subscripts
# :p
{
    my %hash = (0 => "A", 1 => "B");

    isa_ok %hash<0>:p, Pair,
        ":p on a hash returned a Pair";
    is ~(%hash<0>:p), "0\tA",
        ":p on a hash returned the correct pair";

    lives_ok { (%hash<0>:p).value = "a"}, 'can assign to %hash<0>:p.value';
    is %hash<0>, "a",
        ":p on a hash returns lvalues (like normal subscripts do as well)";

    is +(%hash<0 1>:p), 2,
        ":p on a hash returned a two-elem array";
    is ~(%hash<0 1>:p), "0\ta 1\tB",
        ":p on a hash returned a two-elem array consisting of the correct pairs";

    #?niecza todo 'Cannot use value like Pair as a number'
    is +(%hash<42 23>:p),  0, ":p on a hash weeded out non-existing entries (1)";
    #?niecza todo
    is ~(%hash<42 23>:p), "", ":p on a hash weeded out non-existing entries (2)";
} #8

# :kv
{
    my %hash = (0 => "A", 1 => "B");

    is +(%hash<0>:kv), 2,
        ":kv on a hash returned a two-elem array";
    is ~(%hash<0>:kv), "0 A",
        ":kv on a hash returned the correct two-elem array";

    lives_ok {(%hash<0>:kv)[1] = "a"}, 'can assign to %hash<0>:kv.[1]';
    is %hash<0>, "a",
        ":kv on a hash returns lvalues (like normal subscripts do as well)";

    #?niecza todo
    is +(%hash<0 1>:kv), 4,
        ":kv on a hash returned a four-elem array";
    is ~(%hash<0 1>:kv), "0 a 1 B",
        ":kv on a hash returned the correct four-elem array";

    #?niecza todo
    is +(%hash<42 23>:kv),  0, ":kv on a hash weeded out non-existing entries (1)";
    #?niecza todo
    is ~(%hash<42 23>:kv), "", ":kv on a hash weeded out non-existing entries (2)";
} #8

# :k
{
    my %hash = (0 => "A", 1 => "B");

    #?niecza todo   
    ok %hash<0>:k ~~ Str,
        ":k on a hash returned the correct key type";
    is ~(%hash<0>:k), "0",
        ":k on a hash returned the correct key name";

    is +(%hash<0 1>:k), 2,
        ":k on a hash returned a tow-elem array";
    is ~(%hash<0 1>:k), "0 1",
        ":k on a hash returned the correct two-elem array";

    #?niecza todo
    is +(%hash<42 23>:k),  0, ":k on a hash weeded out non-existing entries (1)";
    #?niecza todo
    is ~(%hash<42 23>:k), "", ":k on a hash weeded out non-existing entries (2)";
} #6

# :v
{
    my %hash = (0 => "A", 1 => "B");

    #?niecza skip 'Excess arguments to KERNEL Hash.postcircumfix:<{ }>, unused named v'
    ok %hash<0> ~~ Str,
        ":v on a hash returns the correct type of value";
    #?niecza skip 'Excess arguments to KERNEL Hash.postcircumfix:<{ }>, unused named v'
    is ~(%hash<0>:v), "A",
        ":v on a hash returned the correct value";

    #?niecza todo
    dies_ok {%hash<0>:v = "a"}, 'can assign to %hash<0>:v';
    #?niecza todo
    is %hash<0>, "A", ":v on a hash returns rvalues (unlike normal subscripts)";

    #?niecza skip 'Excess arguments to KERNEL Hash.postcircumfix:<{ }>, unused named v'
    is +(%hash<0 1>:v), 2,
        ":v on a hash returned a two-elem array";
    #?niecza skip 'Excess arguments to KERNEL Hash.postcircumfix:<{ }>, unused named v'
    is ~(%hash<0 1>:v), "A B",
        ":v on a hash returned the correct two-elem array";

    #?niecza skip 'Excess arguments to KERNEL Hash.postcircumfix:<{ }>, unused named v'
    is +(%hash<42 23>:v),  0, ":v on a hash weeded out non-existing entries (1)";
    #?niecza skip 'Excess arguments to KERNEL Hash.postcircumfix:<{ }>, unused named v'
    is ~(%hash<42 23>:v), "", ":v on a hash weeded out non-existing entries (2)";
} #8

# array adverbials that can weed out
{
    my @array; @array[0] = 42; @array[2] = 23; # = (42, Mu, 23);

    # []:kv
    #?niecza 4 todo
    is +(@array[0,1,2]:kv), 4,
      "non-existing entries should be weeded out (1:kv)";
    is_deeply @array[0,1,2]:kv, (0,42,2,23),
      "non-existing entries should be weeded out (2:kv)";
    is +(@array[0,1,2]:!kv), 6,
      "non-existing entries should not be weeded out (1:!kv)";
    is_deeply @array[0,1,2]:!kv, (0,42,1,Any,2,23),
      "non-existing entries should not be weeded out (2:!kv)";

    # []:p
    #?niecza 2 todo
    is +(@array[0,1,2]:p), 2,
      "non-existing entries should be weeded out (1:p)";
    is_deeply @array[0,1,2]:p, (0=>42,2=>23),
      "non-existing entries should be weeded out (2:p)";
    is +(@array[0,1,2]:!p), 3,
      "non-existing entries should not be weeded out (1:!p)";
    is_deeply @array[0,1,2]:!p, (0=>42,1=>Any,2=>23),
      "non-existing entries should not be weeded out (2:!p)";

    # []:k
    #?niecza 2 todo
    is +(@array[0,1,2]:k), 2,
      "non-existing entries should be weeded out (1:k)";
    is_deeply @array[0,1,2]:k, (0,2),
      "non-existing entries should be weeded out (2:k)";
    is +(@array[0,1,2]:!k), 3,
      "non-existing entries should not be weeded out (1:!k)";
    is_deeply @array[0,1,2]:!k, (0,1,2),
      "non-existing entries should not be weeded out (2:!k)";

    # []:v
    #?niecza 4 skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    is +(@array[0,1,2]:v), 2,
      "non-existing entries should be weeded out (1:v)";
    is_deeply @array[0,1,2]:v, (42,23),
      "non-existing entries should be weeded out (2:v)";
    is +(@array[0,1,2]:!v), 3,
      "non-existing entries should not be weeded out (1:!v)";
    is_deeply @array[0,1,2]:!v, (42,Any,23),
      "non-existing entries should not be weeded out (2:!v)";
} #16

# array subscript adverbial weeds out non-existing entries, but undefined (but
# existing) entries should be unaffected by this rule.
{
    my @array = (42, Any, 23);

    # []:kv
    #?niecza 4 todo
    is +(@array[0,1,2]:kv), 6,
      "undefined but existing entries should not be weeded out (1:kv)";
    is_deeply @array[0,1,2]:kv, (0,42,1,Any,2,23),
      "undefined but existing entries should not be weeded out (2:kv)";
    is +(@array[0,1,2]:!kv), 6,
      "undefined but existing entries should not be weeded out (1:!kv)";
    is_deeply @array[0,1,2]:!kv, (0,42,1,Any,2,23),
      "undefined but existing entries should not be weeded out (2:!kv)";

    # []:p
    is +(@array[0,1,2]:p), 3,
      "undefined but existing entries should not be weeded out (1:p)";
    is_deeply @array[0,1,2]:p, (0=>42,1=>Any,2=>23),
      "undefined but existing entries should not be weeded out (2:p)";
    is +(@array[0,1,2]:!p), 3,
      "undefined but existing entries should not be weeded out (1:!p)";
    is_deeply @array[0,1,2]:!p, (0=>42,1=>Any,2=>23),
      "undefined but existing entries should not be weeded out (2:!p)";

    # []:k
    is +(@array[0,1,2]:k), 3,
      "undefined but existing entries should not be weeded out (1:k)";
    is_deeply @array[0,1,2]:k, (0,1,2),
      "undefined but existing entries should not be weeded out (2:k)";
    is +(@array[0,1,2]:!k), 3,
      "undefined but existing entries should not be weeded out (1:!k)";
    is_deeply @array[0,1,2]:!k, (0,1,2),
      "undefined but existing entries should not be weeded out (2:!k)";

    #?niecza 4 skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    # []:v
    is +(@array[0,1,2]:v), 3,
      "undefined but existing entries should not be weeded out (1:v)";
    is_deeply @array[0,1,2]:v, (42,Any,23),
      "undefined but existing entries should not be weeded out (2:v)";
    is +(@array[0,1,2]:!v), 3,
      "undefined but existing entries should not be weeded out (1:!v)";
    is_deeply @array[0,1,2]:!v, (42,Any,23),
      "undefined but existing entries should not be weeded out (2:!v)";
} #16

# hash adverbials that can weed out
{
    my %hash = (0 => 42, 2 => 23);

    # {}:kv
    #?niecza 4 todo
    is +(%hash<0 1 2>:kv), 4,
        "non-existing entries should be weeded out (3:kv)";
    is_deeply %hash<0 1 2>:kv, ("0",42,"2",23),
        "non-existing entries should be weeded out (4:kv)";
    is +(%hash<0 1 2>:!kv), 6,
        "non-existing entries should be weeded out (3:!kv)";
    is_deeply %hash<0 1 2>:!kv, ("0",42,"1",Any,"2",23),
        "non-existing entries should be weeded out (4:!kv)";

    # {}:p
    #?niecza 2 todo
    is +(%hash<0 1 2>:p), 2,
        "non-existing entries should be weeded out (3:p)";
    is_deeply %hash<0 1 2>:p, ("0"=>42,"2"=>23),
        "non-existing entries should be weeded out (4:p)";
    is +(%hash<0 1 2>:!p), 3,
        "non-existing entries should not be weeded out (3:!p)";
    #?niecza todo 
    is_deeply %hash<0 1 2>:!p, ("0"=>42,"1"=>Any,"2"=>23),
        "non-existing entries should not be weeded out (4:!p)";

    #?niecza 2 todo 
    # {}:k
    is +(%hash<0 1 2>:k), 2,
        "non-existing entries should be weeded out (3:k)";
    is_deeply %hash<0 1 2>:k, <0 2>,
        "non-existing entries should be weeded out (4:k)";
    is +(%hash<0 1 2>:!k), 3,
        "non-existing entries should not be weeded out (3:!k)";
    is_deeply %hash<0 1 2>:!k, <0 1 2>,
        "non-existing entries should not be weeded out (4:!k)";

    # {}:v
    #?niecza 4 skip 'Excess arguments to KERNEL Array.postcircumfix:<[ ]>, unused named v'
    is +(%hash<0 1 2>:v), 2,
        "non-existing entries should be weeded out (3:v)";
    is_deeply %hash<0 1 2>:v, (42,23),
        "non-existing entries should be weeded out (4:v)";
    is +(%hash<0 1 2>:!v), 3,
        "non-existing entries should not be weeded out (3:!v)";
    is_deeply %hash<0 1 2>:!v, (42,Any,23),
        "non-existing entries should not be weeded out (4:!v)";
} #16

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/subscript-vs-lt.t0000664000175000017500000000115312224265625021635 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

  Infix comparison operators L

=end pod


plan 4;

# infix less-than requires whitespace; otherwise it's interpreted as
# a <...> hash subscript

eval_lives_ok "1 <2", "infix less-than (<) requires whitespace before.";
eval_lives_ok  "1 < 2" , "infix less-than (<) requires whitespace before.";
#?pugs 2 todo 'parsing'
eval_dies_ok("1< 2", "infix less-than (<) requires whitespace before, so this is a parse error.");
eval_dies_ok("1<2", "infix less-than (<) requires whitespace before, so this is a parse error.");

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/ternary.t0000664000175000017500000000341312224265625020241 0ustar  moritzmoritzuse v6;

use Test;

#Ternary operator ?? !!

plan 17;
#L

my $str1 = "aaa";
my $str2 = "aaa";
my $str3 = "bbb";

{
    my $foo = "";
    $str1 eq $str2 ?? ($foo = 1) !! ($foo = 2);
    is($foo, 1, "?? !!");

    $str1 eq $str3 ?? ($foo = 3) !! ($foo = 4);
    is($foo, 4, "?? !!");
}

is(($str2 eq $str1 ?? 8 * 8 !! 9 * 9), 64, "?? !! in parenthesis");
#?pugs skip 'div'
is(($str2 eq $str3 ?? 8 + 8 !! 9 div 9), 1, "?? !! in parenthesis");

is(1 ?? 2 ?? 3 !! 4 !! 5 ?? 6 !! 7, 3, "nested ?? !!");
is(1 ?? 0 ?? 3 !! 4 !! 5 ?? 6 !! 7, 4, "nested ?? !!");
is(0 ?? 2 ?? 3 !! 4 !! 5 ?? 6 !! 7, 6, "nested ?? !!");
is(0 ?? 2 ?? 3 !! 4 !! 0 ?? 6 !! 7, 7, "nested ?? !!");

{
    my @a = (1 ?? 2 !! 3, 4 ?? 5 !! 6);
    is(@a, [2, 5], "?? !! in array");

}

is((0 and 1 ?? 2 !! 3), 0, "operator priority");
is((4 or 5 ?? 6 !! 7), 4, "operator priority");

{
    my $foo = 8;

    $foo = 9 ?? 10 !! 11;
    is($foo, 10, "operator priority");

    $foo = 0 ?? 12 !! 13;
    is($foo, 13, "operator priority");
}

#?pugs skip "parse failure"
{
    # This parses incorrectly in pugs because it's 
    # parsed as Bool::True(!! Bool::False).
    my $foo = 1 ?? Bool::True !! Bool::False;
    is($foo, Bool::True, "a statement with both ??!! and :: in it did compile") ;
}

{
    # Defining an N! postfix (for factorial) causes a misparse on ternary op
    proto postfix:($n) {
        return 1 if $n < 2;
        return $n * ($n-1)!
    }

    my $foo = eval q[ 1 ?? 'yay' !! 'nay' ];
    #?pugs todo 'bug'
    is($foo, "yay", "defining a postfix doesn't screw up ternary op");
}

eval_dies_ok q[ 1 ?? 2,3 !! 4,5 ], 'Ternary error (RT 66840)';

eval_dies_ok q[ 71704 !! 'bust' ], 'Ternary error (RT 71704)';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-operators/value_equivalence.t0000664000175000017500000001277012224265625022260 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

C<===> and C are 2 distinct operators, where C<===> tests value
equivalence for immutable types and reference equivalence for 
mutable types, and C tests value equivalence for snapshots of mutable
types.  So C<(1,2) === (1,2)> returns true but C<[1,2] === [1,2]> returns 
false, and C<[1,2] eqv [1,2]> returns true.

=end pod

# L

plan 75;

# === on values
{
  ok  (1 === 1), "=== on values (1)";
  ok  (0 === 0), "=== on values (2)";
  ok  (1 + 1 === 2), '=== on non-literal values';
  ok !(0 === 1), "=== on values (3)";
  isa_ok (1 === 1), Bool, "=== on values (4)";
  ok  ("abc" === "abc"), "=== on values(abc)";
  ok !("abc" === "ABC"), "=== on values(abc === ABC)";
  isa_ok ("abc" === "abc"), Bool, "=== on values (abc)";
  ok !(1 === 1.0), "=== on values (1 === 1.0)";
  ok !(1 === "1"), '=== on values (1 === "1")';
}

# more value tests
{
  ok 1/2 === 1/2,                "=== on Rats";
  ok 1/2 !=== 3/2,               "!=== on Rats";
  isa_ok 1/2 === 1/2, Bool,      "=== on Rats yields Bool";
  isa_ok 1/2 !=== 3/2, Bool,     "!=== on Rats yields Bool";
  ok 0.5e0 === 0.5e0,            "=== on Nums";
  ok 0.5e0 !=== 1.5e0,           "!=== on Nums";
  isa_ok 0.5e0 === 0.5e0, Bool,  "=== on Nums yields Bool";
  isa_ok 0.5e0 !=== 1.5e0, Bool, "!=== on Nums yields Bool";
}

# Value types
{
  my $a = 1;
  my $b = 1;

  ok $a === $a, "=== on value types (1-1)";
  ok $b === $b, "=== on value types (1-2)";
  ok $a === $b, "=== on value types (1-3)";
  isa_ok $a === $b, Bool, "=== on value types (1-4)";
}

{
  my $a = 1;
  my $b = 2;

  ok  ($a === $a), "=== on value types (2-1)";
  ok  ($b === $b), "=== on value types (2-2)";
  ok !($a === $b), "=== on value types (2-3)";
  isa_ok ($a === $a), Bool, "=== on value types (2-4)";
}

# Reference types
{
  my @a = (1,2,3);
  my @b = (1,2,3);

  #?rakudo 2 todo "=== doesn't work on array references yet"
  #?niecza todo
  ok  (\@a === \@a), "=== on array references (1)";
  #?niecza todo
  ok  (\@b === \@b), "=== on array references (2)";
  ok !(\@a === \@b), "=== on array references (3)";
  isa_ok (\@a === \@a), Bool, "=== on array references (4)";
}

{
  my $a = \3;
  my $b = \3;

  ok  ($a === $a), "=== on scalar references (1-1)";
  ok  ($b === $b), "=== on scalar references (1-2)";
  #?pugs todo
  ok !($a === $b), "=== on scalar references (1-3)";
  isa_ok ($a === $a), Bool, "=== on scalar references (1-4)";
}

{
  my $a = { 3 };
  my $b = { 3 };

  ok  ($a === $a), "=== on sub references (1-1)";
  ok  ($b === $b), "=== on sub references (1-2)";
  ok !($a === $b), "=== on sub references (1-3)";
  isa_ok ($a === $a), Bool, "=== on sub references (1-4)";
}

{
  ok  (&say === &say), "=== on sub references (2-1)";
  ok  (&map === &map), "=== on sub references (2-2)";
  ok !(&say === &map), "=== on sub references (2-3)";
  isa_ok (&say === &say), Bool, "=== on sub references (2-4)";
}

{
  my $num = 3;
  my $a   = \$num;
  my $b   = \$num;

  ok  ($a === $a), "=== on scalar references (2-1)";
  ok  ($b === $b), "=== on scalar references (2-2)";
  #?rakudo todo "=== fail"
  #?niecza todo
  ok  ($a === $b), "=== on scalar references (2-3)";
  isa_ok ($a === $a), Bool, "=== on scalar references (2-4)";
}

{
  ok !([1,2,3] === [4,5,6]), "=== on anonymous array references (1)";
  ok !([1,2,3] === [1,2,3]), "=== on anonymous array references (2)";
  ok !([]      === []),      "=== on anonymous array references (3)";
  isa_ok ([1,2,3] === [4,5,6]), Bool, "=== on anonymous array references (4)";
}

{
  ok !({a => 1} === {a => 2}), "=== on anonymous hash references (1)";
  ok !({a => 1} === {a => 1}), "=== on anonymous hash references (2)";
  isa_ok ({a => 1} === {a => 2}), Bool, "=== on anonymous hash references (3)";
}

{
  ok !(\3 === \4),          "=== on anonymous scalar references (1)";
  #?pugs todo
  ok !(\3 === \3),          "=== on anonymous scalar references (2)";
  isa_ok (\3 === \4), Bool, "=== on anonymous scalar references (4)";
}

# Chained === (not specced, but obvious)
{
  ok  (3 === 3 === 3), "chained === (1)";
  ok !(3 === 3 === 4), "chained === (2)";
}

# Subparam binding doesn't affect === test
{
  my $foo;
  my $test = -> $arg { $foo === $arg };

  $foo = 3;
  ok  $test($foo), "subparam binding doesn't affect === (1)";
  ok  $test(3),    "subparam binding doesn't affect === (2)";

  ok !$test(4),    "subparam binding doesn't affect === (3)";
  my $bar = 4;
  ok !$test($bar), "subparam binding doesn't affect === (4)";
}

{
    my $a = 1;
    my $b = 2;
    is($a === $a, Bool::True,  '=== returns Bool::True when true');
    is($a === $b, Bool::False, '=== returns Bool::False when false');
}

# L
{
  ok !(1 !=== 1), "!=== on values (1)";
  ok !(0 !=== 0), "!=== on values (2)";
  ok  (1 !=== 0), "!=== on values (3)";
  isa_ok (1 !=== 1), Bool, "!=== on values (4)";
  ok !("abc" !=== "abc"), "!=== on values(abc)";
  ok  ("abc" !=== "ABC"), "!=== on values(abc !=== ABC)";
  ok  (1 !=== 1.0), "!=== on values (1 !=== 1.0)";
  ok  (1 !=== "1"), '!=== on values (1 !=== "1")';
}

#?pugs skip "this test alters # of run tests?"
ok     1|2 === 1,  '=== does autothread (1)';
isa_ok  1|2 === 1, Junction,  '=== does autothread (2)';

#?pugs skip 'roles'
{
    my $a = do {
        my role A { };
        1 but A;
    };
    my $b = do {
        my role A { };
        1 but A;
    };
    #?rakudo todo '.WHICH based on type names'
    nok $a === $b, 'two lexical roles come out as different when compared with ===';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-sequence/arity0.t0000664000175000017500000000266712224265625017571 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 13;

# Test with Whatever limit
{
    my @rolls = ({ (1..6).pick } ... *).[^20];
    is +@rolls, 20, 'Got the number of rolls we asked for';
    is @rolls.grep(Int).elems, 20, 'all the rolls are Ints';
    is @rolls.grep(1..6).elems, 20, 'all the rolls are in the Range 1..6';
}

# Test with exact limit
#?niecza skip 'Unable to resolve method munch in class List'
{
    my @rolls = ({ (1..2).pick } ... 2).munch(100);
    ok +@rolls > 0, 'the sequence had at least one element...';
    ok +@rolls < 100, '... and the sequence terminated';
    is @rolls.grep(Int).elems, +@rolls, 'all the rolls are Ints';
    is @rolls.grep(2).elems, 1, 'There was exactly one 2 rolled...';
    is @rolls[@rolls.elems - 1], 2, '...and it was the last roll';
}

# Test with limit between possible values
#?niecza skip 'Unable to resolve method munch in class List'
{
    my @rolls = ({ (1..2).pick } ... 1.5).munch(100);
    ok +@rolls == 100, 'the sequence is infinite...';
    is @rolls.grep(Int).elems, +@rolls, 'all the rolls are Ints';
}

# Test with limit that cannot be hit
#?niecza skip 'Unable to resolve method munch in class List'
{
    my @rolls = ({ (1..6).pick } ... 7).munch(40);
    is +@rolls, 40, 'Got the number of rolls we asked for';
    is @rolls.grep(Int).elems, 40, 'all the rolls are Ints';
    is @rolls.grep(1..6).elems, 40, 'all the rolls are in the Range 1..6';
}


done;
rakudo-2013.12/t/spec/S03-sequence/arity-2-or-more.t0000664000175000017500000000441612224265625021220 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 19;

# some tests without regard to ending 

is (1, 1, { $^a + $^b } ... *).[^6].join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci';
is (1, 1, &infix:<+> ... *).[^6].join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, using "&infix:<+>"';
#?niecza skip "Undeclared names: '[+]'"
is (1, 1, &[+] ... *).[^6].join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, using "&[+]"';
is (0, 1, { $^a + $^b } ... *).[^7].join(', '), '0, 1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, 0 1 seeds';
is (1, 1, 2, -> $a, $b { $a + $b } ... *).[^6].join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, 3 seeds';
is (1, 1, 2, 3, { $^a + $^b } ... *).[^6].join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, 4 seeds';
is (0, 1, 1, 2, 3, { $^a + $^b } ... *).[^7].join(', '), '0, 1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, 5 seeds';

# some tests which exactly hit a limit

is (1, 1, { $^a + $^b } ... 8).join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci';
is (1, 1, 2, -> $a, $b { $a + $b } ... 8).join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, 3 seeds';
is (1, 1, 2, 3, { $^a + $^b } ... 8).join(', '), '1, 1, 2, 3, 5, 8', 'arity-2 Fibonacci, 4 seeds';
# adapted from http://www.perlmonks.org/?node_id=772778
#?niecza skip "Undeclared names: '[%]'"
is (42, 24, &[%] ... 0)[*-2], 6, 'arity-2 GCD';
#?niecza skip "Undeclared names: '[%]'"
is (42, 24, &[%] ...^ 0)[*-1], 6, 'arity-2 GCD with excluded limit';
is (42, 24, * % * ... 0)[*-2], 6, 'arity-2 GCD';
is (42, 24, * % * ...^ 0)[*-1], 6, 'arity-2 GCD with excluded limit';

# some tests which miss a limit

is (1, 1, { $^a + $^b } ... 9).[^7].join(', '), '1, 1, 2, 3, 5, 8, 13', 'arity-2 Fibonacci';
is (1, 1, 2, -> $a, $b { $a + $b } ... 9).[^7].join(', '), '1, 1, 2, 3, 5, 8, 13', 'arity-2 Fibonacci, 3 seeds';
is (1, 1, 2, 3, { $^a + $^b } ... 9).[^7].join(', '), '1, 1, 2, 3, 5, 8, 13', 'arity-2 Fibonacci, 4 seeds';

# sequence with slurpy functions
{
    sub nextprime( *@prev_primes ) {
	my $current = @prev_primes[*-1];
        1 while ++$current % any(@prev_primes) == 0;
        return $current;
    }
    is (2, &nextprime ... 13).join(' '), '2 3 5 7 11 13', 'slurpy prime generator';
}
is (1, 2, sub {[*] @_[*-1], @_ + 1} ... 720).join(' '), '1 2 6 24 120 720', 'slurpy factorial generator';

done;
rakudo-2013.12/t/spec/S03-sequence/basic.t0000775000175000017500000003424612224265625017443 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 129;

# single-term sequence

is ~( 1  ...  1 ), '1', '1 ... 1';
is ~( 'a'  ...  'a' ), 'a', "'a' ... 'a'";

# finite sequence that exactly hit their limit

is (1 ... 5).join(', '), '1, 2, 3, 4, 5', 'simple sequence with one item on the LHS';
is (1 ... -3).join(', '), '1, 0, -1, -2, -3', 'simple decreasing sequence with one item on the LHS';
is (1, 3 ... 9).join(', '), '1, 3, 5, 7, 9', 'simple additive sequence with two items on the LHS';
is (1, 0 ... -3).join(', '), '1, 0, -1, -2, -3', 'simple decreasing additive sequence with two items on the LHS';
is (1, 3, 5 ... 9).join(', '), '1, 3, 5, 7, 9', 'simple additive sequence with three items on the LHS';
is (1, 3, 9 ... 81).join(', '), '1, 3, 9, 27, 81', 'simple multiplicative sequence with three items on the LHS';
is (81, 27, 9 ... 1).join(', '), '81, 27, 9, 3, 1', 'decreasing multiplicative sequence with three items on the LHS';
is (1, { $_ + 2 } ... 9).join(', '), '1, 3, 5, 7, 9', 'simple sequence with one item and block closure on the LHS';
is (1, *+2 ... 9).join(', '), '1, 3, 5, 7, 9', 'simple sequence with one item and * closure on the LHS';
is (1, { $_ - 2 } ... -7).join(', '), '1, -1, -3, -5, -7', 'simple sequence with one item and closure on the LHS';
is (1, 3, 5, { $_ + 2 } ... 13).join(', '), '1, 3, 5, 7, 9, 11, 13', 'simple sequence with three items and block closure on the LHS';
is (1, { 1 / ((1 / $_) + 1) } ... 1/5).map({.perl}).join(', '), '1, 0.5, <1/3>, 0.25, 0.2', 'tricky sequence with one item and closure on the LHS';
is (1, { -$_ } ... 1).join(', '), '1', 'simple alternating sequence with one item and closure on the LHS';
is (1, { -$_ } ... 3).[^5].join(', '), '1, -1, 1, -1, 1', 'simple alternating sequence with one item and closure on the LHS';

is ({ 3+2; } ... *).[^5].join(', '), '5, 5, 5, 5, 5', 'sequence with one scalar containing Code on the LHS';

is (1 ... 5, 6, 7).join(', '), '1, 2, 3, 4, 5, 6, 7', 'simple sequence with two further terms on the RHS';
is (1 ... 5, 4, 3).join(', '), '1, 2, 3, 4, 5, 4, 3', 'simple sequence with two extra terms on the RHS';
is (1 ... 5, 'xyzzy', 'plugh').join(', '), '1, 2, 3, 4, 5, xyzzy, plugh', 'simple sequence with two weird items on the RHS';

# infinite sequence that go past their limit
{
is (1 ... 5.5).[^6].join(', '), '1, 2, 3, 4, 5, 6', 'simple sequence with one item on the LHS';
is (1 ... -3.5).[^6].join(', '), '1, 0, -1, -2, -3, -4', 'simple decreasing sequence with one item on the LHS';
is (1, 3 ... 10).[^6].join(', '), '1, 3, 5, 7, 9, 11', 'simple additive sequence with two items on the LHS';
is (1, 0 ... -3.5).[^6].join(', '), '1, 0, -1, -2, -3, -4', 'simple decreasing additive sequence with two items on the LHS';
is (1, 3, 5 ... 10).[^6].join(', '), '1, 3, 5, 7, 9, 11', 'simple additive sequence with three items on the LHS';
is (1, 3, 9 ... 100).[^6].join(', '), '1, 3, 9, 27, 81, 243', 'simple multiplicative sequence with three items on the LHS';
is (81, 27, 9 ... 8/9).[^6], (81, 27, 9, 3, 1, 1/3), 'decreasing multiplicative sequence with three items on the LHS';
is (1, { $_ + 2 } ... 10).[^6].join(', '), '1, 3, 5, 7, 9, 11', 'simple sequence with one item and block closure on the LHS';
is (1, *+2 ... 10).[^6].join(', '), '1, 3, 5, 7, 9, 11', 'simple sequence with one item and * closure on the LHS';
is (1, { $_ - 2 } ... -8).[^6].join(', '), '1, -1, -3, -5, -7, -9', 'simple sequence with one item and closure on the LHS';
is (1, 3, 5, { $_ + 2 } ... 14).[^8].join(', '), '1, 3, 5, 7, 9, 11, 13, 15', 'simple sequence with three items and block closure on the LHS';
is (1, { 1 / ((1 / $_) + 1) } ... 11/60).[^6].map({.perl}).join(', '), '1, 0.5, <1/3>, 0.25, 0.2, <1/6>', 'tricky sequence with one item and closure on the LHS';
is (1, { -$_ } ... 0).[^4].join(', '), '1, -1, 1, -1', 'simple alternating sequence with one item and closure on the LHS';

is (1 ... 5.5, 6, 7).[^8].join(', '), '1, 2, 3, 4, 5, 6, 7, 8', 'simple sequence with two further terms on the RHS';
is (1 ... 5.5, 4, 3).[^8].join(', '), '1, 2, 3, 4, 5, 6, 7, 8', 'simple sequence with two extra terms on the RHS';
is (1 ... 5.5, 'xyzzy', 'plugh').[^8].join(', '), '1, 2, 3, 4, 5, 6, 7, 8', 'simple sequence with two weird items on the RHS';
}
# infinite sequence without limits

is (1 ... *).[^5].join(', '), '1, 2, 3, 4, 5', 'simple sequence with one item on the LHS';
is (1, 3 ... *).[^5].join(', '), '1, 3, 5, 7, 9', 'simple additive sequence with two items on the LHS';
is (1, 0 ... *).[^5].join(', '), '1, 0, -1, -2, -3', 'simple decreasing additive sequence with two items on the LHS';
is (1, 3, 5 ... *).[^5].join(', '), '1, 3, 5, 7, 9', 'simple additive sequence with three items on the LHS';
is (8, 7, 6 ... *).[^5].join(', '), '8, 7, 6, 5, 4', 'simple decreasing additive sequence with three items on the LHS';
is (1, 3, 9 ... *).[^5].join(', '), '1, 3, 9, 27, 81', 'simple multiplicative sequence with three items on the LHS';
is (81, 27, 9 ... *).[^5].join(', '), '81, 27, 9, 3, 1', 'decreasing multiplicative sequence with three items on the LHS';
is (1, { $_ + 2 } ... *).[^5].join(', '), '1, 3, 5, 7, 9', 'simple sequence with one item and block closure on the LHS';
is (1, *+2 ... *).[^5].join(', '), '1, 3, 5, 7, 9', 'simple sequence with one item and * closure on the LHS';
is (1, { $_ - 2 } ... *).[^5].join(', '), '1, -1, -3, -5, -7', 'simple sequence with one item and closure on the LHS';
is (1, 3, 5, { $_ + 2 } ... *).[^7].join(', '), '1, 3, 5, 7, 9, 11, 13', 'simple sequence with three items and block closure on the LHS';
is (1, { 1 / ((1 / $_) + 1) } ... *).[^5].map({.perl}).join(', '), '1, 0.5, <1/3>, 0.25, 0.2', 'tricky sequence with one item and closure on the LHS';
is (1, { -$_ } ... *).[^5].join(', '), '1, -1, 1, -1, 1', 'simple alternating sequence with one item and closure on the LHS';

is (1 ... *, 6, 7).[^7].join(', '), '1, 2, 3, 4, 5, 6, 7', 'simple sequence with two further terms on the RHS';
is (1 ... *, 4, 3).[^7].join(', '), '1, 2, 3, 4, 5, 6, 7', 'simple sequence with two extra terms on the RHS';
is (1 ... *, 'xyzzy', 'plugh').[^7].join(', '), '1, 2, 3, 4, 5, 6, 7', 'simple sequence with two weird items on the RHS';

# constant sequence

is ('c', { $_ } ... *).[^10].join(', '), 'c, c, c, c, c, c, c, c, c, c', 'constant sequence started with letter and identity closure';
is ('c', 'c' ... *).[^10].join(', '), 'c, c, c, c, c, c, c, c, c, c', 'constant sequence started with two letters';
is ('c', 'c', 'c' ... *).[^10].join(', '), 'c, c, c, c, c, c, c, c, c, c', 'constant sequence started with three letters';
is (1, 1 ... *).[^10].join(', '), '1, 1, 1, 1, 1, 1, 1, 1, 1, 1', 'constant sequence started with two numbers';
is (1, 1, 1 ... *).[^10].join(', '), '1, 1, 1, 1, 1, 1, 1, 1, 1, 1', 'constant sequence started with three numbers';

# misleading starts

is (1, 1, 1, 2, 3 ... 10).[^10].join(', '), '1, 1, 1, 2, 3, 4, 5, 6, 7, 8', 'sequence started with three identical numbers, but then goes arithmetic';
is (1, 1, 1, 2, 4 ... 16).join(', '), '1, 1, 1, 2, 4, 8, 16', 'sequence started with three identical numbers, but then goes geometric';
is (4, 2, 1, 2, 4 ... 16).join(', '), '4, 2, 1, 2, 4, 8, 16', 'geometric sequence started in one direction and continues in the other';

# some tests taken from Spec

is (False, &prefix: ... *).[^6].join(', '), (False, True, False, True, False, True).join(', '), "alternating False and True";
is (False, &prefix: ... *).[^10].grep(Bool).elems, 10, "alternating False and True is always Bool";
#?niecza skip '&[] NYI'
is (1,2,&[+] ... 8).join(', ') , "1, 2, 3, 5, 8" , "Using &[+] works";
is (False, { !$_ } ... *).[^6].join(', '), (False, True, False, True, False, True).join(', '), "alternating False and True";
is (False, { !$_ } ... *).[^10].grep(Bool).elems, 10, "alternating False and True is always Bool";

# L
# infinite sequence with limits

is ~(1, 1/2, 1/4 ... 0).[^5].map({.perl}), '1 0.5 0.25 0.125 0.0625', 'geometric sequence that never reaches its limit';
is ~(1, -1/2, 1/4 ... 0).[^5].map({.perl}), '1 -0.5 0.25 -0.125 0.0625', 'alternating geometric sequence that never reaches its limit';
is (1, { 1 / ((1 / $_) + 1) } ... 0).[^5].map({.perl}).join(', '), '1, 0.5, <1/3>, 0.25, 0.2', '"harmonic" sequence that never reaches its limit';

# empty sequence

# L
{
is (1, 2 ... 0).[^3], (1,2,3), 'No more: limit value is on the wrong side';
}

# L
# excluded limits via "...^"
{
    is (1 ...^ 5).join(', '), '1, 2, 3, 4', 'exclusive sequence';
    is (1 ...^ -3).join(', '), '1, 0, -1, -2', 'exclusive decreasing sequence';
    is (1 ...^ 5.5).[^6].join(', '), '1, 2, 3, 4, 5, 6', "exclusive sequence that couldn't hit its limit anyway";
    is (1, 3, 9 ...^ 81).join(', '), '1, 3, 9, 27', 'exclusive geometric sequence';
    is (81, 27, 9 ...^ 2).[^5].join(', '), '81, 27, 9, 3, 1', "exclusive decreasing geometric sequence that couldn't hit its limit anyway";
    is (2, -4, 8 ...^ 32).join(', '), '2, -4, 8, -16', 'exclusive alternating geometric sequence';
    is (2, -4, 8 ...^ -32).[^6].join(', '), '2, -4, 8, -16, 32, -64', 'exclusive alternating geometric sequence (not an exact match)';
    is (1, { $_ + 2 } ...^ 9).join(', '), '1, 3, 5, 7', 'exclusive sequence with closure';
    is (1 ...^ 1), (), 'empty exclusive sequence';
    is (1, 1 ...^ 1), (), 'empty exclusive constant sequence';
    is (1, 2 ...^ 0).[^3], (1, 2, 3), 'empty exclusive arithmetic sequence';
    is (1, 2 ...^ 0, 'xyzzy', 'plugh').[^3].join(', '), '1, 2, 3', 'exclusive sequence empty but for extra items';
    is ~(1 ...^ 0), '1', 'singleton exclusive sequence';
    is (4...^5).join(', '), '4', '4...^5 should parse as 4 ...^ 5 and not 4 ... ^5';
}


# RT #75698
ok ?(one((-5 ... ^5).flat) == 0), '-5 ... ^5 produces just one zero';

# RT #75316
#?rakudo todo 'mysterious'
#?niecza skip 'Failure NYI'
isa_ok (1...()), Failure,
    'empty list on right side of sequence operator does not cause infinite loop';

# RT #73508
is (1,2,4...*)[10], 1024,
    'element from list generated using infinite sequence is accessible by index';

# RT #72914
is (4 ... ^5).join(', '), '4, 3, 2, 1, 0, 1, 2, 3, 4',
    'geometric sequence started in one direction and continues in the other with exclusion';

lives_ok { (1 ... 5).perl }, 'Can take .perl of sequence';
is eval((1 ... 5).perl).join(','), '1,2,3,4,5',
    'eval($sequence.perl) reproduces result list';

# RT 98790
is ~((1 ... *) Z~ ('a' ... 'z')).[^5], "1a 2b 3c 4d 5e", "Zipping two sequence in parallel";

{
    is (1, 2, 4 ... 3).[^4], (1, 2, 4, 8), "sequence that does not hit the limit";
    is (1, 2, 4 ... 2), (1, 2), "sequence that aborts during LHS";

    is (1, 2, 4 ... 1.5).[^4], (1,2,4,8), "sequence that does not hit the limit";
    is (1, 2, 4 ... 1), (1), "sequence that aborts during LHS";

    is ~(1, -2, 4 ... 1), '1', 'geometric sequence with smaller RHS and sign change';
    is ~(1, -2, 4 ... 2).[^4], '1 -2 4 -8', 'geometric sequence with smaller RHS and sign change';
    is ~(1, -2, 4 ... 3).[^4], '1 -2 4 -8', 'geometric sequence with smaller RHS and sign change';
    is ~(1, -2, 4 ... 25).[^10], '1 -2 4 -8 16 -32 64 -128 256 -512', 'geometric sequence with sign-change and non-matching end point';

    is (1, 2, 4, 5, 6 ... 2), (1, 2), "sequence that aborts during LHS, before actual calculations kick in";

    is (1, 2, 4, 5, 6 ... 3).[^6], (1,2,4,5,6,7), "sequence that aborts during LHS, before actual calculations kick in";
}

# tests for the types returned

{
    my @a = 1, 2, 3 ... 100;
    is @a.elems, 100, "1, 2, 3 ... 100 generates a sequence with one hundred elements...";
    is @a.grep(Int).elems, 100, "... all of which are Ints";
}

{
    my @a = 1.Rat, 2.Rat, 3.Rat ... 100;
    is @a.elems, 100, "1.Rat, 2.Rat, 3.Rat ... 100 generates a sequence with one hundred elements...";
    is @a.grep(Rat).elems, 100, "... all of which are Rats";
}

{
    my @a = 1.Num, 2.Num, 3.Num ... 100;
    is @a.elems, 100, "1.Num, 2.Num, 3.Num ... 100 generates a sequence with one hundred elements...";
    is @a.grep(Num).elems, 100, "... all of which are Nums";
}

{
    my @a = 1, 2, 4 ... 64;
    is @a.elems, 7, "1, 2, 4 ... 64 generates a sequence with seven elements...";
    is @a.grep(Int).elems, @a.elems, "... all of which are Ints";
}

{
    my @a = 1.Rat, 2.Rat, 4.Rat ... 64;
    is @a.elems, 7, "1.Rat, 2.Rat, 4.Rat ... 64 generates a sequence with seven elements...";
    is @a.grep(Rat).elems, 7, "... all of which are Rats";
}

{
    my @a = 1.Num, 2.Num, 4.Num ... 64;
    is @a.elems, 7, "1.Num, 2.Num, 4.Num ... 64 generates a sequence with seven elements...";
    is @a.grep(Num).elems, 7, "... all of which are Nums";
}

# RT #74606
is (1, +* ... *).[^5].join('|'), (1 xx 5).join('|'),
    '1, +* works for sequence';

# RT #75768, RT #98790
is ~(1...10)[2...4], '3 4 5', 'can index sequence with sequence';

{
    is (1, 2 ... *>=5), (1,2,3,4,5), "sequence with code on the rhs";
    is (1, 2 ... *>5), (1,2,3,4,5,6), "sequence with code on the rhs";
    is (1, 2 ...^ *>=5), (1,2,3,4), "exclusive sequence with code on the rhs";
    is (1, 2 ...^ *>5), (1,2,3,4,5), "exclusive sequence with code on the rhs";
}

#?rakudo todo 'sequence + last'
is (1, 2 , {last if $_>=5; $_+1} ... *), (1,2,3,4,5), "sequence that lasts in the last item of lhs";

{
	is (1..* ... 5), (1, 2, 3, 4, 5), '1..* ... 5';
	my @fib := (0, 1, *+* ... * );
        # RT #98790
	is (@fib ... 8), (0 , 1, 1, 2 , 3, 5, 8), '@fib ... 8';
}

# RT #78324
is (32,16,8 ...^ Rat), (32,16,8) , 'stop on a matching type';

# RT #75828
eval_dies_ok '1, 2, 3, ... 5', 'comma before sequence operator is caught';

# RT #73268
is ~(1...^*).[^10], '1 2 3 4 5 6 7 8 9 10', 'RT #73268';

# RT #76046
#?niecza skip '&[] NYI'
is (1, 1, &[+] ... *).[^10], '1 1 2 3 5 8 13 21 34 55', 'use &[+] on infix:<...> series';

# see http://irclog.perlgeek.de/perl6/2012-05-30#i_5659147 ff.
# previously rakudo said Not enough positional parameters passed; got 3 but expected 4
is ((1,1,2,4,8)[^4], *+*+*+* ... *)[4], 8, 'WhateverCode with arity > 3 gets enough arguments';

#RT #75674
{
    is (4 ... ^5), <4 3 2 1 0 1 2 3 4>, "RT #75674";
    is (4 ... 0,1,2,3,4), <4 3 2 1 0 1 2 3 4>, "RT #75674";
    is (-5 ... ^5), <-5 -4 -3 -2 -1 0 1 2 3 4>, "RT #75674";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-sequence/limit-arity-2-or-more.t0000664000175000017500000000205112224265625022325 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 8;

# sequence with a limit function of arity 2

is (8,*/2 ... (*-*).abs < 2).join(', '), '8, 4, 2, 1', 'arity-2 convergence limit';
is (8,*/2 ...^ (*-*).abs < 2).join(', '), '8, 4, 2', 'arity-2 excluded convergence limit';

# sequence with a limit function of arity 3

{
  my $i = -5;
  my @seq = { ++$i; $i**3-9*$i } ... { ($^a-$^b) > ($^b-$^c) };
  is @seq.join(', '), '-28, 0, 10, 8, 0, -8, -10', 'arity-3 curvature limit';
}

{
  my $i = -5;
  my @seq = { ++$i; $i**3-9*$i } ...^ { ($^a-$^b) > ($^b-$^c) };
  is @seq.join(', '), '-28, 0, 10, 8, 0, -8', 'arity-3 excluded curvature limit';
}

is (2, 1, 0.5 ... (*-*).abs < 2).join(', '), '2, 1', 'ASAP arity-2 convergence limit';
is (2, 1, 0.5 ...^ (*-*).abs < 2).join(', '), '2', 'ASAP arity-2 excluded convergence limit';

# limit function that accepts any number of args

is (1 ... { @_ eq "1 2 3" }).join(', '), '1, 2, 3', 'arity-Inf limit';
is (1 ...^ { @_ eq "1 2 3" }).join(', '), '1, 2', 'arity-Inf excluded limit';

done;
rakudo-2013.12/t/spec/S03-sequence/misc.t0000664000175000017500000001023412237474612017303 0ustar  moritzmoritzuse v6;
use Test;


# L
#?niecza skip 'Nominal type check failed in binding Int $n in f; got Str, needed Int'
#?rakudo todo 'bogus test?'
{
    sub f (Int $n) { $n > 3 ?? 'liftoff!' !! $n + 1 }
    is (1, &f ... *).join(' '), '1 2 3 liftoff!', 'sequence terminated by signature mismatch';
}

# L'>

# XXX This is surely the wrong way to test this, but I don't know
#     the right way.
#?niecza skip 'Need something on the LHS'
is (() ... *)[^3].perl, '((), (), ())', 'Nil sequence';

# L
# multiple return values

is (1, 1, { $^a + 1, $^b * 2 } ... *).flat.[^12].join(' '), '1 1 2 2 3 4 4 8 5 16 6 32', 'sequence of two interleaved sequences';
is (1, 1, 1, { $^a + 1, $^b * 2, $^c - 1 } ... *).flat.[^18].join(' '), '1 1 1 2 2 0 3 4 -1 4 8 -2 5 16 -3 6 32 -4', 'sequence of three interleaved sequences';
is (1, { $^n + 1 xx $^n + 1 } ... *)[^10].join(' '), '1 2 2 3 3 3 4 4 4 4', 'sequence with list-returning block';
#?rakudo 2 todo 'NYI'
is ('a', 'b', { $^a ~ 'x', $^a ~ $^b, $^b ~ 'y' } ... *)[^11].join(' '), 'a b ax ab by abx abby byy abbyx abbybyy byyy', 'sequence with arity < number of return values';
is ('a', 'b', 'c', { $^x ~ 'x', $^y ~ 'y' ~ $^z ~ 'z' } ... *)[^9].join(' '), 'a b c ax bycz cx axybyczz byczx cxyaxybyczzz', 'sequence with arity > number of return values';

# L

eval_dies_ok '(1, 2, ... 3)[2]', 'yada operator not confused for sequence operator';    #OK apparent sequence operator

# L
# chained sequence

is (1 ... 5 ... 10).join(' '),
    '1 2 3 4 5 6 7 8 9 10',
    'simple chained finite arithmetic sequence';
#?niecza skip 'Slicel lists are NYI'
is infix:<...>(1; 5; 10).join(' '),
    '1 2 3 4 5 6 7 8 9 10',
    "simple chained finite arithmetic sequence (with 'infix:<...>')";
is (1 ... 5, 10 ... 25, 50 ... 150).join(' '),
    '1 2 3 4 5 10 15 20 25 50 75 100 125 150',
    'chained finite arithmetic sequence';
is (1 ... 4, 8, 16 ... 64, 63, 62 ... 58).join(' '),
    '1 2 3 4 8 16 32 64 63 62 61 60 59 58',
    'chained finite numeric sequence';
#?niecza skip 'Slicel lists are NYI'
is infix:<...>(1;   4, 8, 16;   64, 63, 62;   58).join(' '),
    '1 2 3 4 8 16 32 64 63 62 61 60 59 58',
    "chained finite numeric sequence (with 'infix:<...>')";
is (1/4, 1/2, 1 ... 8, 9 ... *)[^10].join(' '),
    '0.25 0.5 1 2 4 8 9 10 11 12',
    'chained infinite numeric sequence';
#?niecza skip 'Slicel lists are NYI'
#?rakudo skip 'Slicel lists are NYI'
is infix:<...>(1/4, 1/2, 1;   8, 9;   *).join(' '),
    '1/4 1/2 1 2 4 8 9 10 11 12',
    "chained infinite numeric sequence (with 'infix:<...>')";
is (1, 4, 7 ... 16, 16 ... *)[^8].join(' '),
    '1 4 7 10 13 16 16 16',
    'chained eventually constant numeric sequence';
    
# The following is now an infinite sequence...
# is (0, 2 ... 7, 9 ... 14).join(' '),
#     '0 2 4 6 7 9 11 13',
#     'chained arithmetic sequence with unreached limits';

# Mixed ...^ and ... -- should that work?
# is (0, 2 ...^ 8, 11 ... 17, 18 ...^ 21).join(' '),
#     '0 2 4 6 11 14 17 18 19 20',
#     'chained arithmetic sequence with exclusion';

#?niecza skip 'Cannot use value like Block as a number'
#?rakudo todo 'gives True instead'
is (1, *+1  ... { $_ < 5 }, 5, *+10  ... { $_ < 35 }, 35, *+100 ... { $_ < 400 }).join(' '),
    '1 2 3 4 5 15 25 35 135 235 335',
    'simple chained sequence with closures';
#?niecza skip 'Unable to resolve method chars in class Block'
#?rakudo skip 'Not enough positional parameters passed; got 0 but expected 1'
is (1, { $^n*2 + 1 } ... 31, *+5 ... { $^n**2 < 2000 }, 'a', *~'z' ... { $_.chars < 6 }).join(' '), 
    '1 3 7 15 31 36 41 a az azz azzz azzzz',
    'chained sequence with closures';

# The following is now an infinite sequence...
# is (1, 2 ... 0, 1 ... 3).join(' '),
#     '0 1 2 3',
#     'chained sequence with an empty subsequence';

{
    my @rt80574 := -> { 'zero', 'one' } ... *;
    #?rakudo todo 'RT 80574'
    is @rt80574[0], 'zero', 'Generator output is flattened';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-sequence/nonnumeric.t0000664000175000017500000001312512224265625020525 0ustar  moritzmoritzuse v6;
use Test;
 
plan 37;

# L is assumed'>

#?rakudo skip 'hangs'
#?niecza skip 'Two definitions found for symbol ::GLOBAL::&infix: (etc)'
{
    class Alternating {
        has Int $.val;
        method Str { 'A' ~ $.val }
        method succ { Alternating.new(val => -($.val + 1)) }
        method pred { Alternating.new(val => -($.val - 1)) }
    }
    multi infix: (Alternating $x, Alternating $y) { abs($x.val) cmp abs($y.val) }
    multi infix: (Alternating $x, Int $n)         { abs($x.val) cmp abs($n) }
    multi infix: (Alternating $x, Alternating $y) { abs($x.val) eqv abs($y.val) }
    multi infix: (Alternating $x, Int $n)         { abs($x.val) eqv abs($n) }
    my $f = { Alternating.new(val => $^v) };

    is ($f(0) ... $f(4)).join(' '), 'A0 A-1 A2 A-3 A4', 'finite increasing sequence with user class (1)';
    is ($f(0) ... 4).join(' '), 'A0 A-1 A2 A-3 A4', 'finite increasing sequence with user class (2)';
    is ($f(-9) ... 4).join(' '), 'A-9 A8 A-7 A6 A-5 A4', 'finite decreasing sequence with user class';
    is ($f(-9) ...^ 4).join(' '), 'A-9 A8 A-7 A6 A-5', 'finite decreasing exclusive sequence with user class (1)';
    is ($f(-9) ...^ -4).join(' '), 'A-9 A8 A-7 A6 A-5 A4', 'finite decreasing exclusive sequence with user class (2)';
    is ($f(2), { $_.succ.succ } ... 10).join(' '), 'A2 A4 A6 A8 A10', 'finite sequence with closure and user class (1)';
    is ($f(2), { $_.succ.succ } ... 9).join(' '), 'A2 A4 A6 A8', 'finite sequence with closure and user class (2)';
    is ($f(1), { $_.succ.succ } ... { $_.v**2 < 100 }).join(' '), 'A1 A3 A5 A7 A9', 'finite sequence with closure, termination function, and user class';
    is ($f(2) ... *)[^5].join(' '), 'A2 A-3 A4 A-5 A6', 'infinite increasing sequence with user class';
    is ($f(2), $f(1) ... *)[^5].join(' '), 'A2 A1 A0 A1 A-2', 'infinite decreasing sequence with user class';
    is ($f(0), $f(0) ... *)[^5].join(' '), 'A0 A0 A0 A0 A0', 'constant sequence with user class';
}

# L
# character sequence

is ('a'  ... 'g').join(', '), 'a, b, c, d, e, f, g', 'finite sequence started with one letter';
is ('a'  ... *).[^7].join(', '), 'a, b, c, d, e, f, g', 'sequence started with one letter';
is ('a', 'b' ... *).[^10].join(', '), 'a, b, c, d, e, f, g, h, i, j', 'sequence started with two different letters';
is ( ... *).[^10].join(', '), "a, b, c, d, e, f, g, h, i, j", "character sequence started from array";
is ('z' ... 'a').[^10].join(', '), 'z, y, x, w, v, u, t, s, r, q', 'descending sequence started with one letter';
is ( ... 'a').[^10].join(', '), 'z, y, x, w, v, u, t, s, r, q', 'descending sequence started with two different letters';
is ( ... 'a').[^10].join(', '), 'z, y, m, l, k, j, i, h, g, f', 'descending sequence started with three different letters';
is (, { .succ } ... *).[^7].join(', '), 'a, b, c, d, e, f, g', 'characters xand arity-1';
is ('x' ... 'z').join(', '), 'x, y, z', "sequence ending with 'z' don't cross to two-letter strings";
is ('A' ... 'z').elems, 'z'.ord - 'A'.ord + 1, "sequence from 'A' to 'z' is finite and of correct length";
is ('α' ... 'ω').elems, 'ω'.ord - 'α'.ord + 1, "sequence from 'α' to 'ω' is finite and of correct length";
is ('☀' ... '☕').join(''), '☀☁☂☃☄★☆☇☈☉☊☋☌☍☎☏☐☑☒☓☔☕', "sequence from '☀' to '☕'";
is ('☀' ...^ '☕').join(''), '☀☁☂☃☄★☆☇☈☉☊☋☌☍☎☏☐☑☒☓☔', "exclusive sequence from '☀' to '☕'";

# # L
# the tricky termination test

#?niecza skip 'munch not implemented'
{
    ok ('A' ... 'ZZ').munch(1000).elems < 1000, "'A' ... 'ZZ' does not go on forever";
    #?rakudo 2 skip 'Decrement out of range'
    ok ('ZZ' ... 'A').munch(1000).elems < 1000, "'ZZ' ... 'A' does not go on forever";
    ok ('Z' ... 'AA').munch(1000).elems < 1000, "'Z' ... 'AA' does not go on forever";
}

is ('A' ...^ 'ZZ')[*-1], 'ZY', "'A' ...^ 'ZZ' omits last element";

# be sure the test works as specced even for user classes
#?rakudo skip 'lifting comparison ops'
#?niecza skip 'Two definitions found for symbol ::GLOBAL::&infix: (etc)'
{
    class Periodic {
        has Int $.val;
        method Str { 'P' ~ $.val }
        method succ { Periodic.new(val => ($.val >= 2 ?? 0 !! $.val + 1)) }
        method pred { Periodic.new(val => ($.val <= 0 ?? 2 !! $.val - 1)) }
    }
    multi infix: (Periodic $x, Periodic $y) { $x.val cmp $y.val }
    multi infix: (Periodic $x, Int $n)      { $x.val cmp $n }
    multi infix: (Periodic $x, Periodic $y) { $x.val eqv $y.val }
    multi infix: (Periodic $x, Int $n)      { $x.val eqv $n }
    my $f = { Periodic.new(val => $^v) };
    
    is ($f(0) ... 5)[^7].join(' '), 'P0 P1 P2 P0 P1 P2 P0', 'increasing periodic sequence';
    is ($f(0) ... -1)[^7].join(' '), 'P0 P2 P1 P0 P2 P1 P0', 'decreasing periodic sequence';

    is ($f(0) ... 2).join(' '), 'P0 P1 P2', 'increasing not-quite-periodic sequence';
    is ($f(2) ... 0).join(' '), 'P2 P1 P0', 'decreasing not-quite-periodic sequence';
    is ($f(0) ...^ 2).join(' '), 'P0 P1', 'exclusive increasing not-quite-periodic sequence';
    is ($f(2) ...^ 0).join(' '), 'P2 P1', 'exclusive decreasing not-quite-periodic sequence';
}

is ('1a', '1b' ... '1e').Str, '1a 1b 1c 1d 1e', 'sequence with strings that starts with a digit but cannot convert to numbers';

#RT #118519
{
    is ('▁' ... '█').Str, "▁ ▂ ▃ ▄ ▅ ▆ ▇ █", "unicode blocks";
    is ('.' ... '0').Str, ". / 0",             "mixture";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-any.t0000664000175000017500000000130512224265625020254 0ustar  moritzmoritzuse v6;
use Test;
plan 8;

#L
{
    class Smartmatch::ObjTest {}
    my $a = Smartmatch::ObjTest.new;
    my $b = Smartmatch::ObjTest.new;
    ok  ($a ~~  $a),    'Any ~~  Any (+)';
    ok !($a !~~ $a),    'Any !~~ Any (-)';
    #?pugs 2 todo
    ok !($a ~~  $b),    'Any ~~  Any (-)';
    ok  ($a !~~ $b),    'Any !~~ Any (+)';
}


{
    $_ = 42;
    my $x;
    'abc' ~~ ($x = $_);
    #?pugs todo
    is $x, 'abc', '~~ sets $_ to the LHS';
    is $_, 42, 'original $_ restored';
    'defg' !~~ ($x = $_);
    #?pugs todo
    is $x, 'defg', '!~~ sets $_ to the LHS';
    is $_, 42, 'original $_ restored';
    'defg' !~~ ($x = $_);
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-array.t0000664000175000017500000000137512224265625020612 0ustar  moritzmoritzuse v6;
use Test;
plan 6;

#L
{
    class TestArraySmartmatch {
        has @!obj;
        multi method list() { @!obj };
    }

    my $o = TestArraySmartmatch.new(obj => (1, 2, 4));

    #?rakudo todo 'nom regression'
    #?niecza todo
    #?pugs todo
    ok  ($o ~~ [1, 2, 4]),      'Any ~~ Array (basic, +)';
    ok !($o ~~ [1, 5, 4]),      'Any ~~ Array (basic, -)';
    #?rakudo todo 'nom regression'
    #?niecza todo
    #?pugs todo
    ok  ($o ~~ [1, *]),         'Any ~~ Array (dwim, +)';
    ok !($o ~~ [8, *]),         'Any ~~ Array (dwim, -)';
    ok  (1  ~~ [1]),            'Any ~~ Array (Int, +)';
    ok !(1  ~~ [1, 2]),         'Any ~~ Array (Int, -, it is not any())';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-bool.t0000664000175000017500000000112712224265625020422 0ustar  moritzmoritzuse v6;
use Test;
plan 8;

#L

{
    sub is-true() { True };
    sub is-false() { False };
    #?pugs 2 todo
    ok   0  ~~ is-true(),      '~~ non-syntactic True';
    ok  'a' ~~ is-true(),      '~~ non-syntactic True';
    nok  0  ~~ is-false(),     '~~ non-syntactic True';
    nok 'a' ~~ is-false(),     '~~ non-syntactic True';

}

{
    nok  0   ~~ .so,           'boolean truth';
    ok   'a' ~~ .so,           'boolean truth';
    ok   0   ~~ .not,          'boolean truth';
    nok  'a' ~~ .not,          'boolean truth';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-callable.t0000664000175000017500000000120212224265625021220 0ustar  moritzmoritzuse v6;
use Test;
plan 6;

#L
{
    sub is_even($x) { $x % 2 == 0 }
    sub is_odd ($x) { $x % 2 == 1 }
    ok 4 ~~ &is_even,    'scalar sub truth (unary)';
    ok 4 !~~ &is_odd,    'scalar sub truth (unary, negated smart-match)';
    ok !(3 ~~ &is_even), 'scalar sub truth (unary)';
    ok !(3 !~~ &is_odd), 'scalar sub truth (unary, negated smart-match)';
}

#L
{
    sub uhuh { 1 }
    sub nuhuh { Mu }

    ok((Mu ~~ &uhuh), "scalar sub truth");
    ok(!(Mu ~~ &nuhuh), "negated scalar sub false");
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-complex.t0000664000175000017500000000142012224265625021132 0ustar  moritzmoritzuse v6;
use Test;
plan 12;

{
    ok (1 + 2i)    ~~ (1 + 2i),  'Complex  ~~ Complex (+)';
    ok !((1 + 2i)  ~~ (1 + 1i)), 'Complex  ~~ Complex (-)';
    ok !((1 + 2i)  ~~ (2 + 2i)), 'Complex  ~~ Complex (-)';
    ok !((1 + 2i) !~~ (1 + 2i)), 'Complex !~~ Complex (-)';
    ok (1 + 2i)   !~~ (1 + 1i),  'Complex !~~ Complex (+)';
    ok (1 + 2i)   !~~ (2 + 2i),  'Complex !~~ Complex (+)';
    #?pugs todo
    ok 3           ~~ (3 + 0i),  'Num  ~~ Complex (+)';
    ok !(2         ~~ (3 + 0i)), 'Num  ~~ Complex (-)';
    ok !(3         ~~ (3 + 1i)), 'Num  ~~ Complex (-)';
    #?pugs todo
    ok !(3        !~~ (3 + 0i)), 'Num !~~ Complex (-)';
    ok  (2        !~~ (3 + 0i)), 'Num !~~ Complex (+)';
    ok  (3        !~~ (3 + 1i)), 'Num !~~ Complex (+)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-hash-pair.t0000664000175000017500000000114412224265625021342 0ustar  moritzmoritzuse v6;
use Test;
plan 7;

#L
{
    my %a = (a => 1, b => 'foo', c => Mu);
    ok  (%a ~~ b => 'foo'),         '%hash ~~ Pair (Str, +)';
    ok !(%a ~~ b => 'ugh'),         '%hash ~~ Pair (Str, -)';
    ok  (%a ~~ a => 1.0),           '%hash ~~ Pair (Num, +)';
    ok  (%a ~~ :b),            '%hash ~~ Colonpair';
    ok  (%a ~~ c => !*.defined),    '%hash ~~ Pair (!*.defined, Mu)';
    ok  (%a ~~ d => !*.defined),    '%hash ~~ Pair (!*.defined, Nil)';
    ok !(%a ~~ a => 'foo'),         '%hash ~~ Pair (key and val not paired)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-method.t0000664000175000017500000000053112224265625020745 0ustar  moritzmoritzuse v6;
use Test;
plan 4;

{
    #?pugs todo
    nok 'ab' ~~ .uc, 'smart-match happens after method calls on $_ 1';
     ok 'AA' ~~ .uc, 'smart-match happens after method calls on $_ 2';
}

{
    #?pugs todo
    nok 'ab' ~~ .substr(1), 'method call with args 1';
     ok 'ab' ~~ .substr(0), 'method call with args 2';

}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-num.t0000664000175000017500000000267412224265625020276 0ustar  moritzmoritzuse v6;
use Test;
plan 18;

#L
{
    ok   (5 ~~ 5),               'Int ~~ Int works';
    nok  (5 ~~ 6),               'Int ~~ Int works';

    #?pugs todo
    ok   ('05' ~~ 5),            '$something ~~ Int numifies';
    #?pugs todo 'Rat'
    ok   ('05' ~~ 5.Rat),        '$something ~~ Rat numifies';
    #?pugs todo 'Num'
    ok   ('05' ~~ 5.Num),        '$something ~~ Num numifies';

    ok  ('1.2' ~~ 1.2),         '$thing ~~ Rat does numeric comparison';
    ok  ('1.2' ~~ 1.2.Num),     '$thing ~~ Num does numeric comparison';

    # yes, this warns, but it should still be true
    #?rakudo 2 skip "Mu ~~ Num doesn't work yet"
    #?niecza skip 'Nominal type check failed for #1'
    #?pugs todo 'Mu'
    ok  (Mu ~~ 0),              'Mu ~~ 0';
    #?niecza skip 'Nominal type check failed for #1'
    ok !(Mu ~~ 2.3),            'Mu ~~ $other_number';

    #?pugs todo
    ok  (3+0i  ~~ 3),           'Complex ~~ Int (+)';
    nok (3+1i  ~~ 3),           'Complex ~~ Int (-)';
    nok (4+0i  ~~ 3),           'Complex ~~ Int (-)';
    #?pugs todo
    ok  (3+0i  ~~ 3.Rat),       'Complex ~~ Rat (+)';
    nok (3+1i  ~~ 3.Rat),       'Complex ~~ Rat (-)';
    nok (4+0i  ~~ 3.Rat),       'Complex ~~ Rat (-)';
    #?pugs todo
    ok  (3+0i  ~~ 3.Num),       'Complex ~~ Num (+)';
    nok (3+1i  ~~ 3.Num),       'Complex ~~ Num (-)';
    nok (4+0i  ~~ 3.Num),       'Complex ~~ Num (-)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-pair.t0000664000175000017500000000232312224265625020421 0ustar  moritzmoritzuse v6;
use Test;
plan 10;

#L
{
    # ?."{X.key}" === ?X.value
    # means:
    # call the method with the name of X.key on the object, coerce to
    # Bool, and check if it's the same as boolean value of X.value

    class SmartmatchTest::AttrPair {
        has $.a = 4;
        has $.b = 'foo';
        has $.c = Mu;
    }
    my $o = SmartmatchTest::AttrPair.new();
    ok  ($o ~~ :a(4)),      '$obj ~~ Pair (Int, +)';
    ok  ($o ~~ :a(2)),      '$obj ~~ Pair (Int, +)';
    ok !($o ~~ :b(0)),      '$obj ~~ Pair (different types)';
    ok  ($o ~~ :b),    '$obj ~~ Pair (Str, +)';
    ok  ($o ~~ :b),    '$obj ~~ Pair (Str, -)';
    ok  ($o ~~ :c(Mu)),     '$obj ~~ Pair (Mu, +)';
    ok  ($o ~~ :c(0)),      '$obj ~~ Pair (0, +)';
    ok !($o ~~ :b(Mu)),     '$obj ~~ Pair (Mu, -)';
    # not explicitly specced, but implied by the spec and decreed 
    # by TimToady: non-existing method or attribute dies:
    # http://irclog.perlgeek.de/perl6/2009-07-06#i_1293199
    #?niecza todo
    dies_ok {$o ~~ :e(Mu)},  '$obj ~~ Pair, nonexistent, dies (1)';
    #?niecza todo
    dies_ok {$o ~~ :e(5)},      '$obj ~~ Pair, nonexistent, dies (2)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-str.t0000664000175000017500000000066712224265625020307 0ustar  moritzmoritzuse v6;
use Test;
plan 5;

#L
{
    ok(!("foo" !~~ "foo"),  "!(foo ne foo)");
    ok(("bar" !~~ "foo"),   "bar ne foo)");
    ok  (4 ~~ '4'),         'string equality';
    ok !(4 !~~ '4'),        'negated string equality';
    #?rakudo skip 'smartmatching Mu against Str'
    #?niecza skip 'Mu as argument'
    #?pugs todo 'Mu'
    ok  (Mu ~~ ''),         'Mu ~~ ""';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-sub.t0000664000175000017500000000121012224265625020251 0ustar  moritzmoritzuse v6;
use Test;

#L
{
    my $t = sub { Bool::True };
    my $f = sub { Bool::False };
    my $mul = sub ($x) { $x * 2 };
    my $sub = sub ($x) { $x - 2 };

    ok ($t ~~ .()),     '~~ .() sub call truth (+)';
    ok !($f ~~ .()),    '~~ .() sub call truth (-)';
    ok  ('anything' ~~ $t), '~~ sub call truth (+)';
    ok !('anything' ~~ $f), '~~ sub call truth (-)';
    ok  (2 ~~ $mul),    '~~ sub call truth (+,1)';
    ok !(0 ~~ $mul),    '~~ sub call truth (-,1)';
    ok !(2 ~~ $sub),    '~~ sub call truth (+,2)';
    ok  (0 ~~ $sub),    '~~ sub call truth (-,2)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/any-type.t0000664000175000017500000000254612224265625020456 0ustar  moritzmoritzuse v6;
use Test;
plan 15;

#L
{ 
    class Dog {}
    class Cat {}
    class Chihuahua is Dog {} # i'm afraid class Pugs will get in the way ;-)
    role SomeRole { };
    class Something does SomeRole { };

    ok (Chihuahua ~~ Dog), "chihuahua isa dog";
    ok (Something ~~ SomeRole), 'something does dog';
    ok !(Chihuahua ~~ Cat), "chihuahua is not a cat";
}

# RT #71462
{
    is 'RT71462' ~~ Str,      True,  '~~ Str returns a Bool (1)';
    is 5         ~~ Str,      False, '~~ Str returns a Bool (2)';
    is 'RT71462' ~~ Int,      False, '~~ Int returns a Bool (1)';
    is 5         ~~ Int,      True,  '~~ Int returns a Bool (2)';
    #?pugs 2 skip 'Set'
    is 'RT71462' ~~ Set,      False, '~~ Set returns a Bool (1)';
    is set(1, 3) ~~ Set,      True,  '~~ Set returns a Bool (2)';
    #?pugs 2 skip 'Numeric'
    is 'RT71462' ~~ Numeric,  False, '~~ Numeric returns a Bool (1)';
    is 5         ~~ Numeric,  True,  '~~ Numeric returns a Bool (2)';
    #?pugs 2 skip 'Callable'
    is &say      ~~ Callable, True,  '~~ Callable returns a Bool (1)';
    is 5         ~~ Callable, False, '~~ Callable returns a Bool (2)';
}

# RT 76610
{
    module M { };
    #?niecza todo "Unable to resolve method ACCEPTS in type M"
    lives_ok { 42 ~~ M }, '~~ module lives';
    ok not $/, '42 is not a module';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/array-array.t0000664000175000017500000000646712224265625021150 0ustar  moritzmoritzuse v6;
use Test;
plan 36;

#L
{
    ok((("blah", "blah") ~~ ("blah", "blah")), "qw/blah blah/ .eq");
    ok(!((1, 2) ~~ (1, 1)), "1 2 !~~ 1 1");
    ok(!((1, 2, 3) ~~ (1, 2)), "1 2 3 !~~ 1 2");
    ok(!((1, 2) ~~ (1, 2, 3)), "1 2 !~~ 1 2 3");
    ok(!([] ~~ [1]), "array smartmatch boundary conditions");
    ok(!([1] ~~ []), "array smartmatch boundary conditions");
    ok(([] ~~ []), "array smartmatch boundary conditions");
    ok(([1] ~~ [1]), "array smartmatch boundary conditions");
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,*), 'array smartmatch dwims * at end');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,*,*), 'array smartmatch dwims * at end (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (*,4), 'array smartmatch dwims * at start');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (*,*,4), 'array smartmatch dwims * at start (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,*,3,4), 'array smartmatch dwims * 1 elem');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,*,*,3,4), 'array smartmatch dwims * 1 elem (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,*,4), 'array smartmatch dwims * many elems');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,*,*,4), 'array smartmatch dwims * many elems (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (*,3,*), 'array smartmatch dwims * at start and end');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (*,*,3,*,*), 'array smartmatch dwims * at start and end (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (*,1,2,3,4), 'array smartmatch dwims * can match nothing at start');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (*,*,1,2,3,4), 'array smartmatch dwims * can match nothing at start (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,2,*,3,4), 'array smartmatch dwims * can match nothing in middle');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,2,*,*,3,4), 'array smartmatch dwims * can match nothing in middle (many *s)');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,2,3,4,*), 'array smartmatch dwims * can match nothing at end');
    #?niecza todo
    #?pugs todo
    ok((1,2,3,4) ~~ (1,2,3,4,*,*), 'array smartmatch dwims * can match nothing at end (many *s)');
    ok(!((1,2,3,4) ~~ (1,*,3)), '* dwimming does not cause craziness');
    ok(!((1,2,3,4) ~~ (*,5)), '* dwimming does not cause craziness');
    ok(!((1,2,3,4) ~~ (1,3,*)), '* dwimming does not cause craziness');

    # now try it with arrays as well
    my @a = 1, 2, 3;
    my @b = 1, 2, 4;
    my @m = (*, 2, *); # m as "magic" ;-)

    ok (@a ~~  @a), 'Basic smartmatching on arrays (positive)';
    ok (@a !~~ @b), 'Basic smartmatching on arrays (negative)';
    ok (@b !~~ @a), 'Basic smartmatching on arrays (negative)';
    #?niecza todo
    #?pugs todo
    ok (@a ~~  @m), 'Whatever dwimminess in arrays';
    ok (@a ~~ (1, 2, 3)), 'smartmatch Array ~~ List';
    ok ((1, 2, 3) ~~ @a), 'smartmatch List ~~ Array';
    #?niecza todo
    #?pugs todo
    ok ((1, 2, 3) ~~ @m), 'smartmatch List ~~ Array with dwim';

    ok (1 ~~ *,1,*),     'smartmatch with Array RHS co-erces LHS to list';
    ok (1..10 ~~ *,5,*), 'smartmatch with Array RHS co-erces LHS to list';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/array-hash.t0000664000175000017500000000114012224265625020734 0ustar  moritzmoritzuse v6;
use Test;
plan 6;

#L
{
    my %h = (a => 'b', c => Mu);
    #?pugs todo
    ok  (['a']      ~~ %h), 'Array ~~ Hash (exists and True)';
    #?pugs todo
    ok  (['c']      ~~ %h), 'Array ~~ Hash (exists but Mu)';
    #?pugs todo
    ok  ([]    ~~ %h), 'Array ~~ Hash (both exist)';
    #?pugs todo
    ok  ([]    ~~ %h), 'Array ~~ Hash (one exists)';
    # note that ?any() evaluates to False
    ok !( ()        ~~ %h), 'Array ~~ Hash (empty list)';
    ok !(['e']      ~~ %h), 'Array ~~ Hash (not exists)';

}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/capture-signature.t0000664000175000017500000000132012224265625022337 0ustar  moritzmoritzuse v6;

use Test;

plan 5;

sub t1(%h) {
    given %h {
        when :(Int :$a) { "pivo" }
        when :(Str :$a) { "slivovica" }
    }
}
my %h = a => 42;
is t1(%h), "pivo", "signature smart-match against hash works (1)";
%h = "moja draha";
is t1(%h), "slivovica", "signature smart-match against hash works (1)";


sub t2(@a) {
    given @a {
        when :($a)     { "godis" }
        when :($a, $b) { "om nom nom" }
    }
}
is t2([1]), "godis", "signature smart-match against array works (1)";
is t2([1,2]), "om nom nom", "signature smart-match against array works (2)";

# RT #77164
sub f($ = rand) { };
ok \() ~~ &f.signature, 'can smart-match against a signature with a default value';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/disorganized.t0000664000175000017500000000730112224265625021364 0ustar  moritzmoritzuse v6;
use Test;
plan 41;

=begin pod

This tests the smartmatch operator, defined in L

=end pod

sub eval_elsewhere($code){ eval($code) }

#L
{ 
    ok("foo" ~~ .defined, "foo is ~~ .defined");
    #?pugs todo
    nok "foo" !~~ .defined,   'not foo !~~ .defined';
    nok((Mu ~~ .defined), "Mu is not .defined");
}

# TODO: 
# Set   Set
# Hash  Set
# Any   Set
# Set   Array
# Set   Hash
# Any   Hash

# Regex tests are in spec/S05-*

#L
{ 
    # more range tests in t/spec/S03-operators/range.t
    #?pugs todo
    ok((5 ~~ 1 .. 10), "5 is in 1 .. 10");
    ok(!(10 ~~ 1 .. 5), "10 is not in 1 .. 5");
    ok(!(1 ~~ 5 .. 10), "1 is not i n 5 .. 10");
    ok(!(5 ~~ 5 ^..^ 10), "5 is not in 5 .. 10, exclusive");
};

# TODO:
# Signature Signature
# Callable  Signature
# Capture   Signature
# Any       Signature

# Signature Capture  

# reviewed by moritz on 2009-07-07 up to here.

=begin Explanation

You may be wondering what the heck is with all these try blocks.
Prior to r12503, this test caused a horrible death of Pugs which
magically went away when used inside an eval.  So the try blocks
caught that case.

=end Explanation

{
    my $result = 0;
    my $parsed = 0;
    my @x = 1..20;
    try {
        $result = all(@x) ~~ { $_ < 21 };
        $parsed = 1;
    };
    ok $parsed, 'C parses';
    ok ?$result, 'C
my %hash1 = ( "foo" => "Bar", "blah" => "ding");
my %hash2 = ( "foo" => "zzz", "blah" => "frbz");
my %hash3 = ( "oink" => "da", "blah" => "zork");
my %hash4 = ( "bink" => "yum", "gorch" => "zorba");
my %hash5 = ( "foo" => 1, "bar" => 1, "gorch" => Mu, "baz" => Mu );

{
    #?rakudo todo 'nom regression'
    #?pugs todo
    ok  (%hash1 ~~ %hash2), 'Hash ~~ Hash (same keys, +)';
    ok !(%hash1 ~~ %hash3), 'Hash ~~ Hash (same keys, -)';
    #?pugs todo
    #?rakudo todo 'nom regression'
    ok eval_elsewhere('(%hash1 ~~ %hash2)'), "hash keys identical";
    ok eval_elsewhere('!(%hash1 ~~ %hash4)'), "hash keys differ";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/range-range.t0000664000175000017500000000225112224265625021067 0ustar  moritzmoritzuse v6;
use Test;
plan 14;

#L
{
    # .bounds.all ~~ X (mod ^'s)
    # means:
    # check whether both .min and .max are inside of the Range X
    # (though this is only true to a first approximation, as
    # those .min and .max values might be excluded)

    ok  (2..3 ~~ 1..4),     'proper inclusion +';
    ok !(1..4 ~~ 2..3),     'proper inclusion -';
    ok  (2..4 ~~ 1..4),     'inclusive vs inclusive right end';
    ok  (2..^4 ~~ 1..4),    'exclusive vs inclusive right end';
    ok !(2..4 ~~ 1..^4),    'inclusive vs exclusive right end';
    ok  (2..^4 ~~ 1..^4),   'exclusive vs exclusive right end';
    ok  (2..3 ~~ 2..4),     'inclusive vs inclusive left end';
    ok  (2^..3 ~~ 2..4),    'exclusive vs inclusive left end';
    ok !(2..3 ~~ 2^..4),    'inclusive vs exclusive left end';
    ok  (2^..3 ~~ 2^..4),   'exclusive vs exclusive left end';
    ok  (2..3 ~~ 2..3),     'inclusive vs inclusive both ends';
    ok  (2^..^3 ~~ 2..3),   'exclusive vs inclusive both ends';
    ok !(2..3 ~~ 2^..^3),   'inclusive vs exclusive both ends';
    ok  (2^..^3 ~~ 2^..^3), 'exclusive vs exclusive both ends';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/regex-hash.t0000664000175000017500000000054412224265625020737 0ustar  moritzmoritzuse v6;
use Test;
plan 4;

#L
{
    my %h = (moep => 'foo', bar => 'baz');
    ok  (/oep/ ~~ %h),      'Regex ~~ Hash (+,1)';
    ok  (/bar/ ~~ %h),      'Regex ~~ Hash (+,2)';
    ok !(/ugh/ ~~ %h),      'Regex ~~ Hash (-,1)';
    ok !(/foo/ ~~ %h),      'Regex ~~ Hash (-,value)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/scalar-hash.t0000664000175000017500000000046412224265625021073 0ustar  moritzmoritzuse v6;
use Test;
plan 3;

#L
{
    my %h = (moep => 'foo', bar => Mu);
    ok  ('moep' ~~ %h),     'Cool ~~ Hash (+, True)';
    ok  ('bar' ~~ %h),      'Cool ~~ Hash (+, False)';
    ok !('foo' ~~ %h),      'Cool ~~ Hash (-)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S03-smartmatch/signature-signature.t0000664000175000017500000000104112224265625022675 0ustar  moritzmoritzuse v6;
use Test;
plan 5;

#L
{
	ok  :(Str)      ~~ :(Str),           'signature :(Str) is the same as :(Str)';
	nok :(Str)      ~~ :(Int),           'signature :(Str) is not the same as :(Int)';
	ok  :(Str, Int) ~~ :(Str, Int),      'signature :(Str, Int) is the same as :(Str, Int)';
	nok :(Str, Int) ~~ :(Int, Str),      'signature :(Str, Int) is not the same as :(Int, Str)';
	nok :(Str, Int) ~~ :(Str, Int, Str), 'signature :(Str, Int) is not the same as :(Str, Int, Str)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-blocks-and-statements/let.t0000664000175000017500000000344712224265625021535 0ustar  moritzmoritzuse v6;

use Test;

plan 12;

# L
# L
# let() should not restore the variable if the block exited successfully
# (returned a true value).
{
  my $a = 42;
  {
    is((let $a = 23; $a), 23, "let() changed the variable (1)");
    1;
  }
  is $a, 23, "let() should not restore the variable, as our block exited succesfully (1)";
}

# let() should restore the variable if the block failed (returned a false
# value).
{
  my $a = 42;
  {
    is((let $a = 23; $a), 23, "let() changed the variable (1)");
    Mu;
  }
  is $a, 42, "let() should restore the variable, as our block failed";
}

# Test that let() restores the variable at scope exit, not at subroutine
# entry.  (This might be a possibly bug.)
{
  my $a     = 42;
  my $get_a = { $a };
  {
    is((let $a = 23; $a),       23, "let() changed the variable (2-1)");
    is $get_a(), 23, "let() changed the variable (2-2)";
    1;
  }
  is $a, 23, "let() should not restore the variable, as our block exited succesfully (2)";
}

# Test that let() restores variable even when not exited regularly (using a
# (possibly implicit) call to return()), but when left because of an exception.
{
  my $a = 42;
  try {
    is((let $a = 23; $a), 23, "let() changed the variable in a try block");
    die 57;
  };
  is $a, 42, "let() restored the variable, the block was exited using an exception";
}

{
  my @array = (0, 1, 2);
  {
    is((let @array[1] = 42; @array[1]), 42, "let() changed our array element");
    Mu;
  }
  is @array[1], 1, "let() restored our array element";
}

#?niecza skip "'fail' used at line 68"
{
    my $x = 5;
    sub f() {
        let $x = 10;
        fail 'foo';
    }
    my $sink = f(); #OK
    is $x, 5, 'fail() resets let variables';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-blocks-and-statements/pointy-rw.t0000664000175000017500000000266512224265625022722 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

We ought to be able to change a value when aliasing into it.

# L statement/by including the is rw trait>

=end pod

plan 10;

#?pugs 8 todo 'rw aliasing'

{
    my %h = 1..4;
    lives_ok {
        for %h.values -> $v is rw { $v += 1 }
    }, 'aliases returned by %hash.values should be rw (1)';

    is %h<3>, 5, 'aliases returned by %hash.values should be rw (2)';
}

{
    my %h = 1..4;
    lives_ok {
        for %h.values <-> $v { $v += 1 }
    }, 'aliases returned by %hash.values should be rw (<->) (1)';

    is %h<3>, 5, 'aliases returned by %hash.values should be rw (<->) (2)';
}

{
    my @a = 1..4;
    lives_ok {
        for @a.values -> $v is rw { $v += 1 }
    }, 'aliases returned by @array.values should be rw (1)';

    is @a[2], 4, 'aliases returned by @array.values should be rw (2)';
}

{
    my $pair = (a => 42);
    #?niecza todo
    lives_ok {
        for $pair.value -> $v is rw { $v += 1 }
    }, 'aliases returned by $pair.values should be rw (1)';

    #?niecza todo
    is $pair.value, 43, 'aliases returned by $pair.values should be rw (2)';
}

{
    my $var  = 42;
    my $pair = (a => $var);
    lives_ok {
        for $pair.value -> $v is rw { $v += 1 }
    }, 'aliases returned by $pair.values should be rw (1)';

    is $pair.value, 43, 'aliases returned by $pair.values should be rw (2)';
}

# (currently this dies with "Can't modify constant item: VInt 2")

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-blocks-and-statements/pointy.t0000664000175000017500000000571412224265625022272 0ustar  moritzmoritzuse v6;

use Test;

plan 17;

=begin description

Test pointy sub behaviour described in S06

=end description

# L
my ($sub, $got);

$got = '';
$sub = -> $x { $got = "x $x" };
$sub.(123);
is $got, 'x 123', 'pointy sub without param parens';

$got = '';
-> $x { $got = "x $x" }.(123);
is $got, 'x 123', 'called pointy immediately: -> $x { ... }.(...)';

$got = '';
-> $x { $got = "x $x" }(123);
is $got, 'x 123', 'called pointy immediately: -> $x { ... }(...)';


# L
my @a;
lives_ok { @a = ("one", -> $x { $x**2 }, "three")} , 
        'pointy sub without preceding comma';
is @a[0], 'one', 'pointy sub in list previous argument';
isa_ok @a[1], Code, 'pointy sub in list';
is @a[2], 'three', 'pointy sub in list following argument';


# L
my $n = 1;
my $s = -> { 
    last if $n == 10;
    $n++;
    redo if $n < 10;
};
dies_ok $s, 'pointy with block control exceptions';
#?rakudo todo 'pointy blocks and last/redo'
#?niecza todo
#?pugs todo
is $n, 10, "pointy control exceptions ran";

# L
my $str = '';

sub outer {  
    my $s = -> { 
        #?rakudo todo '&?ROUTINE'
        #?niecza todo 'Unable to resolve method name in class Sub'
        is(&?ROUTINE.name, '&Main::outer', 'pointy still sees outer\'s &?ROUTINE'); 

        $str ~= 'inner'; 
        return 'inner ret'; 
    };
    $s.(); 
    $str ~= 'outer';
    return 'outer ret';
}

is outer(), 'inner ret', 'return in pointy returns from enclosing sub';
is $str, 'inner', 'return in pointy returns from enclosing sub';

# What about nested pointies -> { ... -> {} }?


# L
# Coming soon...


# -> { $^a, $^b } is illegal; you can't mix real sigs with placeholders,
# and the -> introduces a sig of ().  TimToady #perl6 2008-May-24
#?pugs todo
eval_dies_ok(q{{ -> { $^a, $^b } }}, '-> { $^a, $^b } is illegal');

# RT #61034

lives_ok {my $x = -> {}; my $y = $x(); }, 
         'can define and execute empty pointy block';

# The default type of pointy blocks is Mu, not Any. See 
# http://www.nntp.perl.org/group/perl.perl6.language/2009/03/msg31181.html
# L
# this means that junctions don't autothread over pointy blocks

#?niecza skip 'Could not find non-existent sub junction'
#?pugs skip 'No such subroutine: "&junction'
{
    my @a = any(3, 4);
    my $ok = 0;
    my $iterations = 0;
    for @a -> $x {
        $ok = 1 if $x ~~ Junction;
        $iterations++;
    }
    ok $ok, 'Blocks receive junctions without autothreading';
    is $iterations, 1, 'no autothreading happened';
    my $b = -> $x { ... };
    ok $b.signature.perl !~~ /Any/, 
       'The .signature of a block does not contain Any';
}

# vim: ft=perl6

rakudo-2013.12/t/spec/S04-blocks-and-statements/temp.t0000775000175000017500000001212112224265625021706 0ustar  moritzmoritzuse v6;

use Test;

plan 36;

# L
{
  my $a = 42;
  {
    is((temp $a = 23; $a), 23, "temp() changed the variable (1)");
  }
  is $a, 42, "temp() restored the variable (1)";
}

# Test that temp() restores the variable at scope exit, not at subroutine
# entry.
{
  my $a     = 42;
  my $get_a = { $a };
  {
    is((temp $a = 23; $a),       23, "temp() changed the variable (2-1)");
    is $get_a(), 23, "temp() changed the variable (2-2)";
  }
  is $a, 42, "temp() restored the variable (2)";
}

# temp() shouldn't change the variable containers
{
  my $a     = 42;
  my $get_a = { $a };
  {
    ok((temp $a = 23; $a =:= $get_a()), "temp() shouldn't change the variable containers");
  }
}

{
  our $pkgvar = 42;
  {
    is((temp $pkgvar = 'not 42'; $pkgvar), 'not 42', "temp() changed the package variable (3-1)");
  }
  is $pkgvar, 42, "temp() restored the package variable (3-2)";
}

# Test that temp() restores variable even when not exited regularly (using a
# (possibly implicit) call to return()), but when left because of an exception.
{
  my $a = 42;
  try {
    is((temp $a = 23; $a), 23, "temp() changed the variable in a try block");
    die 57;
  };
  is $a, 42, "temp() restored the variable, the block was exited using an exception";
}

eval('
{
  my @array = (0, 1, 2);
  {
    temp @array[1] = 42; 
    is @array[1], 42, "temp() changed our array element";
  }
    is @array[1], 1, "temp() restored our array element";
}
"1 - delete this line when the parsefail eval() is removed";
') or skip("parsefail: temp \@array[1]", 2);

{
  my %hash = (:a(1), :b(2), :c(3));
  {
    temp %hash = 42;
    is %hash, 42, "temp() changed our hash element";
  }
  is %hash, 2, "temp() restored our array element";
}

{
  my $struct = [
    "doesnt_matter",
    {
      doesnt_matter => "doesnt_matter",
      key           => [
        "doesnt_matter",
        42,
      ],
    },
  ];

  {
    temp $struct[1][1] = 23;
    is $struct[1][1], 23, "temp() changed our nested arrayref/hashref element";
  }
  is $struct[1][1], 42, "temp() restored our nested arrayref/hashref element";
}

# Block TEMP{}
# L
# (Test is more or less directly from S06.)
#?niecza 2 skip 'spec clarification needed'
{
  my $next    = 0;

  # Here is the real implementation of &advance.
  sub advance() {
    my $curr = $next++;
    TEMP {{ $next = $curr }}  # TEMP block returns the closure { $next = $curr }
    return $curr;
  };

  # and later...

  is advance(), 0, "TEMP{} block (1)";
  is advance(), 1, "TEMP{} block (2)";
  is advance(), 2, "TEMP{} block (3)";
  is $next,     3, "TEMP{} block (4)";

  #?rakudo 4 todo 'TEMP phasers NYI'
  #?pugs 4 todo 'feature'
  flunk "TEMP{} block (5)";
  flunk "TEMP{} block (6)";
  flunk "TEMP{} block (7)";
  flunk "TEMP{} block (8)";

  # Following does parse, but isn't executed (don't know why).
  # If the "{" on the following line is changed to "if 1 {", it is executed,
  # too, but then it dies complaining about not finding a matching temp()
  # function.  So, for now, we just comment the following block and add
  # unconditional flunk()s.
  # {
  #  #?pugs 4 todo 'feature'
  #  is temp(advance()), 3, "TEMP{} block (5)";
  #  is $next,           4, "TEMP{} block (6)";
  #  is temp(advance()), 4, "TEMP{} block (7)";
  #  is temp(advance()), 5, "TEMP{} block (8)";
  # }  # $next = 3

  is $next,     3, "TEMP{} block (9)";
  is advance(), 3, "TEMP{} block (10)";
  is $next,     4, "TEMP{} block (11)";
}

# Following are OO tests, but I think they fit better in var/temp.t than in
# oo/.
# L
{
  my $was_in_own_temp_handler = 0;

  class WierdTemp is Int {
    method TEMP {
      $was_in_own_temp_handler++;
      return { $was_in_own_temp_handler++ };
    }
  }

  my $a = WierdTemp.new();
  ok defined($a), "instantiating a WierdTemp worked";
  is $was_in_own_temp_handler, 0, ".TEMP method wasn't yet executed";

  #?rakudo todo 'TEMP phasers NYI'
  {
    is((temp $a; $was_in_own_temp_handler), 1, ".TEMP method was executed on temporization");
  }
  #?rakudo todo 'TEMP phasers NYI'
  is $was_in_own_temp_handler, 2, ".TEMP method was executed on restoration";
}

{
  my $depth = 0;
  my $c = 1;
  sub a {
    ++temp $c;
    a() if ++$depth < 3;
  }
  a();
  #?rakudo.parrot todo 'temp and recursion'
  is $c, 1, 'recursive nested temps are restored properly';
}

{
  my $a=1;
  {
    temp $a=2;
    temp $a=3;
  }
  is $a, 1, 'multiple temps in the same scope are restored properly';
}

{
  my $value = 0;

  my sub non-recursive {
      temp $value = $value + 1;
  }

  my sub recursive(Int $limit) {
      temp $value = $value + 1;

      if $limit > 0 {
          recursive($limit - 1);
      }
  }

  is($value, 0, 'sanity');
  non-recursive();
  is($value, 0, 'non-recursive function properly resets value');

  # recover if the previous test failed
  $value = 0;

  recursive(10);
  #?rakudo.parrot todo 'temp + recursion'
  is($value, 0, 'recursive function properly resets value');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/constant.t0000664000175000017500000001617412237474612021053 0ustar  moritzmoritzuse v6;

use Test;


# L

# Following tests test whether the declaration succeeded.
#?pugs todo 'feature'
{
    constant foo = 42;

    ok foo == 42, "declaring a sigilless constant using 'constant' works";
    dies_ok { foo = 3 }, "can't reassign to a sigil-less constant";
}

{
    # RT #69522
    sub foo0 { "OH NOES" };
    constant foo0 = 5;
    is foo0,   5,         'bare constant wins against sub of the same name';
    #?niecza skip 'Unable to resolve method postcircumfix:<( )> in class Int'
    is foo0(), 'OH NOES', '... but parens always indicate a sub call';
}

{
    my $ok;

    constant $bar0 = 42;
    ok $bar0 == 42, "declaring a constant with a sigil using 'constant' works";
    dies_ok { $bar0 = 2 }, "Can't reassign to a sigiled constant";
}

# RT #69740
{
    eval_dies_ok 'constant ($a, $b) = (3, 4)', 'constant no longer takes list';
}

{
    {
        constant foo2 = 42;
    }
    #?niecza todo
    eval_lives_ok 'foo2 == 42', 'constants are our scoped';
}

#?niecza skip 'Lexical foo3 is not a package (?)'
{
    constant foo3 = 42;
    #?rakudo todo 'constants as type constraints'
    lives_ok { my foo3 $x = 42 },        'constant can be used as a type constraint';
    dies_ok { my foo3 $x = 43 },         'constant used as a type constraint enforces';
    dies_ok { my foo3 $x = 42; $x =43 }, 'constant used as a type constraint enforces';
}

{
    my $ok;

    constant $foo = 582;
    constant $bar = $foo;
    $ok = $bar == 582;

    ok $ok, "declaring a constant in terms of another constant works";
}

{
    package ConstantTest {
        constant yak = 'shaving';
    }
    is ConstantTest::yak, 'shaving', 'constant is "our"-scoped';
}

{
    package ConstantTest2 {
        our constant yak = 'shaving';
    }
    is ConstantTest2::yak, 'shaving', 'constant can be explicitly "our"-scoped';
}

{
    package ConstantTest3 {
        my constant yak = 'shaving';
    }
    dies_ok { ConstantTest3::yak }, 'constant can be explicitly "my"-scoped';
}

#?rakudo todo 'COMPILING'
#?niecza skip 'Cannot use COMPILING outside BEGIN scope'
{
    my $ok;

    constant $foo = 8224;
    constant $bar = COMPILING::<$foo>;
    $ok = $bar == 8224;

    ok $ok, "declaring a constant in terms of COMPILING constant works";
}

{
    my $ok;

    constant %foo = { :a(582) };
    constant $bar = %foo;
    $ok = $bar == 582;

    ok $ok, "declaring a constant in terms of hash constant works";
}

#?rakudo todo 'COMPILING'
#?niecza skip 'Cannot use COMPILING outside BEGIN scope'
{
    my $ok;

    constant %foo = { :b(8224) };
    constant $bar = COMPILING::<%foo>;
    $ok = $bar == 8224;

    ok $ok, "declaring a constant in terms of COMPILING hash constant works";
}

{
    my $ok;

    constant @foo = 0, 582;
    constant $bar = @foo[1];
    $ok = $bar == 582;

    ok $ok, "declaring a constant in terms of array constant works";
}

#?rakudo todo 'COMPILING'
#?niecza skip 'Cannot use COMPILING outside BEGIN scope'
{
    my $ok;

    constant @foo = [ 1, 2, 8224 ];
    constant $bar = COMPILING::<@foo>[2];
    $ok = $bar == 8224;

    ok $ok, "declaring a constant in terms of COMPILING hash constant works";
}

{
    my $ok;

    my Num constant baz = 42;
    $ok = baz == 42;

    ok $ok, "declaring a sigilless constant with a type specification using 'constant' works";
}

#?rakudo skip 'unicode constant name'
{
    my $ok;

    constant λ = 42;
    $ok = λ == 42;

    ok $ok, "declaring an Unicode constant using 'constant' works";
}

# Following tests test whether the constants are actually constant.
#?pugs todo 'feature'
{
    my $ok = 0;

    constant grtz = 42;
    $ok++ if grtz == 42;

    try { grtz = 23 };
    $ok++ if $!;
    $ok++ if grtz == 42;

    is $ok, 3, "a constant declared using 'constant' is actually constant (1)";
}

#?rakudo skip 'binding'
#?pugs todo 'feature'
{
    my $ok;

    constant baka = 42;
    $ok++ if baka == 42;

    try { baka := 23 };
    $ok++ if $!;
    $ok++ if baka == 42;

    is $ok, 3, "a constant declared using 'constant' is actually constant (2)";
}

#?pugs todo 'feature'
{
    my $ok = 0;

    constant wobble = 42;
    $ok++ if wobble == 42;

    try { wobble++ };
    $ok++ if $!;
    $ok++ if wobble == 42;

    is $ok, 3, "a constant declared using 'constant' is actually constant (3)";
}

#?rakudo skip 'binding'
#?pugs todo 'feature'
{
    my $ok;

    constant wibble = 42;
    $ok++ if wibble == 42;

    try { wibble := { 23 } };
    $ok++ if $!;
    $ok++ if wibble == 42;

    is $ok, 3, "a constant declared using 'constant' is actually constant (4)";
}

# L
{
    my $ok;

    my $foo = 42;
    BEGIN { $foo = 23 }
    constant timecheck = $foo;
    $ok++ if timecheck == 23;

    #?pugs todo 'feature'
    #?niecza todo
    ok $ok, "the initializing values for constants are evaluated at compile-time";
}

# RT #64522
{
    constant $x = 64522;
    dies_ok { $x += 2 }, 'dies: constant += n';
    is $x, 64522, 'constant after += has not changed';

    sub con { 64522 }
    dies_ok { ++con }, "constant-returning sub won't increment";
    is con, 64522, 'constant-returning sub after ++ has not changed';
}

# identities -- can't assign to constant even if it doesn't change it.
{
    constant $change = 'alteration';

    dies_ok { $change ~= '' }, 'append nothing to a constant';
    dies_ok { $change = 'alteration' }, 'assign constant its own value';
    my $t = $change;
    dies_ok { $change = $t }, 'assign constant its own value from var';
    dies_ok { $change = 'alter' ~ 'ation' },
             'assign constant its own value from expression';

    constant $five = 5;

    dies_ok { $five += 0 }, 'add zero to constant number';
    dies_ok { $five *= 1 }, 'multiply constant number by 1';
    dies_ok { $five = 5 }, 'assign constant its own value';
    my $faux_five = $five;
    dies_ok { $five = $faux_five },
             'assign constant its own value from variable';
    dies_ok { $five = 2 + 3 },
             'assign constant its own value from expression';
}

{
    constant C = 6;
    class A {
        constant B = 5;
        has $.x = B;
        has $.y = A::B;
        has $.z = C;
    }

    is A.new.x, 5, 'Can declare and use a constant in a class';
    is A.new.y, 5, 'Can declare and use a constant with FQN in a class';
    is A.new.z, 6, 'Can use outer constants in a class';
}

#?niecza skip "Undeclared name: 'G::c'"
{
    enum F::B ;
    my constant G = F::B;
    # RT #66650
    ok F::B::c == G::c, 'can use "constant" to alias an enum';
    my constant Yak = F::B::c;
    # RT #66636
    ok Yak === F::B::c, 'can use "constant" to alias an enum value';
}

#?niecza skip "Cannot use bind operator with this LHS"
{
    constant fib := 0, 1, *+* ... *;
    is fib[100], 354224848179261915075, 'can have a constant using a sequence and index it';
}

# RT #112116
{
    constant %escapes = (^128).map({; chr($_) => sprintf '%%%02X', $_ }).hash;
    is %escapes, '%65', 'constant hashes constructed by map';
}

# RT #119751
{
    class B { constant \a = 3; };
    is B::a, 3, 'escaped constant declaration in class';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/implicit-parameter.t0000664000175000017500000000365112224265625023004 0ustar  moritzmoritzuse v6;
use Test;
plan 18;

# L 

{
    # test with explicit $_
    my $f1 = { 2*$_ };
    is $f1(2), 4, 'Block with explicit $_ has one formal parameter';
}

{
    # test with implicit $_
    my $f2 = { .sqrt };
    is_approx $f2(4), 2, 'Block with implicit $_ has one formal parameter';
}

#?pugs skip 'Missing required parameters: $_'
{
    # { } has implicit signature ($_ is rw = $OUTER::_)
    
    $_ = 'Hello';
    #?pugs todo 'feature'
    is(try { { $_ }.() }, 'Hello',              '$_ in bare block defaults to outer');
    is({ $_ }.('Goodbye'), 'Goodbye',   'but it is only a default');
    is({ 42 }.(), 42,                   'no implicit $_ usage checking');
    is({ 42 }.('Goodbye'), 42,          '$_ gets assigned but is not used');

    is(({ $_ }.arity), 0,                 '{$_} is arity 0, of course');
    is(({ .say }.arity), 0,               'Blocks that uses $_ implicitly have arity 0');
    is(({ $_ }.count), 1,                 '{$_} is count 1');
    is(({ .say }.count), 1,               'Blocks that uses $_ implicitly have count 1');
}

{
    #?pugs 4 todo 'pointy blocks'
    $_ = 'Ack';
    dies_ok({ (-> { "Boo!" }).(42) },     '-> {} is arity 0');
    dies_ok({ (-> { $_ }).(42) },         'Even when we use $_>');
    
    #?rakudo 2 todo 'pointy blocks and $_'
    #?niecza todo
    is((-> { $_ }).(),      'Ack!',       '$_ is lexical here');
    #?niecza todo
    is(-> $a { $_ }.(42),   'Ack!',       'Even with parameters (?)');
    is(-> $_ { $_ }.(42),   42,           'But not when the parameter is $_');

    #?pugs todo
    eval_dies_ok( 'sub () { -> { $^a }.() }',  'Placeholders not allowed in ->');

    is(-> { }.arity, 0,                 '->{} is arity 0, again');
}

#?niecza todo
{
    eval_dies_ok('sub { $^foo }.(42)',  'Placeholders not allowed in sub()');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/multiple.t0000664000175000017500000000166312224265625021050 0ustar  moritzmoritzuse v6;
use Test;
plan 6;

# L

eval_lives_ok 'my $x; my $x', 
              'it is legal to declare my $x twice in the same scope.';

eval_lives_ok 'state $x; state $x', 
              'it is legal to declare state $x twice in the same scope.';

{
    my $x = 2;
    my $y := $x;
    my $x = 3;
    is $y, 3, 'Two lexicals with the name in same scope are the same variable';
}

# this is not exactly S04 material
#?pugs todo
eval_dies_ok 'sub foo {1; }; sub foo($x) {1; };',
             'multiple declarations need multi or proto';

eval_dies_ok 'only sub foo {1; }; sub foo($x) {1; };',
             'multiple declarations need multi or proto';

#?niecza todo "MMD"
#?rakudo todo 'nom regression'
eval_lives_ok 'proto foo {1; }; sub foo {1; }; sub foo($x) {1; };',
             'multiple declarations need multi or proto';

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/my.t0000664000175000017500000002161512240000710017615 0ustar  moritzmoritzuse v6;
use Test;

plan 75;

#L 
{

    eval_dies_ok('$x; my $x = 42', 'my() variable not yet visible prior to declaration');
    is(eval('my $x = 42; $x'), 42, 'my() variable is visible now (2)');
}


{
    my $ret = 42;
    eval_dies_ok '$ret = $x ~ my $x;', 'my() variable not yet visible (1)';
    is $ret, 42,                       'my() variable not yet visible (2)';
}

{
    my $ret = 42;
    lives_ok { $ret = (my $x) ~ $x }, 'my() variable is visible (1)';
    is $ret, "",                      'my() variable is visible (2)';
}

#?pugs skip "Can't modify constant item: VStr"
{
    sub answer { 42 }
    my &fortytwo = &answer;
    is &fortytwo(), 42,               'my variable with & sigil works (1)';
    is fortytwo(),  42,               'my variable with & sigil works (2)';
}

{
  my $was_in_sub;
  my &foo := -> $arg { $was_in_sub = $arg };
  foo(42);
  is $was_in_sub, 42, 'calling a lexically defined my()-code var worked';
}

eval_dies_ok 'foo(42)', 'my &foo is lexically scoped';

{
  is(do {my $a = 3; $a}, 3, 'do{my $a = 3; $a} works');
  is(do {1; my $a = 3; $a}, 3, 'do{1; my $a = 3; $a} works');
}

eval_lives_ok 'my $x = my $y = 0; #OK', '"my $x = my $y = 0" parses';

#?pugs skip 'parsefail'
{
    my $test = "value should still be set for arg, even if there's a later my";
    sub foo2 (*%p) {
        is(%p, 'b', $test);
        my %p; #OK
    }
    foo2(a => 'b');
}

my $a = 1;
ok($a, '$a is available in this scope');

if (1) { # create a new lexical scope
    ok($a, '$a is available in this scope');
    my $b = 1;
    ok($b, '$b is available in this scope');
}
eval_dies_ok '$b', '$b is not available in this scope';

# changing a lexical within a block retains the changed value
my $c = 1;
if (1) { # create a new lexical scope
    is($c, 1, '$c is still the same outer value');
    $c = 2;
}
is($c, 2, '$c is available, and the outer value has been changed');

# L

my $d = 1;
{ # create a new lexical scope
    is($d, 1, '$d is still the outer $d');
    { # create another new lexical scope
        my $d = 2;
        is($d, 2, '$d is now the lexical (inner) $d');    
    }
}
is($d, 1, '$d has not changed');

# eval() introduces new lexical scope
is( eval('
my $d = 1;
{ 
    my $d = 3 #OK not used
};
$d;
'), 1, '$d is available, and the outer value has not changed' );

{
    # check closures with functions
    my $func;
    my $func2;
    if (1) { # create a new lexical scope
        my $e = 0;
        $func = sub { $e++ }; # one to inc
        $func2 = sub { $e };  # one to access it
    }

    eval_dies_ok '$e', '$e is not available in this scope';
    is($func2(), 0, '$func2() just returns the $e lexical which is held by the closure');
    $func();
    is($func2(), 1, '$func() increments the $e lexical which is held by the closure');
    $func();
    is($func2(), 2, '... and one more time just to be sure');
}

# check my as simultaneous lvalue and rvalue

is(eval('my $e1 = my $e2 = 42 #OK'), 42, 'can parse squinting my value');
is(eval('my $e1 = my $e2 = 42; $e1 #OK'), 42, 'can capture squinting my value');
is(eval('my $e1 = my $e2 = 42; $e2 #OK'), 42, 'can set squinting my variable');
is(eval('my $x = 1, my $y = 2; $y #OK'), 2, 'precedence of my wrt = and ,');

# test that my (@array, @otherarray) correctly declares
# and initializes both arrays
{
    my (@a, @b);
    lives_ok { @a.push(2) }, 'Can use @a';
    lives_ok { @b.push(3) }, 'Can use @b';
    is ~@a, '2', 'push actually worked on @a';
    is ~@b, '3', 'push actually worked on @b';
}

my $result;
my $x = 0;
{
    while my $x = 1 { $result = $x; last };
    is $result, 1, 'my in while cond seen from body';
}

is(eval('while my $x = 1 { last }; $x'), 1, 'my in while cond seen after');

is(eval('if my $x = 1 { $x } else { 0 }'), 1, 'my in if cond seen from then');
is(eval('if not my $x = 1 { 0 } else { $x }'), 1, 'my in if cond seen from else');
is(eval('if my $x = 1 { 0 } else { 0 }; $x'), 1, 'my in if cond seen after');

# check proper scoping of my in loop initializer

is(eval('loop (my $x = 1, my $y = 2; $x > 0; $x--) { $result = $x; last }; $result #OK'), 1, '1st my in loop cond seen from body');
is(eval('loop (my $x = 1, my $y = 2; $x > 0; $x--) { $result = $y; last }; $result #OK'), 2, '2nd my in loop cond seen from body');
is(eval('loop (my $x = 1, my $y = 2; $x > 0; $x--) { last }; $x #OK'), 1, '1st my in loop cond seen after');
is(eval('loop (my $x = 1, my $y = 2; $x > 0; $x--) { last }; $y #OK'), 2, '2nd my in loop cond seen after');


# check that declaring lexical twice is noop
{
    my $f;
    $f = 5;
    my $f; #OK
    is($f, 5, "two lexicals declared in scope is noop");
}

my $z = 42; #OK not used
{
    my $z = $z;
    nok( $z.defined, 'my $z = $z; can not see the value of the outer $z');
}

# interaction of my and eval
# yes, it's weird... but that's the way it is
# http://irclog.perlgeek.de/perl6/2009-03-19#i_1001177
{
    sub eval_elsewhere($str) {
        eval $str;
    }
    my $x = 4; #OK not used
    is eval_elsewhere('$x + 1'), 5, 
       'eval() knows the pad where it is launched from';

    ok eval_elsewhere('!$y.defined'),
       '... but initialization of variables might still happen afterwards';

    # don't remove this line, or eval() will complain about 
    # $y not being declared
    my $y = 4; #OK not used
}

# &variables don't need to be pre-declared
# (but they need to exist by CHECK)
{
    #?pugs todo
    eval_lives_ok '&x; 1; sub x {}', '&x does not need to be pre-declared';
    eval_dies_ok '&x()', '&x() dies when empty';
}

# RT #62766
{
    eval_lives_ok 'my $a;my $x if 0;$a = $x', 'my $x if 0';

    #?pugs todo
    eval_lives_ok 'my $a;do { die "foo"; my $x; CATCH { default { $a = $x.defined } } }';

    {
        #?pugs todo
        ok eval('not OUTER::<$x>.defined'), 'OUTER::<$x>';
        #?pugs todo
        ok eval('not SETTING::<$x>.defined'), 'SETTING::<$x>';
        my $x; #OK not used
    }

    {
        my $a;
        #?rakudo todo 'fails'
        #?niecza 2 todo 'still fails?'
        #?pugs todo
        eval_lives_ok 'do { die "foo";my Int $x;CATCH { default { $a = ?($x ~~ Int) } } }';
        #?rakudo todo 'previous test skipped'
        #?pugs todo
        ok $a, 'unreached declaration in effect at block start';
    }

    # XXX As I write this, this does not die right.  more testing needed.
    #?pugs todo
    dies_ok { my Int $x = "abc" }, 'type error'; #OK
    #?pugs todo
    dies_ok { eval '$x = "abc"'; my Int $x; }, 'also a type error';
}

{
    nok declare_later().defined,
        'Can access variable returned from a named closure that is declared below the calling position';
    my $x;
    sub declare_later {
        $x;
    }
}

# used to be RT #76366, #76466
#?rakudo skip 'nom regression, OUR::'
#?pugs skip 'No such subroutine: "&OUR::access_lexical_a"'
{
    nok OUR::access_lexical_a().defined,
        'can call our-sub that accesses a lexical before the block was run';
    {
        my $a = 42;
        our sub access_lexical_a() { $a }
    }
    #?niecza todo 'NYI'
    is  OUR::access_lexical_a(), 42,
        'can call our-sub that accesses a lexical after the block was run';

}

eval_lives_ok 'my (%h?) #OK', 'my (%h?) lives';

#RT 63588
eval_lives_ok 'my $x = 3; class A { has $.y = $x; }; A.new.y.gist',
        'global scoped variables are visible inside class definitions';

#RT #72814
#?rakudo.jvm skip "Method 'submethod_table' not found"
{
    #?niecza skip 'a not predeclared'
    lives_ok {my ::a $a}, 'typing a my-declared variable as ::a works.';    #OK not used
}

# RT #72946
#?pugs skip 'parsefail'
{
    is ( my $ = 'foo' ), 'foo',
        'declaration of anonymous Scalar';
    is ( my @ = 'foo', 'bar', 'baz' ), ['foo', 'bar', 'baz'],
        'declaration of anonymous Array';
    is ( my % = 'foo' => 1, 'bar' => 2, 'baz' => 3 ), {'foo' => 1, 'bar' => 2, 'baz' => 3},
        'declaration of anonymous Hash';
}

# RT #76452
eval_lives_ok 'multi f(@a) { }; multi f(*@a) { }; f(my @a = (1, 2, 3))',
              'can declare a variable inside a sub call';

# RT #77112
# check that the presence of routines is checked before run time 
#?pugs todo
{
    my $bad = 0;
    dies_ok { eval '$bad = 1; no_such_routine()' },
        'dies on undeclared routines';
    nok $bad, '... and it does so before run time';
}

#RT #102650
{
    my @tracker;
    my $outer;
    sub t() {
        my $inner = $outer++;
        @tracker.push($inner) and t() for $inner ?? () !! ^2;
    }
    t();
    is @tracker.join(', '), '0, 0', 'RT 102650';
}

# RT #114202
# # check that anonymous variables don't overshare.
#?niecza skip 'parsefail'
#?pugs skip 'parsefail'
{
    my @ = 1, 2, 3;
    my % = a => 1, b => 2, c => 3;
    my & = { * - 5 };
    is my @, Array.new, q{anonymous @ doesn't overshare};
    is my %, ().hash, q{anonymous % doesn't overshare};
    ok (my &) eqv Callable, q{anonymous sub doesn't overshare};
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/our.t0000664000175000017500000000703712224265625020023 0ustar  moritzmoritzuse v6;
use Test;

plan 33;

# L
our $a = 1;
{ # create a new lexical scope
    is($a, 1, '$a is still the outer $a');
    { # create another new lexical scope
        my $a = 2;
        is($a, 2, '$a is now the lexical (inner) $a');
    }
}
is($a, 1, '$a has not changed');

# should it be allowed to declare our-scoped vars more than once?
{
    our $a = 3;
    is($a, 3, '$a is now another lexical (inner) $a');
}
is($a, 3, '$a has changed'); # XXX is that right?

# test that our (@array, @otherarray) correctly declares
# and initializes both arrays
{
    our (@a, @b);
    lives_ok { @a.push(2) }, 'Can use @a';
    lives_ok { @b.push(3) }, 'Can use @b';
    is ~@a, '2', 'push actually worked on @a';
    is ~@b, '3', 'push actually worked on @b';
}

our $c = 42; #OK not used
{
    my $c = $c;
    nok( $c.defined, 'my $c = $c; can not see the value of the outer $c');
}

# check that our-scoped variables really belong to the package
{
    package D1 {
        our $d1 = 7;
        is($d1, 7, "we can of course see the variable from its own package");
        
        package D2 {
            our $d2 = 8;
            {
                our $d3 = 9;
            }
            {
                eval_dies_ok('$d3', "variables aren't seen within other lexical child blocks");
                is($D2::d3, 9, "variables are seen within other lexical child blocks via package");
                
                package D3 {
                    eval_dies_ok('$d3', " ... and not from within child packages");
                    is($D2::d3, 9, " ... and from within child packages via package");
                }
            }
            eval_dies_ok('d3', "variables do not leak from lexical blocks");
            is($D2::d3, 9, "variables are seen from lexical blocks via pacakage");
        }
        eval_dies_ok('$d2', 'our() variable not yet visible outside its package');
        eval_dies_ok('$d3', 'our() variable not yet visible outside its package');
        
    }
    eval_dies_ok('$d1', 'our() variable not yet visible outside its package');
}

# RT #100560, #102876
{
    lives_ok { our @e1 = 1..3 },   'we can declare and initialize an our-scoped array';
    lives_ok { our %e2 = a => 1 }, 'we can declare and initialize an our-scoped hash';
    is(@OUR::e1[1], 2, 'our-scoped array has correct value' );
    is(%OUR::e2, 1, 'our-scoped hash has correct value' );
}

# RT #117083
{
    our @f1;
    our %f2;
    ok(@f1 ~~ Array, 'our-declared @-sigil var is an Array');
    ok(%f2 ~~ Hash,  'our-declared %-sigil var is a Hash');
}

# RT #117775
{
    package Gee {
        our $msg;
        our sub talk { $msg }
    }

    $Gee::msg = "hello";
    is(Gee::talk, "hello", 'our-var returned by our-sub gives previously set value');
}

# RT #115630
{
    sub foo() { our $foo = 3 };
    is foo(),    3, 'return value of sub call declaring our-scoped var';
#?pugs 2 todo
    is our $foo, 3, 'redeclaration will make previous value available';
    is $foo,     3, '... and the value stays';
}

# RT #107270
#?pugs todo
{
    package Color { our ($red, $green, $blue) = 1..* };
    is $Color::blue, 3, 'declaring and initializing several vars at once';
}

# RT #76450
#?pugs 2 todo
{
    role PiRole   { our $pi = 3 };
    class PiClass { our $pi = 3 };
#?rakudo todo 'our-scoped var in role'
#?niecza todo 'our-scoped var in role'
    is $PiRole::pi,  3, 'declaring/initializing our-scoped var in role';
    is $PiClass::pi, 3, 'declaring/initializing our-scoped var in class';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/state.t0000664000175000017500000001550312224265625020333 0ustar  moritzmoritzuse v6;

use Test;

plan 40;

# L

# RT #67040 -- state initialized with //= instead of =
# (I've put this test here since it gets buggered by later tests
#  unless RT #67058 has been fixed.)
{
    sub rt67040 {
        state $x //= 17;
        $x++;
        return $x;
    }

    is rt67040(), 18, 'Assignment to state variable with //= works.';
    is rt67040(), 19, 'Assignment to state variable with //= happens once.';
}

# state() inside subs
{
    sub inc () {
        state $svar;
        $svar++;
        return $svar;
    };

    is(inc(), 1, "state() works inside subs (first)");
    is(inc(), 2, "state() works inside subs (second)");
    is(inc(), 3, "state() works inside subs (#3)");
}

# state() inside coderefs
# L
#?DOES 1
{
    my $gen = {
        # Note: The following line is only executed once, because it's equivalent
        # to
        #   state $svar will first { 42 };
        state $svar = 42;
        my $ret = { $svar++ };
    };

    my $a = $gen(); # $svar == 42
    $a(); $a();     # $svar == 44
    my $b = $gen(); # $svar == 44

    is $b(), 44, "state() works inside coderefs";
}

# state() inside for-loops
{
    for 1,2,3 -> $val {
        state $svar;
        $svar++;

        # Only check on last run
        if $val == 3 {
            is $svar, 3, "state() works inside for-loops";
        }
    }
}

# state with arrays.
{
    my @bar = 1,2,3;
    sub swatest {
        state (@foo) = @bar;
        my $x = @foo.join('|');
        @foo[0]++;
        return $x
    }
    is swatest(), '1|2|3', 'array state initialized correctly';
    is swatest(), '2|2|3', 'array state retained between calls';
}

# state with arrays.
{
    sub swainit_sub { 1,2,3 }
    sub swatest2 {
        state (@foo) = swainit_sub();
        my $x = @foo.join('|');
        @foo[0]++;
        return $x
    }
    is swatest2(), '1|2|3', 'array state initialized from call correctly';
    is swatest2(), '2|2|3', 'array state retained between calls';
}

# (state @foo) = @bar differs from state @foo = @bar
{
   my @bar = 1,2,3;
   sub swatest3 {
       (state @foo) = @bar;
       my $x = @foo.join('|');
       @foo[0]++;
       return $x
   }
   is swatest3(), '1|2|3', '(state @foo) = @bar is not state @foo = @bar';
   is swatest3(), '1|2|3', '(state @foo) = @bar is not state @foo = @bar';
}

# RHS of state is only run once per init
{
    my $rhs_calls = 0;
    sub impure_rhs {
        state $x = do { $rhs_calls++ }    #OK not used
    }
    impure_rhs() for 1..3;
    is $rhs_calls, 1, 'RHS of state $x = ... only called once';
}

# L
# ("Re: Declaration and definition of state() vars" from Larry)
#?pugs eval 'Parse error'
{
    my ($a, $b);
    my $gen = {
        (state $svar) = 42;
        -> { $svar++ };
    };

    $a = $gen();        # $svar == 42
    $a(); $a();         # $svar == 44
    $b = $gen()();      # $svar == 42
    is $b, 42, "state() and parens"; # svar == 43
}

# state() inside regular expressions
#?rakudo todo 'embedded closures in regexen'
#?niecza skip ':Perl5'
#?DOES 1
{
    my $str = "abc";

    my $re  = {
    # Perl 5 RE, as we don't want to force people to install Parrot ATM. (The
    # test passes when using the Perl 6 RE, too.)
    $str ~~ s:Perl5/^(.)/{
      state $svar;
      ++$svar;
    }/;
    };
    $re();
    $re();
    $re();
    is +$str, 3, "state() inside regular expressions works";
}

# state() inside subs, chained declaration
{
    sub step () {
        state $svar = state $svar2 = 42;
        $svar++;
        $svar2--;
        return (+$svar, +$svar2);
    };

    is(step().join('|'), "43|41", "chained state (1)");
    is(step().join('|'), "44|40", "chained state (2)");
}

# state in cloned closures
#?DOES 4
{
    for  {
        my $code = {
            state $foo = 42;
            ++$foo;
        };

        is $code(), 43, "state was initialized properly ($_ time)";
        is $code(), 44, "state keeps its value across calls ($_ time)";
    }
}

# state with multiple explicit calls to clone - a little bit subtle
#?DOES 3
{
    my $i = 0;
    my $func = { state $x = $i++; $x };
    my ($a, $b) = $func.clone, $func.clone; 
    is $a(), 0, 'state was initialized correctly for clone 1';
    #?niecza todo
    is $b(), 1, 'state was initialized correctly for clone 2';
    is $a(), 0, 'state between clones is independent';
}

# recursive state with list assignment initialization happens only first time
#?DOES 2
{
    my $seensize;
    my sub fib (Int $n) {
	    state @seen = 0,1,1;
	    $seensize = +@seen;
	    @seen[$n] //= fib($n-1) + fib($n-2);
    }
    is fib(10), 55, "fib 10 works";
    is $seensize, 10, "list assignment state in fib memoizes";
}

# recursive state with [list] assignment initialization happens only first time
#?DOES 2
{
    my $seensize;
    my sub fib (Int $n) {
	    state $seen = [0,1,1];
	    $seensize = +@$seen;
	    $seen[$n] //= fib($n-1) + fib($n-2);
    }
    is fib(10), 55, "fib 2 works";
    is $seensize, 10, "[list] assignment state in fib memoizes";
}

#?rakudo skip 'parse error'
#?DOES 4
{
    # now we're just being plain evil:
    subset A of Int where { $_ < state $x++ };
    my A $y = -4;
    # the compiler could have done some checks somehwere, so 
    # pick a reasonably high number
    dies_ok { $y = 900000 }, 'growing subset types rejects too high values';
    lives_ok { $y = 1 }, 'the state variable in subset types works (1)';
    lives_ok { $y = 2 }, 'the state variable in subset types works (2)';
    lives_ok { $y = 3 }, 'the state variable in subset types works (3)';
}

# Test for RT #67058
sub bughunt1 { (state $svar) }    #OK not used
{
    sub bughunt2 { state $x //= 17; ++$x }
    is bughunt2(), 18,
       'a state variable in parens works with a state variable with //= init';
}

#?rakudo skip 'parse error'
#?DOES 1
{
    # http://irclog.perlgeek.de/perl6/2010-04-27#i_2269848
    my @tracker;
    for (1..3) {
        my $x = sub { state $s++; @tracker.push: $s }
        $x();
    };
    is @tracker.join('|'), '1|1|1',
        'state var in anonymous closure in loop is not shared';
}

# niecza regression: state not working at top level
eval_lives_ok 'state $x; $x', 'state outside control structure';

#?rakudo todo 'initialization happens only on first call(?)'
{
    sub f($x) {
        return if $x;
        state $y = 5;
        $y;
    }
    f(1);
    is f(0), 5, 'initialization not reached on first run of the functions';
}

{
    sub r {
        state ($a, $b) = (5, 42);
        $a++; $b--;
        "$a $b"
    }
    r();
    is r(), '7 40', 'state vars and list assignment mixes';
}

{
    my $x = 1;
    sub foo() { state $ = $x++ };
    is foo(), 1, 'anonymous state variable (1)';
    is foo(), 1, 'anonymous state variable (2)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-declarations/will.t0000664000175000017500000001004612224265625020157 0ustar  moritzmoritzuse v6;

use Test;

BEGIN plan 17;

# L

my $begin;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
{
    BEGIN $begin ~= "a";
    my $b will begin { $begin ~= "b" };
    BEGIN $begin ~= "c";
    CHECK $begin ~= "f";
    my $bb will check { $begin ~= "e" };
    CHECK $begin ~= "d";
    is $begin, "abcdef", 'all begin/check blocks in order';
}

my $init;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo todo 'will init NYI'
{
    is $init, "abc", 'all init blocks in order';
    BEGIN $init ~= "a";
    INIT  $init ~= "b";
    my $bbb will init { $init ~= "c" };
}

my $same1;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo skip 'declared variable not visible in block yet'
{
    my $x  will begin { $same1 ~= "a" if $_ === $x }
    my $xx will check { $same1 ~= "b" if $_ === $xx }
    my $xxx will init { $same1 ~= "c" if $_ === $xxx }
    is $same1, "abc", 'all blocks set $_';
}

my $block;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
{
    my $d  will pre    { $block ~= "a" };
    my $dd will enter  { $block ~= "b" };
    is $block, "ab", 'entered block ok';
    my $e will leave   { $block ~= "c" };
    my $ee will post   { $block ~= "d" };
    my $eee will keep  { $block ~= "e" };
    my $eeee will undo { $block ~= "f" }; # should not fire
    1; # successful exit
}
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo todo "will post NYI"
is $block, "abecd", 'all block blocks set variable';

my $same2;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo skip 'declared variable not visible in block yet'
{
    my $d  will pre    { $same2 ~= "a" if $_ === $d; 1 };
    my $dd will enter  { $same2 ~= "b" if $_ === $dd };
    is $same2, "ab", 'entered block ok';
    my $e  will leave  { $same2 ~= "c" if $_ === $e };
    my $ee will post   { $same2 ~= "d" if $_ === $ee; 1 };
    my $eee will keep  { $same2 ~= "e" if $_ === $eee };
    my $eeee will undo { $same2 ~= "f" if $_ === $eeee }; # should not fire
    1; # successful exit
}
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo todo 'declared variable not visible in block yet'
is $same2, "abecd", 'all block blocks get $_';

my $for;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
{
    my @is = ;
    for ^3 {
        my $g will first  { $for ~= "a" };
        my $h will next   { $for ~= "b" };
        my $i will last   { $for ~= "c" };
        is( $for, @is[$_], "for iteration #{$_+1}" );
        my $ii will keep  { $for ~= "d" }; # should not fire
        my $iii will undo { $for ~= "e" };
        Nil; # failure exit
    }
}
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
is $for, "aebebebc", 'all for blocks set variable';

my $same3;
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo skip 'declared variable not visible in block yet'
{
    my @is = ;
    for ^3 {
        my $j will first  { $same3 ~= "a" if $_ === $j; 1 };
        my $k will next   { $same3 ~= "b" if $_ === $k; 1 };
        my $l will last   { $same3 ~= "c" if $_ === $l; 1 };
        is( $same3, @is[$_], "same iteration #{$_+1}" );
        my $ll will keep  { $same2 ~= "d" if $_ === $ll }; # should not fire
        my $lll will undo { $same2 ~= "e" if $_ === $lll };
        Nil; # failure exit
    }
}
#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
#?rakudo todo 'declared variable not visible in block yet'
is $same3, "aebebebc", 'all for blocks get $_';

#?niezca skip "will variable trait NYI"
#?pugs   skip "will variable trait NYI"
{
    my $seen = 42;
    dies_ok {eval 'my $a will foo { $seen = 1 }'}, 'unknown will trait';
    is $seen, 42, 'block should not have executed';
    lives_ok {my $a will compose { $seen = 1 }}, "don't know how to test yet";
    is $seen, 42, 'block should not have executed';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-exception-handlers/catch.t0000664000175000017500000001177112224265625021424 0ustar  moritzmoritzuse v6;

use Test;

plan 27;

=begin desc

Tests C blocks.

=end desc



# L

dies_ok { die 'blah'; CATCH {} }, 'Empty CATCH rethrows exception';
dies_ok { try {die 'blah'; CATCH {}} }, 'CATCH in try overrides default exception handling';

# L

lives_ok { die 'blah'; CATCH {default {}} }, 'Closure with CATCH {default {}} ignores exceptions';
lives_ok { do {die 'blah'; CATCH {default {}}}; }, 'do block with CATCH {default {}} ignores exceptions';

{
    my $f = sub { die 'blah'; CATCH {default {}} };
    lives_ok $f, 'Subroutine with CATCH {default {}} ignores exceptions';

    $f = sub ($x) {
        if $x {
            die 'blah';
            CATCH { default {} }
        }
        else {
            die 'blah';
        }
    };
    lives_ok { $f(1) }, 'if block with CATCH {default {}} ignores exceptions...';
    dies_ok { $f(0) }, "...but the CATCH doesn't affect exceptions thrown in an attached else";
}



#L

#unless eval 'Exception.new' {
#    skip_rest "No Exception objects"; exit;
#}

{
    # exception classes
    class Naughty is Exception {};

    my ($not_died, $caught);
    {
        die Naughty.new();

        $not_died = 1;

        CATCH {
            when Naughty {
                $caught = 1;
            }
        }
    };

    ok(!$not_died, "did not live after death");
    #?pugs 1 todo
    ok($caught, "caught exception of class Naughty");
};

{
    # exception superclass
    class Naughty::Specific is Naughty {};
    class Naughty::Other is Naughty {};

    my ($other, $naughty);
    {
        die Naughty::Specific.new();

        CATCH {
            when Naughty::Other {
                $other = 1;
            }
            when Naughty {
                $naughty = 1;
            }
        }
    };

    ok(!$other, "did not catch sibling error class");
    #?pugs 1 todo
    ok($naughty, "caught superclass");
};

{
    # uncaught class
    class Dandy is Exception {};

    my ($naughty, $lived);
    try {
        {
            die Dandy.new();

            CATCH {
                when Naughty {
                    $naughty = 1;
                }
            }
        };
        $lived = 1;
    }
    
    ok(!$lived, "did not live past uncaught throw");
    ok(!$naughty, "did not get caught by wrong handler");
    ok(WHAT($!).gist, '$! is an object');
    #?pugs skip 'bug'
    is(WHAT($!).gist, Dandy.gist, ".. of the right class");
};

{
    my $s = '';
    {
        die 3;
        CATCH {
            when 1 {$s ~= 'a';}
            when 2 {$s ~= 'b';}
            when 3 {$s ~= 'c';}
            when 4 {$s ~= 'd';}
            default {$s ~= 'z';}
        }
    }

    is $s, 'c', 'Caught number';
};

{
    my $catches = 0;
    sub rt63430 {
        {
            return 63430;
            CATCH { return 73313 if ! $catches++; }
        }
    }

    is rt63430().perl, 63430.perl, 'can call rt63430() and examine the result';
    is rt63430(), 63430, 'CATCH does not intercept return from bare block';
    is $catches, 0, 'CATCH block never invoked';
};



# L

{
    my $catches = 0;
    try {
        {
            die 'catch!';
            CATCH { default {die 'caught' if ! $catches++;} }
        };
    }

    is $catches, 1, "CATCH doesn't catch exceptions thrown in its own lexical scope";

    $catches = 0;
    my $f = { die 'caught' if ! $catches++; };
    try {
        {
            die 'catch!';
            CATCH { default {$f()} }
        };
    }

    is $catches, 1, "CATCH doesn't catch exceptions thrown in its own dynamic scope";

    my $s = '';
    {
        die 'alpha';
        CATCH {
            default {
                $s ~= 'a';
                die 'beta';
            }
            CATCH {
                default { $s ~= 'b'; }
            }
        }
    };

    is $s, 'ab', 'CATCH directly nested in CATCH catches exceptions thrown in the outer CATCH';

    $s = '';
    {
        die 'alpha';
        CATCH {
            default {
                $s ~= 'a';
                die 'beta';
                CATCH {
                    default { $s ~= 'b'; }
                }
            }
        }
    };

    is $s, 'ab', 'CATCH indirectly nested in CATCH catches exceptions thrown in the outer CATCH';
};

# RT #62264
{
    try { die "Goodbye cruel world!" };
    ok $!.^isa(Exception), '$!.^isa works';
}

# RT #64262
{
    dies_ok {
        try {
            die 1;
            CATCH {
                default {
                    die 2;
                }
            }
        }
    }, 'can throw exceptions in CATCH';
}

# RT #80864
eval_lives_ok 'my %a; %a{ CATCH { } }', 'can define CATCH bock in .{}';
# RT #73988
eval_dies_ok 'do { CATCH {}; CATCH { } }', 'only one CATCH per block allowed';

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-exceptions/control_across_runloop.t0000664000175000017500000000041112224265625023524 0ustar  moritzmoritzuse v6;

use Test;

# L

# Test primarily aimed at Niecza

plan 1;

{
    sub foo($x = last) { $x }

    my $i = 0;
    for 1,2,3 { $i++; foo(); }

    is $i, 1, 'control operator last can be used in an inferior context';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-exceptions/fail.t0000664000175000017500000000345112224265625017636 0ustar  moritzmoritzuse v6;

use Test;

plan 13;

# L

{
  # "use fatal" is not standard, so we don't have to disable it here
  my $was_after_fail  = 0;
  my $was_before_fail = 0;
  my $sub = sub { $was_before_fail++; my $exception = fail 42; $was_after_fail++ };    #OK not used

  my $unthrown_exception = $sub();
  # Note: We don't further access $unthrown_exception, so it doesn't get thrown
  is $was_before_fail, 1, "fail() doesn't cause our sub to not get executed";
  is $was_after_fail,  0, "fail() causes our sub to return (1)";
}

{
  my $was_after_fail = 0;
  my $was_after_sub  = 0;
  my $sub = sub { fail 42; $was_after_fail++ };

  use fatal;
  try { $sub(); $was_after_sub++ };

  is $was_after_fail, 0, "fail() causes our sub to return (2)";
  is $was_after_sub,  0, "fail() causes our try to die";
}

# RT #64990
#?rakudo skip 'RT 64990'
{
    our Int sub rt64990 { fail() }
    ok rt64990() ~~ Failure, 'sub typed Int can fail()';

    our Int sub repeat { return fail() }
    ok repeat() ~~ Failure, 'sub typed Int can return Failure';
}

# RT #70229
{
    sub rt70229 { return fail() }
    my $rt70229 = rt70229();
    ok $rt70229 ~~ Failure, 'got a Failure';
    dies_ok { ~$rt70229 }, 'attempt to stringify Failure dies';
}

# RT #77946
{
    sub rt77946 { return fail() }
    my $rt77946 = rt77946();
    isa_ok ?$rt77946, Bool, '?Failure returns a Bool';
    isa_ok $rt77946.defined, Bool, 'Failure.defined returns a Bool';
}

# RT #106832
{
    my $f = (sub { fail('foo') }).();
    is $f.exception, 'foo', 'can extract exception from Failure';
    isa_ok $f.exception, Exception, '... and it is an Exception';
}

{
    class AnEx is Exception { };
    my $f = (sub f { fail AnEx.new }).();  #OK not used
    isa_ok $f.exception, AnEx, 'can fail() typed exceptions';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-exceptions/pending.t0000664000175000017500000000431412224265625020346 0ustar  moritzmoritzuse v6;
use Test;

# XXX I'm not very confident in my reading of S04, so give a suspicious eye
#     to these tests before using them.

# L

{
    try { die 'OMG' }
    ok $! ~~ Exception, '$! has an exception';
    #?rakudo 2 skip '$!.pending'
    ok $!.pending ~~ List, '$!.pending returns a List';
    is $!.pending, (), '$! there are no exceptions pending';

    undefine $!;
    ok ! $!, '$! has been cleared';
}

sub fail_it { fail $^a }

# L

{
    my @fails = ( fail_it(1), fail_it(2), fail_it(3), fail_it(4) );

    #?rakudo todo 'not full of fail?'
    ok all(@fails) ~~ Failure, '@fails is full of fail';
    ok $! !~~ Exception, 'fails do not enter $!';
    #?rakudo 11 skip '$!.pending'
    is +($!.pending.grep( ! *.handled )), 4,
       '$!.pending has three unhandled exceptions';

    ok ! @fails[0].handled, 'fail 0 is not handled';
    ok   @fails[0].not,     'fail 0 is not true';
    ok   @fails[0].handled, 'fail 0 is now handled';

    ok ! @fails[1].handled, 'fail 1 is not handled';
    ok ! @fails[1].defined, 'fail 1 is not defined';
    ok   @fails[1].handled, 'fail 1 is now handled';

# L

    ok ! @fails[2].handled, 'fail 2 is not handled';
    lives_ok { @fails[2].handled = 1 }, 'assign to .handled';
    ok   @fails[2].handled, 'fail 2 is now handled';

    is +($!.pending.grep( ! *.handled )), 1,
       '$!.pending has one unhandled exception';

    undefine $!;
    ok ! $!, '$! has been cleared';
}

# L

#?rakudo skip '$object.handled'
{
    my $fails_thrown = 0;
    {
        my @throwable = ( fail_it(1), fail_it(2), fail_it(3) );
        @throwable[1].handled = 1;
        CATCH {
            default {
                $fails_thrown += +($!.pending);
            }
        }
    }
    is $fails_thrown, 2, 'unhandled Failures in $! at block exit are thrown';

    undefine $!;
    ok ! $!, '$! has been cleared';
}

# L

{
    my $win = Mu.new;
    #?rakudo skip '$object.handled'
    ok $win.handled, '.handled method is true for all Mus';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/ascending-order.t0000664000175000017500000000222512224265625021251 0ustar  moritzmoritzuse v6;

# Test the running order of BEGIN/CHECK/INIT/ENTER/END
# These blocks appear in ascending order
# [TODO] add tests for LEAVE/KEEP/UNDO/PRE/POST/etc

use Test;

plan 7;

# L

my $var;
my ($var_at_begin, $var_at_check, $var_at_init, $var_at_enter, $var_at_leave);
my $eof_var;

$var = 13;

my $hist;

# XXX check if BEGIN blocks do have to remember side effects
BEGIN {
    $hist ~= 'begin ';
    $var_at_begin = $var;
}

CHECK {
    $hist ~= 'check ';
    $var_at_check = $var;
}

INIT {
    $hist ~= 'init ';
    $var_at_init = $var;
}

ENTER {
    $hist ~= 'enter ';
    $var_at_enter = $var;
}

END {
    # tests for END blocks:
    is $var, 13, '$var gets initialized at END time';
    is $eof_var, 29, '$eof_var gets assigned at END time';
}

#?pugs todo
is $hist, 'begin check init enter ', 'BEGIN {} runs only once';
nok $var_at_begin.defined, 'BEGIN {...} ran at compile time';
nok $var_at_check.defined, 'CHECK {...} ran at compile time';
nok $var_at_init.defined, 'INIT {...} ran at runtime, but ASAP';
nok $var_at_enter.defined, 'ENTER {...} at runtime, but before the mainline body';

$eof_var = 29;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/begin.t0000664000175000017500000000275212224265625017276 0ustar  moritzmoritzuse v6;
use Test;

plan 9;

# the boundary between run time and compile time is hard to implement right.
# Some of those tests might look trivial, but nearly all of them are based
# on things that at one point or another failed in even rather advanced
# compilers.

{
    is (BEGIN { "foo" }), "foo", 'Can use BEGIN  as an expression';
    is (BEGIN  "foo" ), "foo", 'Can use BEGIN  as an expression';
}

{
    my $my;
    BEGIN { $my = 'foo' }
    is $my, 'foo', 'can set outer lexical from a BEGIN block';
}

{
    our $our;
    BEGIN { $our = 'foo' }
    is $our, 'foo', 'can set outer package var from a BEGIN block';
}

{
    sub my-uc($x) { $x.uc };
    my ($my-uc, $setting-uc);
    BEGIN { $my-uc      = my-uc 'Ab' }
    BEGIN { $setting-uc =    uc 'Cd' }
    is $my-uc,      'AB', 'can call subs from an outer scope in BEGIN';
    is $setting-uc, 'CD', 'can call subs from the setting in BEGIN';

}

{
    class SomeClass { };
    my $var;
    BEGIN { $var = SomeClass };
    isa_ok $var, SomeClass, 'use a class at BEGIN time';
}

{
    my $code;
    BEGIN { $code = sub { 'returnvalue' } }
    is $code(), 'returnvalue', 'Can execute an anonymous sub return from BEGIN';
}

{
    my $tracker = '';
    try {
        eval q[
            BEGIN { $tracker = "begin" }
            $tracker = "run";
            # syntax error (two terms in a row):
            1 1
        ];
    }
    is $tracker, 'begin',
        'BEGIN block was executed before a parse error happened later in the file';

}
rakudo-2013.12/t/spec/S04-phasers/check.t0000664000175000017500000000155112224265625017263 0ustar  moritzmoritzuse v6;

use Test;

plan 5;

# L
# CHECK {...} block in "void" context
{
    my $str;
    BEGIN { $str ~= "begin1 "; }
    CHECK { $str ~= "check "; }
    BEGIN { $str ~= "begin2 "; }

    is $str, "begin1 begin2 check ", "check blocks run after begin blocks";
}

{
    my $str;
    CHECK { $str ~= "check1 "; }
    BEGIN { $str ~= "begin "; }
    CHECK { $str ~= "check2 "; }

    is $str, "begin check2 check1 ", "check blocks run in reverse order";
}

# CHECK {...} blocks as rvalues
{
    my $str;
    my $handle = { my $retval = CHECK { $str ~= 'C' } };

    #?niecza 2 todo
    is $handle(), 'C', 'our CHECK {...} block returned the correct var (1)';
    is $handle(), 'C', 'our CHECK {...} block returned the correct var (2)';
    is $str, 'C', 'our rvalue CHECK {...} block was executed exactly once';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/descending-order.t0000664000175000017500000000207512224265625021424 0ustar  moritzmoritzuse v6;

# Test the running order of phasers
# These blocks appear in descending order
# [TODO] add tests for ENTER/LEAVE/KEEP/UNDO/PRE/POST/etc

use Test;

plan 7;

# L

my $var;
my ($var_at_enter, $var_at_init, $var_at_check, $var_at_begin);
my $eof_var;

$var = 13;

my $hist;

END {
    # tests for END blocks:
    is $var, 13, '$var gets initialized at END time';
    is $eof_var, 29, '$eof_var gets assigned at END time';
}

ENTER {
    $hist ~= 'enter ';
    $var_at_enter = $var;
}

INIT {
    $hist ~= 'init ';
    $var_at_init = $var;
}

CHECK {
    $hist ~= 'check ';
    $var_at_check = $var;
}

BEGIN {
    $hist ~= 'begin ';
    $var_at_begin = $var;
}

#?pugs todo
is $hist, 'begin check init enter ', 'BEGIN {} runs only once';
nok $var_at_begin.defined, 'BEGIN {...} ran at compile time';
nok $var_at_check.defined, 'CHECK {...} ran at compile time';
nok $var_at_init.defined, 'INIT {...} ran at runtime, but ASAP';
nok $var_at_enter.defined, 'ENTER {...} at runtime, but before the mainline body';

$eof_var = 29;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/end.t0000664000175000017500000000110212224265625016744 0ustar  moritzmoritzuse v6;
use Test;

plan 5;

eval_lives_ok 'my $x = 3; END { $x * $x }',
              'outer lexicals are visible in END { ... } blocks';

eval_lives_ok 'my %rt112408 = END => "parsing clash with block-less END"',
	      'Can use END as a bareword hash key (RT 112408)';

my $a = 0;
#?rakudo 2 todo 'lexicals and eval()'
#?niecza todo
eval_lives_ok 'my $x = 3; END { $a = $x * $x };',
              'and those from eval as well';

#?niecza todo
#?pugs todo
is $a, 9, 'and they really worked';

END { pass("exit does not prevent running of END blocks"); }
exit;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/enter-leave.t0000664000175000017500000000766212224265625020426 0ustar  moritzmoritzuse v6;

use Test;

plan 21;

# L
# L

{
    my $str;
    my sub foo ($x, $y) {
        ENTER { $str ~= "(" }
        LEAVE { $str ~= ")" }
        $str ~= "$x,$y";
    }
    foo(3,4);
    #?pugs todo
    is $str, '(3,4)';
    foo(-1,2);
    #?pugs todo
    is $str, '(3,4)(-1,2)';
}

# reversed order
{
    my $str;
    my sub foo ($x, $y) {
        $str ~= "$x,$y";
        LEAVE { $str ~= ")" }
        ENTER { $str ~= "(" }
    }
    foo(7,-8);
    #?pugs todo
    is $str, '(7,-8)';
    foo(5,0);
    #?pugs todo
    is $str, '(7,-8)(5,0)';
}

# multiple ENTER and LEAVE blocks
#?pugs todo
{
    my $str;
    {
        ENTER { $str ~= '[' }
        LEAVE { $str ~= ']' }

        $str ~= 21;

        ENTER { $str ~= '(' }
        LEAVE { $str ~= ')' }

        ENTER { $str ~= '{' }
        LEAVE { $str ~= '}' }
    }
    is $str, '[({21})]', 'multiple ENTER/LEAVE worked';
}

# L
#?pugs todo
{
    my $str;
    for 1..2 -> $x {
        $str ~= ',';
        ENTER { $str ~= "E$x" }
        LEAVE { $str ~= "L$x " }
    }
    is $str, 'E1,L1 E2,L2 ', 'ENTER/LEAVE repeats on loop blocks';
}

# L

# named sub:
{
    my $str;
    my sub is_even ($x) {
        return 1 if $x % 2 == 0;
        return 0;
        LEAVE { $str ~= $x }
    }
    is is_even(3), 0, 'basic sanity check (1)';
    is $str, '3', 'LEAVE executed at the 1st explicit return';
    is is_even(2), 1, 'basic sanity check (2)';
    is $str, '32', 'LEAVE executed at the 2nd explicit return';
}

# normal closure:
#?niecza skip 'leave'
#?rakudo skip 'leave NYI'
{
    #?pugs todo
    is eval(q{
        my $a;
        {
            leave;
            $a = 100;
            LEAVE { $a++ }
        }
        $a;
    }), 1, 'leave triggers LEAVE {}';
}

#?pugs todo
{
    my $str;
    try {
        ENTER { $str ~= '(' }
        LEAVE { $str ~= ')' }
        $str ~= 'x';
        die 'foo';
    }
    is $str, '(x)', 'die calls LEAVE blocks';
}

#?niecza 2 skip 'dubious: noauto'
#?pugs todo
{
    my $str;
    try {
        LEAVE { $str ~= $! // '' }
        die 'foo';
    }
    ok $str ~~ /foo/, '$! set in LEAVE if exception thrown';
}

#?pugs todo
{
    my $str;
    {
        LEAVE { $str ~= (defined($!) ?? 'yes' !! 'no') }
        try { die 'foo' }
        $str ~= (defined($!) ?? 'aye' !! 'nay');
    }
    #?rakudo todo 'is this spec? why would LEAVE not see outer $!? fossil?'
    is $str, 'ayeno', '$! not set in LEAVE if exception not thrown';
}

{
    my $str;
    try {
        $str ~= '(';
        try {
            ENTER { die 'foo' }
            $str ~= 'x';
        }
        $str ~= ')';
    }
    is $str, '()', 'die in ENTER caught by try';
}

{
    my $str;
    try {
        $str ~= '(';
        try {
            LEAVE { die 'foo' }
            $str ~= 'x';
        }
        $str ~= ')';
    }
    #?rakudo.jvm todo "nigh"
    is $str, '(x)', 'die in LEAVE caught by try';
}

#?pugs todo
{
    my $str;
    try {
        $str ~= '(';
        try {
            ENTER { $str ~= '['; die 'foo' }
            LEAVE { $str ~= ']' }
            $str ~= 'x';
        }
        $str ~= ')';
    }
    is $str, '([])', 'die in ENTER calls LEAVE';
}

#?pugs todo
{
    my $str;
    try {
        ENTER { $str ~= '1'; die 'foo' }
        ENTER { $str ~= '2' }
    }
    is $str, '1', 'die aborts ENTER queue';
}

#?niecza todo '@!'
#?pugs todo
#?rakudo.jvm skip 'unwind'
{
    my $str;
    try {
        LEAVE { $str ~= '1' }
        LEAVE { $str ~= '2'; die 'foo' }
    }
    is $str, '21', 'die doesn\'t abort LEAVE queue';
}

# RT #113548
#?pugs skip 'LEAVE'
{
    my $a = 0;
    my $b = 0;
    multi sub rt113548() { $a = 1; LEAVE $b = 2; }; rt113548;
    ok($a == 1 && $b == 2, "LEAVE fires in a multi sub");
}

# RT #115998
{
    my $x = 0;
    for 1..10 { LEAVE { $x++ }; next }
    is $x, 10, "next triggers LEAVE";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/eval-in-begin.t0000664000175000017500000000074512224265625020627 0ustar  moritzmoritzuse v6;
use Test;

plan 3;

# RT #115134: [BUG] BEGIN { eval "..." } Confuses Rakudo
# The bug is triggered by the closing brace being directly
# followed by a newline and the next statement.
eval_lives_ok(q[BEGIN { eval '0' }
0], 'eval in BEGIN { ... } followed by newline works');

eval_lives_ok(q[BEGIN { eval '0' };
0], 'eval in BEGIN { ... } followed by semicolon and newline works');

eval_lives_ok(q[BEGIN { eval '0' };0], 'eval in BEGIN { ... } followed by semicolon works');

rakudo-2013.12/t/spec/S04-phasers/exit-in-begin.t0000664000175000017500000000103012224265625020635 0ustar  moritzmoritzuse v6;

use Test;

# $failed is set to 0 (actually to Mu) at compiletime.
my $failed;
# At run time, if we ever reach runtime, $failed is set to 1.
$failed = 1;

# When we end, we check if $failed is still 0. If yes, we've never reached runtime.
END {
    nok $failed.defined,
      'exit() works in BEGIN {} - $fail not yet initialized at END time';
}

BEGIN {
  # Output the TAP header...
  plan 2;
  nok $failed.defined, '$failed not yet initialized in BEGIN {}';
  # ...and exit, implicitly calling END.
  exit;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/exit-in-check.t0000664000175000017500000000243212224265625020635 0ustar  moritzmoritzuse v6;

use Test;

# $failed is set to 0 (actually to Mu) at compiletime.
my $failed;
# At run time, if we ever reach runtime, $failed is set to 1.
$failed = 1;

# When we end, we check if $failed is still 0. If yes, we've never reached runtime.
END {
  nok $failed.defined,
      'exit() works in CHECK {} - $fail not yet initialized at END time';
}

CHECK {
  # Output the TAP header...
  plan 2;
  nok $failed.defined, '$failed not yet initialized in CHECK {}';
  # ...and exit, implicitly calling END.
  exit;
}

# This file was testing that exit does not trigger END at CHECK time.
# However, the spec did not say anything on this subject, and Perl 5
# does call END blocks upon exit in CHECK.  Hence I've preserved the
# original test below but now it tests for the perl5-compatible behaviour.
#   -- audreyt 20061006

=begin END

use v6;

use Test;

# $failed is set to 0 (actually to Mu) at compiletime.
my $failed;
# At run time, if we ever reach runtime, $failed is set to 1.
$failed = 1;

# When we end, we check if $failed is still 0. If yes, we've never reached runtime.
END {
  ok 0, 'END {...} should not be invoked';
}

CHECK {
  # Output the TAP header...
  plan 1;
  nok $failed.defined, 'exit() works in CHECK {}';
  # ...and exit, which does _not_ call END.
  exit;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/first.t0000664000175000017500000000161112224265625017332 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# L
#?pugs todo
{
    my $str = '';
    for 1..2 {
        FIRST { $str ~= $_ }
    }
    is $str, 1, 'FIRST only ran once';
}

{
    my ($a, $a_in_first);
    for 1..2 {
        $a++;
        FIRST { $a_in_first = $a }
    }
    nok $a_in_first.defined, 'FIRST {} ran before the loop body';
}

# L
#?pugs todo
{
    my $str = '';
    for 1..2 {
        FIRST { $str ~= $_ }
        FIRST { $str ~= ':' }
        FIRST { $str ~= ' ' }
    }
    is $str, '1: ', 'multiple FIRST {} ran in order';
}

# L
#?pugs todo
{
    my $str = '';
    for 1..2 {
        FIRST { $str ~= 'f1' }
        ENTER { $str ~= 'e' }
        FIRST { $str ~= 'f2' }
    }
    is $str, 'f1f2ee', 'FIRST {} ran before ENTER {}';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/in-eval.t0000664000175000017500000000564512224265625017551 0ustar  moritzmoritzuse v6;

# Test phasers in eval strings

use Test;

plan 35;

# L
{
    my $h;
    my $handle;

    eval '$handle = { $h ~= "1"; once { $h ~= "F" }; $h ~= "2" }';
    ok $! !~~ Exception, 'eval once {...} works';

    nok $h.defined, 'once {...} has not run yet';
    lives_ok { $handle() }, 'can run code with once block';
    is $h, '1F2', 'once {...} fired';
    lives_ok { $handle() }, 'can run code with once block again';
    is $h, '1F212', 'once {...} fired only once';

    # test that it runs again for a clone of $handle
    $h = '';
    my $clone = $handle.clone;
    is $h, '', 'cloning code does not run anything';
    lives_ok { $clone() }, 'can run clone of code with once block';
    is $h, '1F2', 'once {...} fired again for the clone';
    lives_ok { $clone() }, 'can run clone of once block code again';
    is $h, '1F212', 'cloned once {...} fired only once';
}

{
    my $h;
    my $handle;

    eval '$handle = { $h ~= "r"; INIT { $h ~= "I" }; $h ~= "R" }';
    ok $! !~~ Exception, 'eval INIT {...} works';
    #?rakudo todo 'not sure'
    nok $h.defined, 'INIT did not run at compile time';
    lives_ok { $handle() }, 'can run code with INIT block';
    is $h, 'IrR', 'INIT {...} fires at run-time';
    lives_ok { $handle() }, 'can run code with INIT block again';
    is $h, 'IrRrR', 'INIT runs only once';

    # test that it runs again for a clone of $handle
    $h = '';
    my $clone = $handle.clone;
    is $h, '', 'cloning code does not run anything';
    lives_ok { $clone() }, 'can run clone of code with INIT block';
    is $h, 'rR', 'INIT {...} did not fire again for the clone';
}

{
    my $h;
    my $handle;

    eval '$handle = { $h ~= "1"; CHECK { $h ~= "C" };'
        ~ '$h ~= "2"; BEGIN { $h ~= "B" }; $h ~= "3" }';
    ok $! !~~ Exception, 'eval CHECK {...} (and BEGIN {...}) works';

    is $h, 'BC', 'CHECK and BEGIN blocks ran before run time';
    lives_ok { $handle() }, 'can run code with CHECK and BEGIN blocks';
    is $h, 'BC123', 'CHECK {...} runs at compile time after BEGIN';
    lives_ok { $handle() }, 'can run code with CHECK and BEGIN again';
    is $h, 'BC123123', 'CHECK runs once';
}

{
    my $h;
    my $handle;

    eval '$handle = { $h ~= "1"; BEGIN { $h ~= "B" }; $h ~= "2" }';
    ok $! !~~ Exception, 'eval BEGIN {...} works';

    is $h, 'B', 'BEGIN ran before run time';
    lives_ok { $handle() }, 'can run code with BEGIN block';
    is $h, 'B12', 'BEGIN does not run again at run time';
}

{
    my $h = '';
    my $handle;

    END {
        is $h, '12E', 'the END {...} in eval has run already';
    }

    eval '$handle = { $h ~= "1"; END { $h ~= "E" }; $h ~= "2" }';
    ok $! !~~ Exception, 'eval END {...} works';

    is $h, '' , 'END {} has not run yet';
    lives_ok { $handle() }, 'can call code with END block';
    is $h, '12', 'END {} does not run at run time either';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/init.t0000664000175000017500000000352612224265625017155 0ustar  moritzmoritzuse v6;

use Test;

plan 11;

# L
# INIT {...} blocks in "void" context
{
    my $str;
    is $str, "begin1 begin2 init ", "init blocks run after begin blocks";

    BEGIN { $str ~= "begin1 "; }
    INIT  { $str ~= "init "; }
    BEGIN { $str ~= "begin2 "; }
}

{
    my $str;
    is $str, "check2 check1 init ", "init blocks run after check blocks";

    CHECK { $str ~= "check1 "; }
    INIT  { $str ~= "init "; }
    CHECK { $str ~= "check2 "; }
}

{
    my $str;
    is $str, "begin init1 init2 ", "init blocks run in forward order";

    INIT  { $str ~= "init1 "; }
    BEGIN { $str ~= "begin "; }
    INIT  { $str ~= "init2 "; }
}

# INIT {...} blocks as rvalues
{
    my $str;
    my $handle = { my $retval = INIT { $str ~= 'I' } };

    is $str, 'I', 'our INIT {...} block already gets called';
    #?niecza todo "no value"
    is $handle(), 'I', 'our INIT {...} block returned the correct var (1)';
    #?niecza todo "no value"
    is $handle(), 'I', 'our INIT {...} block returned the correct var (2)';
    is $str, 'I', 'our rvalue INIT {...} block was executed exactly once';
}

# IRC note:
#  also, the INIT's settings are going to get wiped
#             out when the my is executed, so you probably just
#             end up with 'o'
{
    my $str = 'o';
    INIT { $str ~= 'i' }
    is $str, 'o', 'the value set by INIT {} wiped out by the initializer of $str';
}

# L

my $str ~= 'o';  # Note that this is different from  "my $str = 'o';".
{
    INIT { $str ~= 'i' }
}
#?pugs todo
is $str, 'io', 'INIT {} always runs before the mainline code runs';

# L
{
	my $var;
	for  {
		my $sub = { INIT { $var++ } };
		is $var, 1, "INIT has run exactly once ($_ time)";
	}
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/in-loop.t0000664000175000017500000000351312224265625017563 0ustar  moritzmoritzuse v6;

use Test;

plan 2;

# TODO, based on synopsis 4:
#
# * KEEP, UNDO, PRE, POST, CONTROL
#   CATCH is tested in t/spec/S04-statements/try.t
#                  and t/spec/S04-exception-handlers/catch.t
#
# * $var will undo, etc
#
# * LEAVE type blocks in the context of CATCH
#
# * PRE/POST in classes is not the same as LEAVE/ENTER

# L

{
    my $str;

    for 1..10 -> $i {
        last if $i > 3;
        $str ~= "($i a)";
        next if $i % 2 == 1;
        $str ~= "($i b)";
        LAST  { $str ~= "($i Lst)" }
        LEAVE { $str ~= "($i Lv)"  }
        NEXT  { $str ~= "($i N)"   }
        FIRST { $str ~= "($i F)"   }
        ENTER { $str ~= "($i E)"   }
    }

    is $str, "(1 F)(1 E)(1 a)" ~ "(1 N)(1 Lv)" ~
                  "(2 E)(2 a)(2 b)(2 N)(2 Lv)" ~
                  "(3 E)(3 a)" ~ "(3 N)(3 Lv)" ~
                  "(4 E)"  ~          "(4 Lv)(4 Lst)",
       'trait blocks work properly in for loop';
}

{
    my $str;

    for 1..10 -> $i {
        last if $i > 3;
        $str ~= "($i a)";

        ENTER { $str ~= "($i E1)"   }
        LAST  { $str ~= "($i Lst1)" }
        FIRST { $str ~= "($i F1)"   }
        LEAVE { $str ~= "($i Lv1)"  }

        next if $i % 2 == 1;
        $str ~= "($i b)";

        LAST  { $str ~= "($i Lst2)" }
        NEXT  { $str ~= "($i N1)"   }
        FIRST { $str ~= "($i F2)"   }
        LEAVE { $str ~= "($i Lv2)"  }
        ENTER { $str ~= "($i E2)"   }
        NEXT  { $str ~= "($i N2)"   }
    }

    is $str, 
"(1 F1)(1 F2)(1 E1)(1 E2)(1 a)" ~ "(1 N2)(1 N1)" ~  "(1 Lv2)(1 Lv1)" ~
            "(2 E1)(2 E2)(2 a)(2 b)(2 N2)(2 N1)" ~  "(2 Lv2)(2 Lv1)" ~
            "(3 E1)(3 E2)(3 a)" ~ "(3 N2)(3 N1)" ~  "(3 Lv2)(3 Lv1)" ~
            "(4 E1)(4 E2)"  ~                       "(4 Lv2)(4 Lv1)" ~ "(4 Lst2)(4 Lst1)",
       'trait blocks work properly in for loop';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/interpolate.t0000664000175000017500000000205312224265625020532 0ustar  moritzmoritzuse v6;

# Test phasers interpolated in double-quoted strings

use Test;

plan 6;

# [TODO] add tests for ENTER/LEAVE/KEEP/UNDO/PRE/POST/etc

# L

# IRC log:
# ----------------------------------------------------------------
# agentzh   question: should BEGIN blocks interpolated in double-quoted
#           strings be fired at compile-time or run-time?
#           for example, say "This is { BEGIN { say 'hi' } }";
# audreyt   compile time.
#           qq is not eval.

my $hist;

END {
    is $hist, 'BCISE', 'interpolated END {...} executed';
}

#?pugs todo
nok "{ END { $hist ~= 'E' } }".defined,
    'END {...} not yet executed';

is "{ START { $hist ~= 'S' } }", "BCIS",
    'START {...} fired at run-time, entry time of the mainline code';

is "{ INIT { $hist ~= 'I' } }", 'BCI',
    'INIT {...} fired at the beginning of runtime';

is "{ CHECK { $hist ~= 'C' } }", "BC",
    'CHECK {...} fired at compile-time, ALAP';

is "{ BEGIN { $hist ~= 'B' } }", "B",
    'BEGIN {...} fired at compile-time, ASAP';

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/keep-undo.t0000664000175000017500000000344512224265625020101 0ustar  moritzmoritzuse v6;

use Test;

plan 12;

# L
# L

{
    my $str;
    my sub is_pos ($n) {
        return (($n > 0) ?? 1 !! Mu);
        KEEP { $str ~= "$n > 0 " }
        UNDO { $str ~= "$n <= 0 " }
    }

    ok is_pos(1), 'is_pos worked for 1';
    is $str, '1 > 0 ', 'KEEP ran as expected';

    ok !is_pos(0), 'is_pos worked for 0';
    is $str, '1 > 0 0 <= 0 ', 'UNDO worked as expected';

    ok !is_pos(-1), 'is_pos worked for 0';
    is $str, '1 > 0 0 <= 0 -1 <= 0 ', 'UNDO worked as expected';
}

# L
{
    my $str;
    my sub is_pos($n) {
        return (($n > 0) ?? 1 !! Mu);
        LEAVE { $str ~= ")" }
        KEEP { $str ~= "$n > 0" }
        UNDO { $str ~= "$n <= 0" }
        LEAVE { $str ~= "(" }
    }

    is_pos(1);
    is $str, '(1 > 0)', 'KEEP triggered as part of LEAVE blocks';

    is_pos(-5);
    is $str, '(1 > 0)(-5 <= 0)', 'UNDO triggered as part of LEAVE blocks';
}

# L

# multiple KEEP/UNDO
{
    my $str;
    {
        KEEP { $str ~= 'K1 ' }
        KEEP { $str ~= 'K2 ' }
        UNDO { $str ~= 'U1 ' }
        UNDO { $str ~= 'U2 ' }
        1;
    }
    is $str, 'K2 K1 ', '2 KEEP blocks triggered';
}

{
    my $str;
    {
        KEEP { $str ~= 'K1 ' }
        KEEP { $str ~= 'K2 ' }
        UNDO { $str ~= 'U1 ' }
        UNDO { $str ~= 'U2 ' }
    }
    is $str, 'U2 U1 ', '2 UNDO blocks triggered';
}

#?niecza skip "fail NYI"
{
    my $kept   = 0;
    my $undone = 0;
    sub f() {
        KEEP $kept   = 1;
        UNDO $undone = 1;
        fail 'foo';
    }
    my $sink = f; #OK
    nok $kept,   'fail() does not trigger KEEP';
    ok  $undone, 'fail() triggers UNDO';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/multiple.t0000664000175000017500000000142612224265625020042 0ustar  moritzmoritzuse v6;

# [TODO] add tests for ENTER/LEAVE/KEEP/UNDO/PRE/POST/etc

# Test multiple phasers.

use Test;

plan 2;

# L
# IRC log:
# [05:41]  TimToady: S04 doesn't discuss the running order 
#                   of multiple phasers (say, two END {} in 
#                   the same scope), so should we assume it's the
#                   same as in Perl 5?
# [05:41]  yes

my $hist;

END { is $hist, 'B b c C I i end End ', 'running order of multiple phasers' }

END { $hist ~= 'End ' }
END { $hist ~= 'end ' }

INIT { $hist ~= 'I ' }
INIT { $hist ~= 'i ' }

CHECK { $hist ~= 'C ' }
CHECK { $hist ~= 'c ' }

BEGIN { $hist ~= 'B ' }
BEGIN { $hist ~= 'b ' }

is $hist, 'B b c C I i ', 'running order of multiple phasers';

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/next.t0000664000175000017500000000615512224265625017171 0ustar  moritzmoritzuse v6;

use Test;

plan 13;

# L
{
    my $str = '';
    for 1..5 {
        NEXT { $str ~= ':' }
        next if $_ % 2 == 1;
        $str ~= $_;
    }
    is $str, ':2::4::', 'NEXT called by both next and normal falling out';
}

# NEXT is positioned at the bottom:
{
    my $str = '';
    for 1..5 {
        next if $_ % 2 == 1;
        $str ~= $_;
        NEXT { $str ~= ':' }
    }
    is $str, ':2::4::', 'NEXT called by both next and normal falling out';
}

# NEXT is positioned in the middle:
{
    my $str = '';
    for 1..5 {
        next if $_ % 2 == 1;
        NEXT { $str ~= ':' }
        $str ~= $_;
    }
    is $str, ':2::4::', 'NEXT called by both next and normal falling out';
}

# NEXT is evaluated even at the last iteration
{
    my $str = '';
    for 1..2 {
        NEXT { $str ~= 'n'; }
        LAST { $str ~= 'l'; }
    }
    #?pugs todo
    is $str, 'nnl', 'NEXT are LAST blocks may not be exclusive';
}

# L

{
    my $str = '';
    try {
        for 1..5 {
            NEXT { $str ~= $_ }
            die if $_ > 3;
        }
        0;
    }
    is $str, '123', "die didn't trigger NEXT \{}";
}

#?rakudo skip 'leave NYI'
{
    my $str = '';
    try {
        for 1..5 {
            NEXT { $str ~= $_ }
            leave if $_ > 3;
        }
        0;
    }
    #?pugs todo
    is $str, '123', "leave didn't trigger NEXT \{}";
}

{
    my $str = '';
    my sub foo {
        for 1..5 {
            NEXT { $str ~= $_ }
            return if $_ > 3;
        }
        0;
    }
    foo();
    is $str, '123', "return didn't trigger NEXT \{}";
}

# L
{
    my $str = '';
    for 1..5 {
        NEXT { $str ~= $_; }
        last if $_ > 3;
    }
    is $str, '123', "last bypass NEXT \{}";
}

# L

#?rakudo todo 'NEXT/LEAVE ordering'
{
    my $str = '';
    for 1..2 {
        NEXT { $str ~= 'n' }
        LEAVE { $str ~= 'l' }
    }
    #?pugs todo
    is $str, 'nlnl', 'NEXT {} ran before LEAVE {} (1)';
}

# reversed order
#?rakudo todo 'NEXT/LEAVE ordering'
{
    my $str = '';
    for 1..2 {
        LEAVE { $str ~= 'l' }
        NEXT { $str ~= 'n' }
    }
    #?pugs todo
    is $str, 'nlnl', 'NEXT {} ran before LEAVE {} (2)';
}

# L

# L

{
    my $str = '';
    my $n = 0;
    my $i;
    while $n < 5 {
        NEXT { ++$n }       # this gets run second (LIFO)
        NEXT { $str ~= $n } # this gets run first (LIFO)
        last if $i++ > 100; # recursion prevension
    }
    #?pugs todo
    is $str, '01234', 'NEXT {} ran in reversed order';
}

{
    my $str = '';
    loop (my $n = 0; $n < 5; ++$n) {
       NEXT { $str ~= $n }
    }
    is $str, '01234', 'NEXT {} works in loop (;;) {}';
}

{
    my @x = 0..4;
    my $str = '';
    for @x {
        NEXT { $str ~= $_; }
    }

    #?pugs todo
    is($str, '01234', 'NEXT {} works in for loop');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/pre-post.t0000664000175000017500000000714112224265625017760 0ustar  moritzmoritzuse v6;

use Test;
# Test of PRE and POST traits
#
# L
# L

plan 22;

sub foo(Int $i) {
    PRE {
        $i < 5
    }
    return 1;
}

sub bar(Int $i) {
    return 1;
    POST {
        $i < 5;
    }
}

lives_ok { foo(2) }, 'sub with PRE  compiles and runs';
lives_ok { bar(3) }, 'sub with POST compiles and runs';

#?pugs todo
dies_ok { foo(10) }, 'Violated PRE  throws (catchable) exception';
dies_ok { bar(10) }, 'Violated POST throws (catchable) exception';

# multiple PREs und POSTs

sub baz (Int $i) {
	PRE {
		$i > 0
	}
	PRE {
		$i < 23
	}
	return 1;
}
lives_ok { baz(2) }, 'sub with two PREs compiles and runs';

#?pugs todo
dies_ok  { baz(-1)}, 'sub with two PREs fails when first is violated';
#?pugs todo
dies_ok  { baz(42)}, 'sub with two PREs fails when second is violated';


sub qox (Int $i) {
	return 1;
	POST {
		$i > 0
	}
	POST {
		$i < 42
	}
}

lives_ok({ qox(23) }, "sub with two POSTs compiles and runs");
#?pugs todo
dies_ok( { qox(-1) }, "sub with two POSTs fails if first POST is violated");
dies_ok( { qox(123)}, "sub with two POSTs fails if second POST is violated");


class Another {
    method test(Int $x) {
        return 3 * $x;
        POST {
            $_ > 4
        }
    }
}

my $pt = Another.new;
#?pugs todo
lives_ok { $pt.test(2) }, 'POST receives return value as $_ (succeess)';
dies_ok  { $pt.test(1) }, 'POST receives return value as $_ (failure)';

{
    my $str;
    {
        PRE  { $str ~= '('; 1 }
        POST { $str ~= ')'; 1 }
        $str ~= 'x';
    }
    #?pugs todo
    is $str, '(x)', 'PRE and POST run on ordinary blocks';
}

{
    my $str;
    {
        POST  { $str ~= ')'; 1 }
        LEAVE { $str ~= ']' }
        ENTER { $str ~= '[' }
        PRE   { $str ~= '('; 1 }
        $str ~= 'x';
    }
    #?pugs todo
    is $str, '([x])', 'PRE/POST run outside ENTER/LEAVE';
}

{
    my $str;
    try {
        {
            PRE     { $str ~= '('; 0 }
            PRE     { $str ~= '*'; 1 }
            ENTER   { $str ~= '[' }
            $str ~= 'x';
            LEAVE   { $str ~= ']' }
            POST    { $str ~= ')'; 1 }
        }
    }
    #?pugs todo
    is $str, '(', 'failing PRE runs nothing else';
}

#?rakudo.jvm todo "nigh"
{
    my $str;
    try {
        {
            POST  { $str ~= 'z'; 1 }
            POST  { $str ~= 'x'; 0 }
            LEAVE { $str ~= 'y' }
        }
    }
    #?pugs todo
    is $str, 'yx', 'failing POST runs LEAVE but not more POSTs';
}

#?niecza skip 'unspecced'
{
    my $str;
    try {
        POST { $str ~= $! // ''; 1 }
        die 'foo';
    }
    #?pugs todo
    ok $str ~~ /foo/, 'POST runs on exception, with correct $!';
}

#?niecza skip 'unspecced'
#?rakudo todo 'POST and exceptions'
{
    my $str;
    try {
        POST { $str ~= (defined $! ?? 'yes' !! 'no'); 1 }
        try { die 'foo' }
        $str ~= (defined $! ?? 'aye' !! 'nay');
    }
    #?pugs todo
    is $str, 'ayeno', 'POST has undefined $! on no exception';
}

#?niecza skip 'unspecced'
#?rakudo.parrot todo "POST and exceptions"
#?rakudo.jvm skip "POST and exceptions"
{
    try {
        POST { 0 }
        die 'foo';
    }
    #?pugs todo
    ok $! ~~ /foo/, 'failing POST on exception doesn\'t replace $!';
    # XXX
    # is $!.pending.[-1], 'a POST exception', 'does push onto $!.pending';
}

{
    my sub blockless($x) {
        PRE $x >= 0;
        POST $_ == 4;
        return $x;
    }
    #?pugs todo
    lives_ok { blockless(4) }, 'blockless PRE/POST (+)';
    dies_ok  { blockless -4 }, 'blockless PRE/POST (-, 1)';
    dies_ok  { blockless 14 }, 'blockless PRE/POST (-, 2)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-phasers/rvalue.t0000664000175000017500000000433712224265625017511 0ustar  moritzmoritzuse v6;

# Test control blocks (BEGIN/CHECK/INIT/END) used as rvalues
# [TODO] add tests for other control blocks

use Test;

plan 16;

# L

{
    my $x = BEGIN { 8 };
    is $x, 8, 'BEGIN block as expression';

    # test that built-ins are available within a BEGIN block:
    my $y = BEGIN { uc 'moin' };
    is $y, 'MOIN', 'can access built-in functions in BEGIN blocks';

    my $z = BEGIN { 'moin'.uc };
    is $z, 'MOIN', 'can access built-in methods in BEGIN blocks';
}

#?pugs skip 'No such subroutine: "&BEGIN"'
{
    my $x = BEGIN 8;
    is $x, 8, 'BEGIN statement prefix as expression';

    # test that built-ins are available within a BEGIN block:
    my $y = BEGIN uc 'moin';
    is $y, 'MOIN', 'can access built-in functions in BEGIN statement prefix';

    my $z = BEGIN 'moin'.uc;
    is $z, 'MOIN', 'can access built-in methods in BEGIN statement prefix';
}

{
    my $hist = '';

    # Test INIT {} as rval:

    my $init_val;
    my $init = {
        $init_val = INIT { $hist ~= 'I' };
    }

    #?niecza todo 'block returns no value'
    is $init(), 'BCI', 'INIT {} runs only once';
    #?niecza todo 'block returns no value'
    is $init_val, 'BCI', 'INIT {} as rval is its ret val';
    #?niecza todo 'block returns no value'
    is $init(), 'BCI', 'INIT {} runs only once';

    # Test CHECK {} as rval:

    my $check_val;
    my $check = {
        $check_val = CHECK { $hist ~= 'C' };
    }

    #?niecza todo 'block returns no value'
    #?rakudo.jvm 3 todo "nigh"
    is $check(), 'BC', 'CHECK {} runs only once';
    #?niecza todo 'block returns no value'
    is $check_val, 'BC', 'CHECK {} as rval is its ret val';
    #?niecza todo 'block returns no value'
    is $check(), 'BC', 'CHECK {} runs only once';

    # Test BEGIN {} as rval:

    my $begin_val;
    my $begin = {
        $begin_val = BEGIN { $hist ~= 'B'; 'B' };
    }

    is $begin(), 'B', 'BEGIN {} runs only once';
    is $begin_val, 'B', 'BEGIN {} as rval is its ret val';
    is $begin(), 'B', 'BEGIN {} runs only once';

    # Test END {} as rval:
    #?niecza skip 'Excess arguments to eval, used 1 of 2 positionals'
    ok !eval('my $end_val = END { 3 }'), "END {} can't be used as a rvalue";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/for.t0000664000175000017500000000433212224265625021312 0ustar  moritzmoritzuse v6;

use Test;

plan 20;

# L

# test the for statement modifier
{
    my $a = '';
    $a ~= $_ for ('a', 'b', 'a', 'b', 'a');
    is($a, "ababa", "post for with parens");
}

# without parens
{
    my $a = '';
    $a ~= $_ for 'a', 'b', 'a', 'b', 'a';
    is($a, "ababa", "post for without parens");
}

{
    my $a = 0;
    $a += $_ for (1 .. 10);
    is($a, 55, "post for 1 .. 10 with parens");
}

{
    my $a = 0;
    $a += $_ for 1 .. 10;
    is($a, 55, "post for 1 .. 10 without parens");
}

{
    my @a = (5, 7, 9);
    my $a = 3;
    $a *= $_ for @a;
    is($a, 3 * 5 * 7 * 9, "post for array");
}

{
    my @a = (5, 7, 9);
    my $i = 5;
    my sub check(Int $n){
        is($n, $i, "sub Int with post for");
        $i += 2;
    }
    check $_ for @a;
}

{
    my $a = "";
    $a ~= "<$_>" for "hello";
    is $a, "", 'iterating one constant element works';
}

{
    my $a = ""; my $v = "hello";
    $a ~= "<$_>" for $v;
    is $a, "", 'iterating one variable element works';
}

#?niecza todo "closure for"
#?pugs todo
{
    my $a = 0;
    { $a++ } for 1..3;
    is $a, 3, 'the closure was called';
}

#?niecza todo "closure for"
#?pugs todo
{
    my $a = 0;
    -> $i { $a += $i } for 1..3;
    is $a, 6, 'the closure was called';
}

# L statement/for and given privately temporize>
{
    my $i = 0;
    $_ = 10;
    $i += $_ for 1..3;
    #?pugs todo
    is $_, 10, 'outer $_ did not get updated in lhs of for';
    is $i, 1+2+3, 'postfix for worked';
}

# L statement/When used as statement modifiers on implicit blocks>

#?pugs skip "Can't modify constant item: VInt 3"
{
    $_ = 42;
    my @trace;
    @trace.push: $_ for 2, 3;
    is @trace.join(':'), '2:3', 'statement modifier "for" sets $_ correctl';
    is $_, 42, '"for" statement modifier restored $_ of outer block';
}

# RT 66622
{
    my $rt66622 = 66622 for 1, 2, 3;
    is $rt66622, 66622, 'statement modifier "for" makes no implicit block';
}

eval_dies_ok '1 for  for ;', 'double statement-modifying for is not allowed';

# RT #66606
{
    my $x = 1 for ^3;
    is $x, 1;
    (my @a).push: $_ for ^3;
    is @a.join(','), '0,1,2';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/given.t0000664000175000017500000000126612224265625021637 0ustar  moritzmoritzuse v6;

use Test;

plan 5;

# L

# test the ``given'' statement modifier
{
    my $a = 0;
    $a = $_ given 2 * 3;
    is($a, 6, "post given");
}

# test the ``given'' statement modifier
{
    my $a;
    $a = $_ given 2 * 3;
    is($a, 6, "post given");
}

{
    my $a = '';
    $a = $_ given 'a';
    is($a, 'a', "post given");
}

# L statement/for and given privately temporize>
#?pugs skip "Can't modify constant item"
{
    my $i = 0;
    $_ = 10;
    $i += $_ given $_+3;
    is $_, 10, 'outer $_ did not get updated in lhs of given';
    is $i, 13, 'postfix given worked';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/if.t0000664000175000017500000000251612224265625021124 0ustar  moritzmoritzuse v6;

use Test;

plan 11;

# L

# test the if statement modifier
{
    my $a = 1;
    $a = 2 if 'a' eq 'a';
    is($a, 2, "post if");
}

{
    my $a = 1;
    $a = 3 if 'a' eq 'b';
    is($a, 1, "post if");
}

{
	my $answer = 1;
	my @x = 41, (42 if $answer), 43;
	my @y = 41, ($answer ?? 42 !! ()), 43;
	my @z = 41, 42, 43;
	is @y, @z, "sanity check";
	is @x, @y, "if expr on true cond"; 
}

{
	my $answer = 0;
	my @x = 41, (42 if $answer), 43;
	my @y = 41, ($answer ?? 42 !! ()), 43;
	my @z = 41, 43;
	is @y, @z, "sanity check";
        #?niecza todo "empty list as element not flattened - https://github.com/sorear/niecza/issues/180"
	is @x, @y, "if expr on false cond"; 
}


#testing else part of the operator 
{
	my $answer = 0;
	my $x = $answer ?? 42 !! 43;
	is $x, 43, "?? || sanity check";
}

{
	sub foo() {
	 return if 1;
	 123;
	}
	
	my $ok = 1;
	for foo() -> @foo {
	    $ok = 0;
	}
	ok $ok, "condition in statement level respects context" 
}

{
    my $x = (3 if 1);
    my $y = (3 if 0);
    is $x, 3, '(3 if 1) worked in scalar context';
    ok !$y, 'my $y = (3 if 0) leaves $y false';
}

# return value of false 'if' should be Nil
# see http://rt.perl.org/rt3/Ticket/Display.html?id=66544

{
    is (42 if 0), Nil, '"$something if 0" is Nil';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/unless.t0000664000175000017500000000157712224265625022045 0ustar  moritzmoritzuse v6;

use Test;

plan 6;

# test the unless statement modifier

# L
{
    my $a = 1;
    $a = 4 unless 'a' eq 'a';
    is($a, 1, "post unless");
}

{
    my $a = 1;
    $a = 5 unless 'a' eq 'b';
    is($a, 5, "post unless");
}

{
        my $answer = 1;
        my @x = 41, (42 unless $answer), 43;
        my @y = 41, (!$answer ?? 42 !! ()), 43;
        my @z = 41, 43;
        is @y, @z, "sanity check";
        #?niecza todo "empty list as element not flattened - https://github.com/sorear/niecza/issues/180"
        is @x, @y, "unless expr on true cond";
}

{
        my $answer = 0;
        my @x = 41, (42 unless $answer), 43;
        my @y = 41, (!$answer ?? 42 !! ()), 43;
        my @z = 41, 42, 43;
        is @y, @z, "sanity check";
        is @x, @y, "unless expr on false cond";
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/until.t0000664000175000017500000000127012224265625021655 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# L

# test simple the ``until'' statement modifier
{
    my $a=0;
    $a += 1 until $a >= 10;
    is($a, 10, "post until");
}

# test the ``until'' statement modifier
{
    my ($a, $b);
    $a=0; $b=0;
    $a += $b += 1 until $b >= 10;
    is($a, 55, "post until");
}

#?pugs skip "cannot shift scalar"
{
    my @a = ('a', 'b', 'a');
    my $a = 'b';
    $a ~= ', ' ~ shift @a until !+@a;
    is($a, "b, a, b, a", "post until");
}

#?pugs skip "cannot shift scalar"
{
    my @a = 'a'..'e';
    my $a = 0;
    $a++ until shift(@a) eq 'c';
    is($a, 2, "post until");
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/values_in_bool_context.t0000664000175000017500000000464712224265625025301 0ustar  moritzmoritzuse v6;

use Test;

plan 24;

# L

##  scalar checking  ##

{
    my $var = 20;

    my ($a, $b, $c, $d, $e, $f, $g, $h);

    $a = 1 if 1;
    $b = 1 if 0;
    $c = 1 if "true";
    $d = 1 if "";
    $e = 1 if "1";
    $f = 1 if "0";
    $g = 1 if Mu;
    $h = 1 if $var;

    ok  $a, 'literal in bool context - numeric true value';
    ok !$b, 'literal in bool context - numeric false value';
    ok  $c, 'literal in bool context - string true value';
    ok !$d, 'literal in bool context - string false value';
    ok  $e, 'literal in bool context - stringified true value';
    ok !$f, 'literal in bool context - stringified false value';
    ok !$g, 'literal in bool context - undefined value';
    ok  $h, 'literal in bool context - scalar variable';
}

##  array checking  ##

{
    my @array = (1, 0, "true", "", "1", "0", Mu);

    my ($a, $b, $c, $d, $e, $f, $g, $h);

    $a = 1 if @array[0];
    $b = 1 if @array[1];
    $c = 1 if @array[2];
    $d = 1 if @array[3];
    $e = 1 if @array[4];
    $f = 1 if @array[5];
    $g = 1 if @array[6];
    $h = 1 if @array;

    ok  $a, 'array in bool context - numeric true value';
    ok !$b, 'array in bool context - numeric false value';
    ok  $c, 'array in bool context - string true value';
    ok !$d, 'array in bool context - string false value';
    ok  $e, 'array in bool context - stringified true value';
    ok !$f, 'array in bool context - stringified false value';
    ok !$g, 'array in bool context - undefined value';
    ok  $h, 'array in bool context  array as a whole';
}

##  hash checking  ##

{
    my %hash = (
        0 => 1, 1 => 0, 2 => "true",
        3 => "", 4 => "1", 5 => "0", 6 => Mu
    );

    my ($a, $b, $c, $d, $e, $f, $g, $h);

    $a = 1 if %hash{0};
    $b = 1 if %hash{1};
    $c = 1 if %hash{2};
    $d = 1 if %hash{3};
    $e = 1 if %hash{4};
    $f = 1 if %hash{5};
    $g = 1 if %hash{6};
    $h = 1 if %hash;

    ok  $a, 'hash in bool context - numeric true value';
    ok !$b, 'hash in bool context - numeric false value';
    ok  $c, 'hash in bool context - string true value';
    ok !$d, 'hash in bool context - string false value';
    ok  $e, 'hash in bool context - stringified true value';
    ok !$f, 'hash in bool context - stringified false value';
    ok !$g, 'hash in bool context - undefined value';
    ok  $h, 'hash in bool context - hash as a whole';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-modifiers/while.t0000664000175000017500000000144012224265625021631 0ustar  moritzmoritzuse v6;

use Test;

plan 5;

# L

# simple while modifier test
{
    my $a = 0;
    $a += 1 while $a < 10;
    is($a, 10, "post simple while modifier");
}

# simple while modifier test
{
    my $a;
    $a += 1 while $a < 10;
    is($a, 10, "post simple while modifier");
}

# test the ``while'' statement modifier
{
    my $a = 0;
    my $b = 0;
    $a += $b += 1 while $b < 10;
    is($a, 55, "post while");
}

#?pugs skip 'Cannot shift scalar'
{
    my @a = 'b'..'d';
    my $a = 'a';
    $a ~= ', ' ~ shift @a while @a;
    is($a, "a, b, c, d", "post while");
}

#?pugs skip 'Cannot shift scalar'
{
    my @a = 'a'..'e';
    my $a = 0;
    ++$a while shift(@a) ne 'd';
    is($a, 3, "post while");
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statement-parsing/hash.t0000664000175000017500000000136012224265625021127 0ustar  moritzmoritzuse v6;
use Test;

# L

plan 8;

isa_ok hash('a', 1), Hash, 'hash() returns a Hash';
is hash('a', 1).keys, 'a', 'hash() with keys/values (key)';
#?pugs todo
is hash('a', 1).values, 1, 'hash() with keys/values (values)';

is hash('a' => 1).keys, 'a', 'hash() with pair (key)';
#?pugs todo
is hash('a' => 1).values, 1, 'hash() with pair (values)';

#?pugs 2 skip 'Named argument found where no matched parameter expected'
is hash(a => 1).keys, 'a', 'hash() with autoquoted pair (key)';
is hash(a => 1).values, 1, 'hash() with autoquoted pair (values)';

#RT #78096
{
    lives_ok { my @r=2..10,;my %v=j=>10,q=>10,k=>10,a=>1|11;},
        "q => doesn't trigger quoting construct";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/do.t0000664000175000017500000000722612224265625017337 0ustar  moritzmoritzuse v6;

use Test;

plan 27;

# L
# Note in accordance with STD, conditionals are OK, loops are not.
eval_dies_ok 'my $i = 1; do { $i++ } while $i < 5;',
    "'do' can't take the 'while' modifier";

eval_dies_ok 'my $i = 1; do { $i++ } until $i > 4;',
    "'do' can't take the 'until' modifier";

eval_dies_ok 'my $i; do { $i++ } for 1..3;',
    "'do' can't take the 'for' modifier";

eval_dies_ok 'my $i; do { $i++ } given $i;',
    "'do' can't take the 'given' modifier";

#?pugs todo
eval_lives_ok 'my $i; do { $i++ } unless $i;',
    "'do' can take the 'unless' modifier";

#?pugs todo
eval_lives_ok 'my $i = 1; do { $i++ } if $i;',
    "'do' can take the 'if' modifier";

# L
{
    my $x;
    my ($a, $b, $c) = 'a' .. 'c';

    $x = do if $a { $b } else { $c };
    is $x, 'b', "prefixing 'if' statement with 'do' (then)";

    $x = do if !$a { $b } else { $c };
    is $x, 'c', "prefixing 'if' statement with 'do' (else)";
}
	
=begin comment
	If the final statement is a conditional which does not execute 
	any branch, the return value is undefined in item context and () 
	in list context.
=end comment
{
	my $x = do if 0 { 1 } elsif 0 { 2 };
	ok !$x.defined, 'when if does not execute any branch, return undefined';
}

{
    my $ret = do given 3 {
        when 3 { 1 }
    };
    is($ret, 1, 'do STMT works');
}

{
    my $ret = do { given 3 {
        when 3 { 1 }
    } };
    is($ret, 1, 'do { STMT } works');
}

# L
{
    my $ret = do 42;
    is($ret, 42, 'do EXPR should also work (single number)');

    $ret = do 3 + 2;
    is($ret, 5, 'do EXPR should also work (simple + expr)');

    $ret = do do 5;
    is($ret, 5, 'nested do (1)');

    $ret = do {do 5};
    is($ret, 5, 'nested do (2)');

    # precedence decisions do not cross a do boundary
    $ret = 2 * do 2 + 5;
    is($ret, 14, 'do affects precedence correctly');
}

# L
#?rakudo skip 'next without loop construct'
{
    my $i;
    do {
        $i++;
        next;
        $i--;
    };
    is $i, 1, "'next' works in 'do' block";
}

#?rakudo 3 skip "Undeclared name A"
#?pugs 3 todo
is eval('my $i; A: do { $i++; last A; $i-- }; $i'), 1,
    "'last' works with label";
is eval('my $i; A: do { $i++; next A; $i-- }; $i'), 1,
    "'next' works with label";
is eval('my $i; A: do { $i++; redo A until $i == 5; $i-- }; $i'), 4,
    "'redo' works with label";

#?rakudo skip 'last without loop construct'
{
    is eval('
        my $i;
        do {
            $i++;
            last;
            $i--;
        };
        $i;
    '), 1, "'last' works in 'do' block";
}

# IRC notes:
#  audreyt: btw, can i use redo in the do-once loop?
#  it can, and it will redo it
#?rakudo skip 'redo without loop construct'
{
    is eval('
        my $i;
        do {
            $i++;
            redo if $i < 3;
            $i--;
        };
        $i;
    '), 2, "'redo' works in 'do' block";
}

# L
{
    eval_dies_ok 'my $i; { $i++; next; $i--; }',
        "bare block can't take 'next'";

    eval_dies_ok 'my $i; { $i++; last; $i--; }',
        "bare block can't take 'last'";
    
    eval_dies_ok 'my $i; { $i++; redo; $i--; }',
        "bare block can't take 'last'";
}

# L
{
    my $a = do {
        1 + 2;
    }  # no trailing `;'
    is $a, 3, "final `}' on a line reverted to `;'";
}

#?pugs todo
lives_ok { my $a = do given 5 {} }, 'empty do block lives (RT 61034)';

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/for-scope.t0000664000175000017500000000273312224265625020630 0ustar  moritzmoritzuse v6;

use Test;

# L statement>

plan 16;

# Implicit $_
for 1, 2 {
    my $inside = '';
    for 1 .. 3 { $inside ~= $_; }
    is($inside, "123", "lexical scalar properly initialized, round $_");
}

for 1, 2 {
    my @inside;
    for 1 .. 3 { push @inside, $_; }
    is(@inside.join, "123", "lexical array properly initialized, round $_");
}

# Explicit $_
for 1, 2 {
    my $inside = '';
    for 1 .. 3 -> $_ { $inside ~= $_; }
    is($inside, "123", "lexical scalar properly initialized, round $_, explicit \$_");
}

for 1, 2 {
    my @inside;
    for 1 .. 3 -> $_ { push @inside, $_; }
    is(@inside.join, "123", "lexical array properly initialized, round $_, explicit \$_");
}

# Explicit $_
for 1, 2 -> $_ {
    my $inside = '';
    for 1 .. 3 -> $_ { $inside ~= $_; }
    is($inside, "123", "lexical scalar properly initialized, round $_, two explicit \$_s");
}

for 1, 2 -> $_ {
    my @inside;
    for 1 .. 3 -> $_ { push @inside, $_; }
    is(@inside.join, "123", "lexical array properly initialized, round $_, two explicit \$_s");
}

{
    sub respect(*@a) {
        my @b = ();
        @b.push($_) for @a;
        return @b.elems;
    }

    is respect(1,2,3), 3, 'a for loop inside a sub loops over each of the elements';
    is respect([1,2,3]), 1, '... but only over one array ref';
    is respect( my @a = 1, 2, 3 ), 3, '...and when the array is declared in the argument list';
    is @a.join(','), '1,2,3', 'and the array get the right values';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/for.t0000664000175000017500000003034012224265625017514 0ustar  moritzmoritzuse 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 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 = ;

{
    my @a;
    for (@elems) {
        push @a, $_;
    }
    my @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 = ;
    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 = ;
  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 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
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
rakudo-2013.12/t/spec/S04-statements/for_with_only_one_item.t0000664000175000017500000000272712224265625023477 0ustar  moritzmoritzuse v6;

use Test;

# L statement>

# Test primarily aimed at PIL2JS

plan 9;

# sanity tests
{
  my $res='';

  for  { $res ~= $_ }
  is $res, "abc", "for works with an <...> array literal";
}

{
  my $res='';

  for () { $res ~= $_ }
  is $res, "abc", "for works with an (<...>) array literal";
}

# for with only one item, a constant
{
  my $res='';

  for ("a",) { $res ~= $_ }
  is $res, "a", "for works with an (a_single_constant,) array literal";
}

{
  my $res='';

  for ("a") { $res ~= $_ }
  is $res, "a", "for works with (a_single_constant)";
}

{
  my $res='';

  for "a" { $res ~= $_ }
  is $res, "a", "for works with \"a_single_constant\"";
}

# for with only one item, an arrayref
# See thread "for $arrayref {...}" on p6l started by Ingo Blechschmidt,
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22970">
{
  my $arrayref = [1,2,3];

  my $count=0;
  for ($arrayref,) { $count++ }

  is $count, 1, 'for ($arrayref,) {...} executes the loop body only once';
}

{
  my $arrayref = [1,2,3];

  my $count=0;
  for ($arrayref) { $count++ }

  is $count, 1, 'for ($arrayref) {...} executes the loop body only once';
}

{
  my $arrayref = [1,2,3];

  my $count=0;
  for $arrayref { $count++ }

  is $count, 1, 'for $arrayref {...} executes the loop body only once';
}

# RT #73400
{
  my $capture = \[1,2,3];
  my $count = 0;
  for $capture { $count++ }

  is $count, 1, 'for $capture {...} executes the loop body only once';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/gather.t0000664000175000017500000001161312224265625020202 0ustar  moritzmoritzuse v6;

use Test;

plan 28;


# L statement prefix/>

# Standard gather
{
    my @a;
    my $i;
    
    @a := gather {
        $i = 1;
        for (1 .. 5) -> $j {
            take $j;
        }
    };

    ok(!$i, "not yet gathered");
    is(+@a, 5, "5 elements gathered");
    ok($i, "gather code executed");
    is(@a[0], 1, "first elem taken");
    is(@a[*-1], 5, "last elem taken");
};

# Nested gathers, two levels
{
  my @outer = gather {
    for 1..3 -> $i {
      my @inner = gather {
         take $_ for 1..3;
      };

      take "$i:" ~ @inner.join(',');
    }
  };

  is ~@outer, "1:1,2,3 2:1,2,3 3:1,2,3", "nested gather works (two levels)";
}

# Nested gathers, three levels
{
  my @outer = gather {
    for 1..2 -> $i {
      my @inner = gather {
        for 1..2 -> $j {
          my @inner_inner = gather {
              take $_ for 1..2;
          };
          take "$j:" ~ @inner_inner.join(',');
        }
      };
      take "$i:" ~ @inner.join(';');
    }
  };

  is ~@outer, "1:1:1,2;2:1,2 2:1:1,2;2:1,2", "nested gather works (three levels)";
}

# take on lists, multiple takes per loop
{
  my @outer = gather {
    my @l = (1, 2, 3);
    take 5;
    take @l;
    take 5;
  };

  is ~@outer, "5 1 2 3 5", "take on lists and multiple takes work";
}

# gather scopes dynamiclly, not lexically
{
    my $dynamic_take = sub { take 7 };
    my @outer = gather {
        $dynamic_take();
        take 1;
    };

    is ~@outer, "7 1", "gather scopes dynamically, not lexically";
}

# take on array-ref
{
  my @list  = gather { take [1,2,3]; take [4,5,6];};
  my @list2 = ([1,2,3],[4,5,6]);
  is @list.perl, @list2.perl , "gather array-refs";
}

# gather statement prefix
{
    my @out = gather for 1..5 {
        take $_;
    };

    is ~@out, "1 2 3 4 5", "gather as a statement_prefix";
}

# lazy gather
{
    my $count = 0;
    my @list := gather {
        for 1 .. 10 -> $a {
            take $a;
            $count++
        }
    };
    my $result = @list[2];
    is($count, 2, "gather is lazy");	
}

{
    my @list = gather {
        my $v = 1;
        while $v <= 10 {
            take $v if $v % 2 == 0;
            $v++;
        }
    };
    is ~@list, "2 4 6 8 10", "gather with nested while";
}

{
    my @list = gather {
        loop (my $v = 1; $v <= 10; $v++)
        {
            take $v if $v % 2 == 0;
        }
    };
    is ~@list, "2 4 6 8 10", "gather with nested loop";
}

{
    is (gather { take 1, 2, 3; take 4, 5, 6; }).elems, 2,
        'take with multiple arguments produces one item each';

    is (gather { take 1, 2, 3; take 4, 5, 6; }).flat.elems, 6,
        'take with multiple arguments .flat tens out';
}

#?rakudo skip 'RT #117635 (infinite loop)'
{
    my sub grep-div(@a, $n) {
        gather for @a {
            take $_ if $_ %% $n;
        }
    }
    
    my @evens := grep-div((1...*), 2);
    is ~grep-div(@evens, 3)[^16], ~grep-div((1...100), 6), "Nested identical gathers";
}

# RT #77036
{
    class E {
        has $.n is rw;
        has $.v;
        method Str() {~self.v }
    };
    my E $x .= new(:v(1));
    $x.n = E.new(:v(2));
    is (gather { my $i = $x; while $i.defined { take $i; $i = $i.n } }).join("|"), '1|2', 'Elements in gather/take stringify correctly';

}

# RT #78026, RT #77302
{
    sub foo {
        my @a = (1,2,3,4,5);
        gather {
            my $val ;
            while @a {
                $val = @a.shift();
                take $val;
            }
        }
    };
    is foo().join, '12345', 'decontainerization happens (1)';
    is ( Zxx 0,1,0,1,0).Str, 'b d',
        'decontainerization happens (2)';
}

# Method form of take
{
  my @outer = gather {
    my @l = (1, 2, 3);
    5.take;
    @l.take;
    5.take;
  };

  is ~@outer, "5 1 2 3 5", "method form of take works.";
}

# RT #115598
{
    my $x;
    my @a = gather { $x = take 3; };
    is $x, 3, "return value of take" 
}

# tests for the S04-control.pod document
#?rakudo.jvm skip "unwind"
{
    my @list = 1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 5, 6, 6;
    my @uniq = gather for @list {
        state $previous = take $_;
        next if $_ === $previous;
        $previous = take $_;
    }
    is @uniq, (1, 2, 3, 4, 5, 6), "first example in S04-control.pod works";
}

#?niecza skip 'Cannot use bind operator with this LHS'
{
    my @y;
    my @x = gather for 1..2 {            # flat context for list of parcels
        my ($y) := \(take $_, $_ * 10);  # binding forces item context
        push @y, $y;
    }
    is @x, (1, 10, 2, 20), "take in flat context flattens";
    is @y, ($(1, 10), $(2, 20)), "take in item context doesn't flatten";
}

#?niecza skip 'Cannot use bind operator with this LHS'
{
    my ($c) := \(gather for 1..2 {
        take $_, $_ * 10;
    });
    is $c.flat, (1,10,2,20), ".flat flattens fully into a list of Ints.";
    is $c.lol, LoL.new($(1,10),$(2,20)), ".lol: list of Parcels.";
    is $c.item, ($(1,10),$(2,20)).list.item, "a list of Parcels, as an item.";
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/given.t0000664000175000017500000001604312224265625020042 0ustar  moritzmoritzuse v6;

use Test;

plan 51;

=begin pod

Tests the given block, as defined in L

=end pod

{
    # basic sanity
    my ($t, $f);

    try { given 1 { when 1 { $t = 1 } } };
    ok($t, "given when true ...");

    try { given 1 { when 2 { $f = 1 } } };;
    ok(!$f, "given when false");
};

#?pugs skip 'proceed NYI'
{
    # simple case, with fall through
    # L
    my ($two, $five, $int, $unreached);

    given 5 {
        when 2 { $two = 1 }
        when 5 { $five = 1; proceed }
        when Int { $int = 1 }
        when 5 { $unreached = 1 }
    }

    ok(!$two, "5 is not two");
    ok($five, "5 is five");
    ok($int, "short fell-through to next true when using 'proceed'");
    ok(!$unreached, "but didn't do so normally");
};

#?pugs todo
{
    my $foo;
    my $match;
    given "foo" {
        when "foo" {
            when /^f/ {
                $foo = 1;
                $match = $/;
            }
        }
    }

    ok($foo, "foo was found in nested when");
    # RT #99912
    ok $match, 'regex in when-clause set match object';
};

{
    # interleaved code L
    my ($b_one, $b_two, $b_three, $panic);
    given 2 {
        $b_one = 1;
        when 1 { }
        $b_two = 1;
        when 2 { }
        $b_three = 1;
        default { }
        $panic = 1;
    }

    ok($b_one, "interleaved 1");
    ok($b_two, "interleaved 2 is the last one");
    ok(!$b_three, "inteleraved 3 not executed");
    ok(!$panic, 'never ever execute something after a default {}');
};

{
    # topic not given by 'given' L
    my ($b_one, $b_two, $b_three,$panic) = (0,0,0,0);
    for <1 2 3> {
        when 1 {$b_one = 1}
        when 2 {$b_two = 1}
        when 3 {$b_three = 1}
        default {$panic =1}
    }
        ok($b_one, "first iteration");
        ok($b_two, "second iteration");
        ok($b_three, "third iteration");
        ok(!$panic,"should not fall into default in this case");
}

#?pugs skip 'proceed NYI'
{
    my ($foo, $bar) = (1, 0);
    given 1 {
        when 1 { $foo = 2; proceed; $foo = 3; }
        when 2 { $foo = 4; }
        default { $bar = 1; }
        $foo = 5;
    };
    is($foo, 2, 'proceed aborts when block');
    ok($bar, 'proceed does not prevent default');
}

#?pugs skip 'succeed NYI'
{
    my ($foo, $bar) = (1, 0);
    given 1 {
        when 1 { $foo = 2; succeed; $foo = 3; }
        when 2 { $foo = 4; }
        default { $bar = 1 }
        $foo = 5;
    };
    is($foo, 2, 'succeed aborts when');
    ok(!$bar, 'succeed prevents default');
}

#?pugs skip 'proceed NYI'
{
    my ($foo, $bar, $baz, $bad) = (0, 0, -1, 0);
    my $quux = 0;
    for 0, 1, 2 {
        when 0 { $foo++; proceed }
        when 1 { $bar++; succeed }
        when 2 { $quux++; }
        default { $baz = $_ }
        $bad = 1;
    };
    is($foo, 1, 'first iteration');
    is($bar, 1, 'second iteration');
    is($baz, 0, 'proceed worked');
    is($quux, 1, "succeed didn't abort loop");
    ok(!$bad, "default didn't fall through");
}


# given returns the correct value:
{
     sub ret_test($arg) {
       given $arg {
         when "a" { "A" }
         when "b" { "B" }
       }
     }

    is( ret_test("a"), "A", "given returns the correct value (1)" ); 
    is( ret_test("b"), "B", "given returns the correct value (2)" ); 
}

# given/succeed returns the correct value:
#?pugs skip 'succeed NYI'
{
     sub ret_test($arg) {
       given $arg {
         when "a" { succeed "A"; 'X'; }
         when "b" { succeed "B"; 'X'; }
       }
     }

    is( ret_test("a"), "A", "given returns the correct value (1)" ); 
    is( ret_test("b"), "B", "given returns the correct value (2)" ); 
}

# given/when and junctions
{
    my $any = 0;
    my $all = 0;
    my $one = 0;
    given 1 {
          when any(1 .. 3) { $any = 1; }
    }
    given 1 {
          when all(1)      { $all = 1; }
    }
    given 1 {
          when one(1)      { $one = 1; }          
    }
    is($any, 1, 'when any');
    is($all, 1, 'when all');
    is($one, 1, 'when one');
}

# given + objects
{
    class TestIt { method passit { 1; }; has %.testing is rw; };
    my $passed = 0;
    ok( eval('given TestIt.new { $_.passit; };'), '$_. method calls' );
    ok( eval('given TestIt.new { .passit; };'), '. method calls' );
    ok( eval('given TestIt.new { $_.testing = 1; };'),'$_. attribute access' );
    ok( eval('given TestIt.new { .testing = 1; };'),  '. attribute access' );
    my $t = TestIt.new;
    given $t { when TestIt { $passed = 1;} };
    is($passed, 1,'when Type {}');
{
    $passed = 0;
    given $t { when .isa(TestIt) { $passed = 1;}};
    is($passed, 1,'when .isa(Type) {}');
}
    $passed = 0;
    given $t { when TestIt { $passed = 1; }};
    is($passed, 1,'when Type {}');
}

{
    # given + true
    # L
    my @input = (0, 1);
    my @got;

    for @input -> $x {
        given $x {
            when .so { push @got, "true" }
            default { push @got, "false" }
        }
    }

    is(@got.join(","), "false,true", 'given { when .so { } }');
}

# given + hash deref
{
    my %h;
    given %h { .{'key'} = 'value'; }
    ok(%h{'key'} eq 'value', 'given and hash deref using .{}');
    given %h { . = "value"; }
    ok(%h{'key'} eq 'value', 'given and hash deref using .<>');
}

# given + 0-arg closure
#?pugs skip 'parsefail'
{
    my $x = 0;
    given 41 {
        when { $_ == 49 } { diag "this really shouldn't happen"; $x = 49 }
        when { $_ == 41 } { $x++ }
    }
    ok $x, 'given tests 0-arg closures for truth';
}

# given + 1-arg closure
#?pugs skip 'parsefail'
{
    my $x;
    given 41 {
        when -> $t { $t == 49 } { diag "this really shouldn't happen"; $x = 49 }
        when -> $t { $t == 41 } { $x++ }
    }
    ok $x, 'given tests 1-arg closures for truth';
}

# given + n>1-arg closure (should fail)
#?pugs skip 'parsefail'
{
    dies_ok {
        given 41 {
            when -> $t, $r { $t == $r } { ... }
        }
    }, 'fail on arities > 1';
}

# given + 0-arg sub
{
    my $x = 41;
    sub always_true { Bool::True }
    given 1 {
        when &always_true { $x++ }
    }
    is $x, 42, 'given tests 0-arg subs for truth';
}

# given + 1-arg sub
{
    my $x = 41;
    sub maybe_true ($value) { $value eq "mytopic" }
    given "mytopic" {
        when &maybe_true { $x++ }
    }
    is $x, 42, 'given tests 1-arg subs for truth';
}

# statement-modifying 'when'
#?pugs skip 'parsefail'
{
    my $tracker = 1;
    given 1 {
        $tracker++ when 1;
    }
    is $tracker, 2, 'statement-modifying when';
}

# RT #78234
eval_lives_ok 'given 3 { sub a() { } }', 'can define a sub inside a given';
#?pugs todo
eval_lives_ok 'sub a() { } given 3',     'can define a sub inside a statement-modifying given';

#?pugs todo 'ok variant?'
{
    my $capture-is-correct = False;
    given "Hello" { 
        when /e(\w\w)/ { $capture-is-correct = $0 eq "ll"; } 
    }
    ok $capture-is-correct, 'matches in when correctly set $0';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/goto.t0000664000175000017500000000273012224265625017700 0ustar  moritzmoritzuse v6;
use Test;
plan 13;

# L

=begin description

Tests for the goto() builtin

We have "phases" to make sure the gotos didn't run wild.

=end description


our $phase;

sub test1_ok { return 1 }
sub test1 {
    &test1_ok.nextwith();
    return 0;
}
ok(test1(), "&sub.nextwith does");
is(++$phase, 1, "phase completed");

# the same, but with subs declared after the call.

sub test2 {
    &test2_ok.nextwith();
    return 0;
}
sub test2_ok { return 1 }
ok(test2(), "&sub.nextwith does (forward reference)");
is(++$phase, 2, "phase completed");

ok(test3(), "&sub.nextwith does (real forward reference)");
sub test3 {
    &test3_ok.nextwith();
    return 0;
}
sub test3_ok { 1 }
is(++$phase, 3, "phase completed");

is(moose(), $?LINE, "regular call to moose() is consistent");
is(foo(), $?LINE, "goto eliminates call stack frames");

sub foo {
    &moose.nextwith();
}

sub moose {
    $?CALLER::LINE;
}

is(++$phase, 4, "phase completed");

# Simple test case to get support for goto LABEL in pugs
# Source for the syntax: S06 "The leave function"
# > last COUNT;

our $test5 = 1;
eval q{ goto SKIP5; };
$test5 = 0;
SKIP5:
#?pugs todo 'feature'
is($test5, 1, "goto label");

is(++$phase, 5, "phase completed");

# this one tests "goto EXPR" syntax. pugs treats "last EXPR" as "last;" in r14915.

our $test6 = 1;
eval q{ goto 'SK' ~ 'IP6'; };
$test6 = 0;
SKIP6:
#?pugs todo 'feature'
is($test6, 1, "goto expr");

is(++$phase, 6, "phase completed");

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/if.t0000664000175000017500000000774712224265625017343 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

Basic "if" tests.


=end kwid

# L

plan 29;

my $x = 'test';
if ($x eq $x) { pass('if ($x eq $x) {} works'); } else { flunk('if ($x eq $x) {} failed'); }
if ($x ne $x) { flunk('if ($x ne $x) {} failed'); } else { pass('if ($x ne $x) {} works'); }
if (1) { pass('if (1) {} works'); } else { flunk('if (1) {} failed'); }
if (0) { flunk('if (0) {} failed'); } else { pass('if (0) {} works'); }
if (Mu) { flunk('if (Mu) {} failed'); } else { pass('if (Mu) {} works'); }

{
    # die called in the condition part of an if statement should die immediately
    # rather than being evaluated as true
    my $foo = 1;
    try { if (die "should die") { $foo = 3 } else { $foo = 2; } };
    #say '# $foo = ' ~ $foo;
    is $foo, 1, "die should stop execution immediately.";
}

{
    my $foo = 1; # just in case
    if 1 > 2 { $foo = 2 } else { $foo = 3 };
    is $foo, 3, 'if with no parens';
};

# if...elsif
{
    my $foo = 1;
    if (1) { $foo = 2 } elsif (1) { $foo = 3 };
    is $foo, 2, 'if (1) {} elsif (1) {}';
}

{
    my $foo = 1;
    if (1) { $foo = 2 } elsif (0) { $foo = 3 };
    is $foo, 2, 'if (1) {} elsif (0) {}';
}

{
    my $foo = 1;
    if (0) { $foo = 2 } elsif (1) { $foo = 3 };
    is $foo, 3, 'if (0) {} elsif (1) {}';
}

{
    my $foo = 1;
    if (0) { $foo = 2 } elsif (0) { $foo = 3 };
    is $foo, 1, 'if (0) {} elsif (0) {}';
}


# if...elsif...else

{
    my $foo = 1;
    if (0) { $foo = 2 } elsif (0) { $foo = 3 } else { $foo = 4 };
    is $foo, 4;
}

{
    my $foo = 1;
    if (1) { $foo = 2 } elsif (0) { $foo = 3 } else { $foo = 4 };
    is $foo, 2;
}

{
    my $foo = 1;
    if (1) { $foo = 2 } elsif (1) { $foo = 3 } else { $foo = 4 };
    is $foo, 2;
}

{
    my $foo = 1;
    if (0) { $foo = 2 } elsif (1) { $foo = 3 } else { $foo = 4 };
    is $foo, 3;
}

{
    my $foo = 1;
    if ({ 1 > 0 }) { $foo = 2 } else { $foo = 3 };
    is $foo, 2, 'if with parens, and closure as cond';
}

{
    my $var = 9;
    my sub func( $a, $b, $c ) { $var };    #OK not used
    if func 1, 2, 3 { $var = 4 } else { $var = 5 };
    is $var, 4, 'if with no parens, and call a function without parenthesis';
}

# I'm not sure where this should go

{
    my $flag = 0;
    if ( my $x = 2 ) == 2 { $flag = $x }
    is($flag, 2, "'my' variable within 'if' conditional");
}

{
    eval_dies_ok('if 1; 2', '"if" requires a block');
}

# L
#?pugs skip 'Cannot bind to non-existing variable: "$a"'
{
    my ($got, $a_val, $b_val);
    my sub testa { $a_val };
    my sub testb { $b_val };

    $a_val = 'truea';
    $b_val = 0;
    if    testa() -> $a { $got = $a }
    elsif testb() -> $b { $got = $b }
    else          -> $c { $got = $c }
    is $got, 'truea', 'if test() -> $a { } binding';

    $a_val = 0;
    $b_val = 'trueb';
    if    testa() -> $a { $got = $a }
    elsif testb() -> $b { $got = $b }
    else          -> $c { $got = $c }
    is $got, 'trueb', 'elsif test() -> $b { } binding';

    $a_val = '';
    $b_val = 0;
    if    testa() -> $a { $got = $a }
    elsif testb() -> $b { $got = $b }
    else          -> $c { $got = $c }
    is $got, 0, 'else -> $c { } binding previous elsif';

    $a_val = '';
    $b_val = 0;
    if    testa() -> $a { $got = $a }
    else          -> $c { $got = $c }
    is $got, '', 'else -> $c { } binding previous if';
}

{
    my $called = 0;
    sub cond($when) {
        is $called,$when,"condition is checked in correct order";
        $called++;
        0;
    }
    if cond(0) {
    } elsif cond(1) {
    } elsif cond(2) {
    }
    is $called,3,"all conditions are checked";
}


# L
#?pugs todo
eval_dies_ok('if($x > 1) {}','keyword needs at least one whitespace after it');

# RT #76174
# scoping of $_ in 'if' shouldn't break aliasing
{
    my @a = 0, 1, 2;
    for @a { if $_ { $_++ } };
    is ~@a, '0 2 3', '"if" does not break lexical aliasing of $_'
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/last.t0000664000175000017500000000336712224265625017702 0ustar  moritzmoritzuse v6;

use Test;

# L

=begin description

last
last if ;
 and last;
last ;
            @conf($x);
        }
        ok 'A' ceq 1,       'infix: picked up lifted prefix:<~> (+)';
        ok !('A' ceq 2),    'infix: picked up lifted prefix:<~> (-)';
    }

    # default operations: no user defined ~ and eq or ceq
    ok 'a' ceq 'a',     'basic operation (+)';
    ok !('a' ceq 'b'),  'basic operation (-)';
    # with coercion
    ok '1' ceq 1,       'basic operation with coercion (+)';
    ok !('1' ceq 2),    'basic operation with coercion (-)';
}

#?rakudo skip "lift NYI"
{
    # I hope I understood this part of specs correctly: 
    # L statement prefix/"Everything else within a lift">
    # etc.
    # IMHO that means that it's OK to use undeclared variables in a lift:
    sub f { lift $a + $b };
    {
        my $a is dynamic = 3;
        my $b is dynamic = 4;
        is f(), 7, 'Can pick up context variables from the caller';
    }
    eval_dies_ok 'f()',
        'It is an error if the lifted variables are not declared in the caller';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/loop.t0000664000175000017500000000413512224265625017702 0ustar  moritzmoritzuse v6;

use Test;

# L

=begin kwid

loop statement tests


=end kwid

plan 15;

# basic loop

{
    my $i = 0;
    is($i, 0, 'verify our starting condition');
    loop ($i = 0; $i < 10; $i++) {}
    is($i, 10, 'verify our ending condition');
}

# loop with last
{
    my $i = 0;
    is($i, 0, 'verify our starting condition');
    loop ($i = 0; $i < 10; $i++) {
        if $i == 5 { 
            last;
        }
    }
    is($i, 5, 'verify our ending condition');
}

# infinite loop

{
    my $i = 0;
    is($i, 0, 'verify our starting condition');
    loop (;;) { $i++; last; }
    is($i, 1, 'verify our ending condition');
}

# declare variable $j inside loop
{
    my $count  = 0;
    is($count, 0, 'verify our starting condition');
    loop (my $j = 0; $j < 10; $j++) { $count++; };
    is($count, 10, 'verify our ending condition');
}

# Ensure condition is tested on the first iteration
{
    my $never_did_body = 1;
    loop (;0;)
    {
        $never_did_body = 0;
    }
    ok($never_did_body, "loop with an initially-false condition executes 0 times");
}

# Loop with next should still execute the continue expression
{
    my $i;
    my $continued;
    loop ($i = 0;; $continued = 1)
    {
        last if $i;
        $i++;
        next;
    }
    ok($continued, "next performs a loop's continue expression");
}

{
    my $loopvar = 0;

    loop {
        last if ++$loopvar == 3;
    }
    is($loopvar, 3, "bare loop exited after 3 iterations");
}

{
    my $rt65962 = 'did not loop';
    
    loop ( my $a = 1, my $b = 2; $a < 5; $a++, $b++ ) {
        $rt65962 = "$a $b";
    }

    is $rt65962, '4 5', 'loop with two variables in init works';
}

# RT #71466
eval_lives_ok('class A { has $!to; method x { loop { (:$!to); } } };', 'pair colon syntax in a loop refers to an attribute works');

# RT #63760
eval_dies_ok 'loop { say "# RT63760"; last } while 1',
             '"loop {} while" is a syntax error (RT 63760)';

# RT #112654
#?rakudo.jvm skip 'unwind'
{
    my @a = gather loop { take 1; take 2; last };
    is @a.join, '12', 'gather, take and loop work together';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/map-and-sort-in-for.t0000664000175000017500000000150612224265625022422 0ustar  moritzmoritzuse v6;

use Test;

# L statement>
# L
# L

plan 4;

# works
{
  my @array = <1 2 3 4>;
  my $output='';

  for (map { 1 }, @array) -> $elem {
    $output ~= "$elem,";
  }

  is $output, "1,1,1,1,", "map works in for";
}

# works, too
{
  my @array = <1 2 3 4>;
  my $output='';

  for sort @array -> $elem {
    $output ~= "$elem,";
  }

  is $output, "1,2,3,4,", "sort works in for";
}

{
  my @array = <1 2 3 4>;
  my $output='';

  for (map { 1 }, sort @array) -> $elem {
    $output ~= "$elem,";
  }

  is $output, "1,1,1,1,", "map and sort work in for";
}

{
  my @array = <1 2 3 4>;
  my $output='';

  for (map { $_ * 2 }, sort @array) -> $elem {
    $output ~= "$elem,";
  }

  is $output, "2,4,6,8,", "map and sort work in for";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/next.t0000664000175000017500000000550412224265625017710 0ustar  moritzmoritzuse v6;

use Test;

# L

=begin pod
next
next if ;
 and next;
next ,     3, '%hash = try {...} worked (9)';
}

# return inside try{}-blocks
# PIL2JS *seems* to work, but it does not, actually:
# The "return 42" works without problems, and the caller actually sees the
# return value 42. But when the end of the test is reached, &try will
# **resume after the return**, effectively running the tests twice.
# (Therefore I moved the tests to the end, so not all tests are rerun).

{
    my $was_in_foo = 0;
    sub foo {
        $was_in_foo++;
        try { return 42 };
        $was_in_foo++;
        return 23;
    }
    is foo(), 42,      'return() inside try{}-blocks works (1)';
    is $was_in_foo, 1, 'return() inside try{}-blocks works (2)';
}

{
    sub test1 {
        try { return 42 };
        return 23;
    }

    sub test2 {
        test1();
        die 42;
    }

    dies_ok { test2() },
        'return() inside a try{}-block should cause following exceptions to really die';
}

{
    sub argcount { return +@_ }
    is argcount( try { 17 }, 23, 99 ), 3, 'try gets a block, nothing more';
}

#?pugs todo
{
    my $catches = 0;
    try {
        try {
            die 'catch!';
            CATCH {
                die 'caught' if ! $catches++;
            }
        }
    }
    is $catches, 1, 'CATCH does not catch exceptions thrown within it';
}

# RT #68728
#?pugs todo
#?rakudo.jvm skip "Method 'substr' not found"
{
    my $str = '';
    try {
        ().abc;
        CATCH {
            default {
                $str ~= 'A';
                if 'foo' ~~ /foo/ {
                    $str ~= 'B';
                    $str ~= $/;
                }
            }
        }
    }
    is $str, 'ABfoo', 'block including if structure and printing $/ ok';
}

#?niecza skip 'new exception stuff'
#?pugs skip '{obj:MyPayload}'
{
    class MyPayload {
        method Str() { 'something exceptional' }
    };
    my $p = MyPayload.new;
    try die $p;
    isa_ok $!, X::AdHoc, 'die($non-exception) creates an X::AdHoc';
    ok $!.payload === $p, '$!.payload is the argument to &die';
    is $!.Str, 'something exceptional', '$!.Str uses the payload';

    class MyEx is Exception {
        has $.s;
    }
    try MyEx.new(s => 'bar').throw;
    isa_ok $!, MyEx, 'Can throw subtypes of Exception and get them back';
    is $!.s, 'bar', '... and got the right object back';
}

# RT #111704
#?rakudo todo 'RT 111704'
#?pugs skip 'Missing required parameters: $_'
{
    my $x = 0;
    try { $x = $_ } given '42';
    is $x, '42', 'try block in statement-modifying contextualizer';
}
done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/unless.t0000664000175000017500000000264712224265625020250 0ustar  moritzmoritzuse v6;

use Test;

=begin kwid

Basic "unless" tests

=end kwid

plan 10;

# L

my $x = 'test';
{
    my $found = 0;
    unless $x ne $x { $found = 1; };
    ok($found, 'unless $x ne $x works');
}

{
    my $found = 1;
    unless $x eq $x { $found = 0; }
    ok($found, 'unless $x eq $x is not executed');
}

{
    my $found = 0;
    unless 0 { $found = 1; }
    ok($found, 'unless 0 is executed');
}

{
    my $found = 1;
    unless 1 { $found = 0; }
    ok($found, 'unless 1 is not executed');
}

{
    my $found = 0;
    unless Mu { $found = 1; }
    ok($found, 'unless undefined is executed');
}

# with parentheses
{
    my $found = 0;
    unless ($x ne $x) { $found = 1; };
    ok($found, 'unless ($x ne $x) works');
}

{
    my $found = 1;
    unless (5+2) { $found = 0; }
    ok($found, 'unless (5+2) is not executer');
}

# die called in the condition part of an if statement should die immediately
# rather than being evaluated as a boolean
my $foo = 1;
try { unless (die "should die") { $foo = 3 }};
#say '# $foo = ' ~ $foo;
is $foo, 1, "die should stop execution immediately.";

# L

eval_dies_ok( 
        ' unless 1 { 2 } else { 3 } ',
        'no else allowed in unless');
eval_dies_ok( 
        ' unless 1 { 2 } elsif 4 { 3 } ', 
        'no elsif allowed in unless');

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/until.t0000664000175000017500000000077212224265625020067 0ustar  moritzmoritzuse v6;
use Test;

plan 4;

# L and C statements/while statements
#   work as in 5>
{
    my $i = 0;
    until $i >= 5 { $i++; };
    is($i, 5, 'until $i >= 5 {} works');
}

{
    my $i = 0;
    until 5 <= $i { $i++; };
    is($i, 5, 'until 5 <= $i {} works');
}

# with parens
{
    my $i = 0;
    until ($i >= 5) { $i++; };
    is($i, 5, 'until ($i >= 5) {} works');
}

{
    my $i = 0;
    until (5 <= $i) { $i++; };
    is($i, 5, 'until (5 <= $i) {} works');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S04-statements/while.t0000664000175000017500000000250412224265625020037 0ustar  moritzmoritzuse v6;

# L and C statements>

use Test;

plan 9;

{
    my $i = 0;
    while $i < 5 { $i++; };
    is($i, 5, 'while $i < 5 {} works');
}

{
    my $i = 0;
    while 5 > $i { $i++; };
    is($i, 5, 'while 5 > $i {} works');
}

# with parens
{
    my $i = 0;
    while ($i < 5) { $i++; };
    is($i, 5, 'while ($i < 5) {} works');
}

{
    my $i = 0;
    while (5 > $i) { $i++; };
    is($i, 5, 'while (5 > $i) {} works');
}

# single value
{
    my $j = 0;
    while 0 { $j++; };
    is($j, 0, 'while 0 {...} works');
}

{
    my $k = 0;
    while $k { $k++; };
    is($k, 0, 'while $var {...} works');
}


#?mildew skip 1
# L statement/It is also possible to write>
# while ... -> $x {...}
#?pugs skip 'Cannot bind to non-existing variable: "$x"'
{
  my @array = 1..5;
  my $str = "";
  while @array.pop -> $x {
      $str ~= $x;
  }
  is $str, '54321', 'while ... -> $x {...} worked (1)';
}

#?mildew skip 1
#?pugs skip "Cannot 'pop' scalar"
{
  my @array = 0..5;
  my $str = "";
  while pop @array -> $x {
      $str ~= $x;
  }
  is $str, '54321', 'while ... -> $x {...} worked (2)';
}

#?mildew skip 1
# L
#?pugs todo
{
    eval_dies_ok('my $i = 1; while($i < 5) { $i++; }',
        'keyword needs at least one whitespace after it');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/alias.t0000664000175000017500000000375112224265625017302 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/named_cap.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 26;

#?pugs emit force_todo(3,6,7,9,10,11,12,15,16,17,18,19,20,21,22,23);

# L

ok("abcd" ~~ m/a  $=(..)  d/, 'Hypothetical variable capture');
is(~$/, "bc", 'Hypothetical variable captured');

my $foo;
ok("abcd" ~~ m/a  $foo=(..)  d/, 'Package variable capture');
is(~$foo, "bc", 'Package variable captured');

# L

ok("abcd" ~~ m/a  $1=(.) $0=(.) d/, 'Reverse capture');
is(~$0, "c", '$0 captured');
is(~$1, "b", '$1 captured');

# L
regex two {..}

ok("abcd" ~~ m/a  $=[]  d/, 'Compound hypothetical capture');
is(~$/, "bc", 'Implicit hypothetical variable captured');
is(~$/, "bc", 'Explicit hypothetical variable captured');

$foo = "";
ok("abcd" ~~ m/a  $foo=[]  d/, 'Mixed capture');
is(~$/, "bc", 'Implicit hypothetical variable captured');
is($foo, "bc", 'Explicit package variable captured');

ok("a cat_O_9_tails" ~~ m:s/ /, 'Standard captures' );
is(~$/, "a", 'Captured ' );
is(~$/, "cat_O_9_tails", 'Captured ' );

ok("Jon Lee" ~~ m:s/$=(<.ident>) $=()/, 'Repeated standard captures' );
is(~$/,  "Jon", 'Captured $first' );
is(~$/, "Lee", 'Captured $family' );
is(~$/,  "Lee", 'Captured ' );

ok("foo => 22" ~~ m:s/$0=(foo) '=>' (\d+) | $1=(\d+) '<=' $0=(foo) /, 'Pair match' );
is(~$0, 'foo', 'Key match' );
is(~$1, '22', 'Value match' );

ok("22 <= foo" ~~ m:s/$0=(foo) '=>' (\d+) | $1=(\d+) '<=' $0=(foo) /, 'Pair match');
is(~$0, 'foo', 'Reverse key match');
is(~$1, '22', 'Reverse value match');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/array-alias.t0000664000175000017500000000654412224265625020421 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/array_cap.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

# L

=end pod

plan 45;

#?pugs emit force_todo 1..12, 14..45;

ok("  a b\tc" ~~ m/@=( \s+ \S+ )+/, 'Named simple array capture');
is(join("|", @), "  a| b|\tc", 'Captured strings');

ok("  a b\tc" ~~ m/@=( \s+ \S+ )+ @=( \s+ \S+)+/, 'Sequential simple array capture');
is(join("|", @), "  a| b", 'First captured strings');
is(join("|", @), "\tc", 'Last captured strings');

ok("abcxyd" ~~ m/a  @=(.(.))+ d/, 'Repeated hypothetical array capture');
is("@", "c y", 'Hypothetical variable captured');
ok(%$/.keys == 1, 'No extra captures');

ok("abcd" ~~ m/a  @=(.(.))  d/, 'Hypothetical array capture');
is("@", "c", 'Hypothetical variable captured');

our @GA;
ok("abcxyd" ~~ m/a  @GA=(.(.))+  d/, 'Global array capture');
is("@GA[]", "c y", 'Global array captured');
ok(%$/.keys == 0, 'No vestigal captures');

my @foo;
ok("abcxyd" ~~ m/a  @foo=(.(.))+  d/, 'Package array capture');
is("@foo[]", "c y", 'Package array captured');

regex two {..}

ok("abcd" ~~ m/a  @=()  d/, 'Compound hypothetical capture');
{
  my $ret;
  lives_ok { $ret = $/[0] }, 'Implicit hypothetical variable captured -- lives_ok';
  is $ret, "bc", 'Implicit hypothetical variable captured -- retval is correct';
}
ok(! eval('@'), 'Explicit hypothetical variable not captured');

ok("  a b\tc" ~~ m/@=( @=[\s+] (\S+))+/, 'Nested array capture');
is("@", "a b c", 'Outer array capture');
is(join("|", @), "  | |\t", 'Inner array capture');

regex spaces { @=[(\s+)] }

ok("  a b\tc" ~~ m/@=(  (\S+))+/, 'Subrule array capture');

is("@", "a b c", 'Outer rule array capture');
is($, "\t", 'Final subrule array capture');

ok("  a b\tc" ~~ m/@=( @=[] (\S+))+/, 'Nested subrule array capture');
is("@", "a b c", 'Outer rule nested array capture');
is(join("|", @), "  | |\t", 'Subrule array capture');


ok("  a b\tc" ~~ m/@=[ () (\S+)]+/, 'Nested multiple array capture');
ok($ ~~ Positional, 'Multiple capture to nested array');
ok(@ == 3, 'Multiple capture count');
is(WHAT($[0]).gist, "(Match)", 'Multiple capture to nested AoA[0]');
is(WHAT($[1]).gist, "(Match)", 'Multiple capture to nested AoA[2]');
is(WHAT($[2]).gist, "(Match)", 'Multiple capture to nested AoA[3]');
is(~$[0][0], "  ", 'Multiple capture value of nested AoA[0][0]');
is(~$[0][1], "a", 'Multiple capture value of nested AoA[0][1]');
is(~$[1][0], " ", 'Multiple capture value of nested AoA[1][0]');
is(~$[1][1], "b", 'Multiple capture value of nested AoA[1][1]');
is(~$[2][0], "\t", 'Multiple capture value of nested AoA[2][0]');
is(~$[2][1], "c", 'Multiple capture value of nested AoA[2][1]');


my @bases = ();
ok("GATTACA" ~~ m/ @bases=(A|C|G|T)+ /, 'All your bases...');
is("@bases", "G A T T A C A", '...are belong to us');

@bases = ();
ok("GATTACA" ~~ m/ @bases=(A|C|G|T)**{4} (@bases+) /, 'Array reinterpolation');
is("@bases[]", "G A T T", '...are belong to...');
is("$0", "A", '...A');


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/caps.t0000664000175000017500000000665112224265625017141 0ustar  moritzmoritzuse v6;
use Test;
plan 42;

# L

sub ca(@x) {
    join '|', gather {
        for @x -> $p {
            take $p.key ~ ':' ~ $p.value;
        }
    }
}

ok 'a b c d' ~~ /(.*)/, 'basic sanity';
ok $/.caps ~~ Positional, '$/.caps returns something Positional';
#?rakudo todo 'return type of .chunks'
isa_ok $/.chunks,     Positional, '$/.chunks returns something Positional';
isa_ok $/.caps.[0],   Pair, '.. and the items are Pairs (caps);';
isa_ok $/.chunks.[0], Pair, '.. and the items are Pairs (chunks);';
isa_ok $/.caps.[0].value,   Match, '.. and the values are Matches (caps);';
isa_ok $/.chunks.[0].value, Match, '.. and the values are Matches (chunks);';

is ca($/.caps),     '0:a b c d', '$/.caps is one item for (.*)';
is ca($/.chunks),   '0:a b c d', '$/.chunks is one item for (.*)';

my token wc { \w };

ok 'a b c' ~~ /:s  (\w)  /, 'regex matches';
is ca($/.caps), 'wc:a|0:b|wc:c', 'named and positional captures mix correctly';
is ca($/.chunks), 'wc:a|~: |0:b|~: |wc:c',
                  'named and positional captures mix correctly (chunks)';

ok 'a b c d' ~~ /[(\w) \s*]+/, 'regex matches';
is ca($/.caps), '0:a|0:b|0:c|0:d', '[(\w)* \s*]+ flattens (...)* for .caps';
is ca($/.chunks), '0:a|~: |0:b|~: |0:c|~: |0:d',
                '[(\w)* \s*]+ flattens (...)* for .chunks';

ok 'a b c' ~~ /[ (\S) \s ] ** 2 (\S)/, 'regex matches';
is ca($/.caps), '0:a|0:b|1:c', '.caps distinguishes quantified () and multiple ()';
is ca($/.chunks), '0:a|~: |0:b|~: |1:c', '.chunks distinguishes quantified () and multiple ()';

ok 'a b c d' ~~ /:s [(\w)  ]+/, 'regex matches';
#'RT 75484 (fails randomly) (noauto)'
is ca($/.caps), '0:a|wc:b|0:c|wc:d',
                      'mixed named/positional flattening with quantifiers';
is ca($/.chunks), '0:a|~: |wc:b|~: |0:c|~: |wc:d',
                      'mixed named/positional flattening with quantifiers';

# .caps and .chunks on submatches

ok '  abcdef' ~~ m/.*?(a(.).)/, 'Regex matches';
is ca($0.caps),     '0:b',      '.caps on submatches';
is ca($0.chunks),   '~:a|0:b|~:c',  '.chunks on submatches';

# RT117831 separator captures
ok 'a;b,c,' ~~ m/(<.alpha>) +% (<.punct>)/, 'Regex matches';
is ca($/.caps),     '0:a|1:;|0:b|1:,|0:c',  '.caps on % separator';
is ca($/.chunks),   '0:a|1:;|0:b|1:,|0:c',  '.chunks on % separator';

ok 'a;b,c,' ~~ m/(<.alpha>) +%% (<.punct>)/, 'Regex matches';
is ca($/.caps),     '0:a|1:;|0:b|1:,|0:c|1:,',      '.caps on %% separator';
is ca($/.chunks),   '0:a|1:;|0:b|1:,|0:c|1:,',  '.chunks on %% separator';

#?niecza skip 'conjunctive regex terms - nyi'
{
    ok 'a' ~~ m/a && /, 'Regex matches';
    is ca($/.caps),     'alpha:a',  '.caps && - first term';

    ok 'a' ~~ m/ && a/,  'Regex matches';
    is ca($/.caps),     'alpha:a',  '.caps && - last term';

    ok 'a' ~~ m/ & /,  'Regex matches';
#?rakudo.jvm todo '& caps on jvm'
    is ca($/.caps),     'alpha:a|ident:a',  '.caps & - multiple terms';

    ok 'a' ~~ m/ && /,  'Regex matches';
#?rakudo.jvm todo '&& caps on jvm'
    is ca($/.caps),     'alpha:a|ident:a',  '.caps && - multiple terms';

    ok 'ab' ~~ m/([a|b] && )**1..2/,  'Regex matches';
    is ca($/.caps),     '0:a|0:b',    '.caps on quantified &&';

    ok 'ab' ~~ m/[[a|b] && ]**1..2/,  'Regex matches';
#?rakudo todo 'RT117995 - quantified conjunctive capture'
    is ca($/.caps),     'alpha:a|alpha:b',    '.caps on quantified &&';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/dot.t0000664000175000017500000000717512224265625017003 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/capture.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

# L

Broken:
## L >>)/A leading C<.> causes>
=end pod

plan 61;

my regex dotdot { (.)(.) };

ok("zzzabcdefzzz" ~~ m/(a.)<.dotdot>(..)/, 'Match');
ok($/, 'Matched');
is(~$/, "abcdef", 'Captured');
is(~$/[0], 'ab', '$/[0]');
is(~$0, 'ab', '$0');
is(~$/[1], 'ef', '$/[1]');
is(~$1, 'ef', '$1');
ok(!defined($/[2]), 'no $/[2]');
ok(!defined($2), 'no $2');
ok(!defined($/), 'no $/');

ok("zzzabcdefzzz" ~~ m/(a.)(..)/, 'Match');
ok($/, 'Matched');
is(~$/, "abcdef", 'Captured');
is(~$/[0], 'ab', '$/[0]');
is(~$0, 'ab', '$0');
is(~$/[1], 'ef', '$/[1]');
is(~$1, 'ef', '$1');
ok(!defined($/[2]), '$/[2]');
ok(!defined($2), '$2');
is(~$/, 'cd', '$/');
is(~$/[0], 'c', '$/[0]');

is(~$/[1], 'd', '$/[1]');

ok(!defined(try { $/[2] }), '$/[2]');

ok("abcd" ~~ m/(a(b(c))(d))/, 'Nested captured');
is(~$0, "abcd", 'Nested $0');
is(~$0[0], "bc", 'Nested $1');
is(~$0[0][0], "c", 'Nested $2');
is(~$0[1], "d", 'Nested $3');

# L

ok("bookkeeper" ~~ m/(((\w)$0)+)/, 'Backreference');
is(~$0, 'ookkee', 'Captured');
#?rakudo todo 'really? :-)'
is(~$0[0], 'ee', 'Captured');

# L

my regex single { o | k | e };

#?rakudo 3 todo 'dubious test'
ok("bookkeeper" ~~ m/ ($)/, 'Named backref');
is(~$/, 'o', 'Named capture');
is(~$0, 'o', 'Backref capture');

#?rakudo 3 todo 'dubious test'
ok("bookkeeper" ~~ m/(<.single>) ($0)/, 'Positional backref');
is(~$0, 'o', 'Named capture');
is(~$1, 'o', 'Backref capture');

ok(!( "bokeper" ~~ m/(<.single>) ($0)/ ), 'Failed positional backref');
# XXX wtf?
ok !( "bokeper" ~~ m/ ($)/ ) , 'Failed named backref';

is("\$0", '$'~'0', 'Non-translation of non-interpolated "\\$0"');
is('$0',  '$'~'0', 'Non-translation of non-interpolated \'$0\'');
is(q{$0}, '$'~'0', 'Non-translation of non-interpolated q{$0}');
is(q[$0], '$'~'0', 'Non-translation of non-interpolated q[$0]');
is(q<$0>, '$'~'0', 'Non-translation of non-interpolated q<$0>');
is(q/$0/, '$'~'0', 'Non-translation of non-interpolated q/$0/');
is(q!$0!, '$'~'0', 'Non-translation of non-interpolated q!$0!');
is(q|$0|, '$'~'0', 'Non-translation of non-interpolated q|$0|');

# L 

grammar English { regex name { john } }
grammar French  { regex name { jean } }
grammar Russian { regex name { ivan } }

ok("john" ~~ m/<.English::name> | <.French::name> | <.Russian::name>/, 'English name');
is(~$/, "john", 'Match is john');
ok($/ ne "jean", "Match isn't jean");
#?rakudo todo 'needs review'
is(~$/, "john", 'Name is john');

ok("jean" ~~ m/<.English::name> | <.French::name> | <.Russian::name>/, 'French name');
is(~$/, "jean", 'Match is jean');
#?rakudo todo 'needs review'
is(~$/, "jean", 'Name is jean');

ok("ivan" ~~ m/<.English::name> | <.French::name> | <.Russian::name>/, 'Russian name');
is(~$/, "ivan", 'Match is ivan');
#?rakudo todo 'needs review'
is(~$/, "ivan", 'Name is ivan');

my regex name { <.English::name> | <.French::name> | <.Russian::name> }
 
ok("john" ~~ m//, 'English metaname');
is(~$/, "john", 'Metaname match is john');
ok(~$/ ne "jean", "Metaname match isn't jean");
is(~$/, "john", 'Metaname is john');


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/external-aliasing.t0000664000175000017500000000234412224265625021615 0ustar  moritzmoritzuse v6;
use Test;

plan 16;

# L

my $x;
our $y;

ok 'ab cd ef' ~~ m/:s  $x= $y=/, 
   'regex matched';
isa_ok $x, Match, 'stored a match object in outer lexical var';
isa_ok $y, Match, 'stored a match object in outer package var';
isa_ok $, Match, '... the normal capture also is a Match object';
is ~$, 'ab', 'normal match object still works';
is ~$x, 'cd', 'outer lexical var got the right value';
is ~$y, 'ef', 'outer package var got the right value';

# this is a bit guesswork here on how outer vars interact with .caps and
# .chunks. It seems sane to assume that .caps will ignore those parts that
# are bound to external variables (since it knows nothing about them)

is +$/.caps, 'one capture';
is ~$/.caps.[0].value, 'ab', 'right value in .caps';
is +$/.chunks, 2, 'two chunks';
is $/.chunks.map({.key}).join('|'), 'ident|~', 'right keys of .chunks';
is $/.chunks.map({.value}).join('|'), 'ab| cd ef', 'right values of .chunks';

{
    my @a;
    ok 'abc' ~~ m/@a=(.)+/, 'regex with outer array matches';
    is +@a, 3, 'bound the right number of matches';
    ok ?(all(@a) ~~ Match), 'All of them are Match objects';
    is @a.join('|'), 'a|b|c', 'right values';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/hash.t0000664000175000017500000001627412224265625017140 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/hash_cap.t.

=end pod

plan 116;

#?pugs emit force_todo(1..49,51..99,101..108,111..116);

# L

ok("  a b\tc" ~~ m/%=( \s+ \S+ )/, 'Named unrepeated hash capture');
ok($/{'  a'}:exists, 'One key captured');
ok(!defined($/{'  a'}), 'One value undefined');
ok($/.keys == 1, 'No extra unrepeated captures');

ok("  a b\tc" ~~ m/%=( \s+ \S+ )+/, 'Named simple hash capture');
ok($/{'  a'}:exists, 'First simple key captured');
ok(!defined($/{'  a'}), 'First simple value undefined');
ok($/{' b'}:exists, 'Second simple key captured');
ok(!defined($/{' b'}), 'Second simple value undefined');
ok($/{"\tc"}:exists, 'Third simple key captured');
ok(!defined($/{"\tc"}), 'Third simple value undefined');
ok($/.keys == 3, 'No extra simple captures');

ok("  a b\tc" ~~ m/%=( \s+ \S+ )+ %=( \s+ \S+)+/, 'Sequential simple hash capture');
ok($/{'  a'}:exists, 'First sequential key captured');
ok(!defined($/{'  a'}), 'First sequential value undefined');
ok($/{' b'}:exists, 'Second sequential key captured');
ok(!defined($/{' b'}), 'Second sequential value undefined');
ok($/{"\tc"}:exists, 'Third sequential key captured');
ok(!defined($/{"\tc"}), 'Third sequential value undefined');
ok($/.keys == 2, 'No extra first sequential captures');
ok($/.keys == 1, 'No extra last sequential captures');

ok("abcxyd" ~~ m/a  %=(.(.))+ d/, 'Repeated nested hash capture');
ok($/{'c'}:exists, 'Nested key 1 captured');
ok(!defined($/), 'No nested value 1 captured');
ok($/{'y'}:exists, 'Nested key 2 captured');
ok(!defined($/), 'No nested value 2 captured');
ok($/.keys == 2, 'No extra nested captures');

ok("abcd" ~~ m/a  %=(.(.))  d/, 'Unrepeated nested hash capture');
ok($/{'c'}:exists, 'Unrepeated key captured');
ok(!defined($/), 'Unrepeated value not captured');
ok($/.keys == 1, 'No extra unrepeated nested captures');

ok("abcd" ~~ m/a  %=((.)(.))  d/, 'Unrepeated nested hash multicapture');
ok($/{'b'}:exists, 'Unrepeated key multicaptured');
ok(~$/, 'c', 'Unrepeated value not multicaptured');
ok($/.keys == 1, 'No extra unrepeated nested multicaptures');

ok("abcxyd" ~~ m/a  %=((.)(.))+ d/, 'Repeated nested hash multicapture');
ok($/{'b'}:exists, 'Nested key 1 multicaptured');
ok($/, 'c', 'Nested value 1 multicaptured');
ok($/{'x'}:exists, 'Nested key 2 multicaptured');
ok($/, 'y', 'Nested value 2 multicaptured');
ok($/.keys == 2, 'No extra nested multicaptures');

our %foo;
ok("abcxyd" ~~ m/a  %foo=(.(.))+  d/, 'Package hash capture');
ok(%foo{'c'}:exists, 'Package hash key 1 captured');
ok(!defined(%foo), 'Package hash value 1 not captured');
ok(%foo{'y'}:exists, 'Package hash key 2 captured');
ok(!defined(%foo), 'Package hash value 2 not captured');
ok(%foo.keys == 2, 'No extra package hash captures');

regex two {..}

ok("abcd" ~~ m/a  %=[]  d/, 'Compound hash capture');
is($/, "bc", 'Implicit subrule variable captured');
ok($/.keys == 0, 'Explicit hash variable not captured');

ok("  a b\tc" ~~ m/%=( %=[\s+] (\S+))+/, 'Nested multihash capture');
ok($/{'a'}:exists, 'Outer hash capture key 1');
ok(!defined($/), 'Outer hash no capture value 1');
ok($/{'b'}:exists, 'Outer hash capture key 2');
ok(!defined($/), 'Outer hash no capture value 2');
ok($/{'c'}:exists, 'Outer hash capture key 3');
ok(!defined($/), 'Outer hash no capture value 3');
ok($/.keys == 3, 'Outer hash no extra captures');

ok($/{'  '}:exists, 'Inner hash capture key 1');
ok(!defined($/{'  '}), 'Inner hash no capture value 1');
ok($/{' '}:exists, 'Inner hash capture key 2');
ok(!defined($/{' '}), 'Inner hash no capture value 2');
ok($/{"\t"}:exists, 'Inner hash capture key 3');
ok(!defined($/{"\t"}), 'Inner hash no capture value 3');
ok($/.keys == 3, 'Inner hash no extra captures');

regex spaces { @=[\s+] }

ok("  a b\tc" ~~ m/%=(  (\S+))+/, 'Subrule hash capture');

ok($/{'a'}:exists, 'Outer subrule hash capture key 1');
ok(!defined($/), 'Outer subrule hash no capture value 1');
ok($/{'b'}:exists, 'Outer subrule hash capture key 2');
ok(!defined($/), 'Outer subrule hash no capture value 2');
ok($/{'c'}:exists, 'Outer subrule hash capture key 3');
ok(!defined($/), 'Outer subrule hash no capture value 3');
ok($/.keys == 3, 'Outer subrule hash no extra captures');
is($/, "\t", 'Final subrule hash capture');


ok("  a b\tc" ~~ m/%=( %=[] (\S+))+/, 'Nested subrule hash multicapture');
ok($/{'a'}:exists, 'Outer rule nested hash key multicapture');
ok(!defined($/), 'Outer rule nested hash value multicapture');
ok($/{'b'}:exists, 'Outer rule nested hash key multicapture');
ok(!defined($/), 'Outer rule nested hash value multicapture');
ok($/{'c'}:exists, 'Outer rule nested hash key multicapture');
ok(!defined($/), 'Outer rule nested hash value multicapture');
ok($/.keys == 3, 'Outer subrule hash no extra multicaptures');

ok($/{'  '}:exists, 'Inner rule nested hash key multicapture');
ok(!defined($/{'  '}), 'Inner rule nested hash value multicapture');
ok($/{' '}:exists, 'Inner rule nested hash key multicapture');
ok(!defined($/{' '}), 'Inner rule nested hash value multicapture');
ok($/{"\t"}:exists, 'Inner rule nested hash key multicapture');
ok(!defined($/{"\t"}), 'Inner rule nested hash value multicapture');
ok($/.keys == 3, 'Inner subrule hash no extra multicaptures');

ok("  a b\tc" ~~ m/%=( () (\S+))+/, 'Nested multiple hash capture');
is($/{'  '}, 'a', 'Outer rule nested hash value multicapture');
is($/{' '},  'b', 'Outer rule nested hash value multicapture');
is($/{"\t"}, 'c', 'Outer rule nested hash value multicapture');
ok($/.keys == 3, 'Outer subrule hash no extra multicaptures');

my %bases = ();
ok("Gattaca" ~~ m:i/ %bases=(A|C|G|T)+ /, 'All your bases...');
ok(%bases{'a'}:exists, 'a key');
ok(!defined(%bases), 'No a value');
ok(%bases{'c'}:exists, 'c key');
ok(!defined(%bases), 'No c value');
ok(!%bases{'g'}:exists, 'No g key');
ok(%bases{'G'}:exists, 'G key');
ok(!defined(%bases), 'No G value');
ok(%bases{'t'}:exists, 't key');
ok(!defined(%bases), 'No t value');
ok(%bases.keys == 4, 'No other bases');

%bases = ();
my %aca = ('aca' => 1);;
ok("Gattaca" ~~ m:i/ %bases=(A|C|G|T)**{4} (%aca) /, 'Hash interpolation');
ok(%bases{'a'}:exists, 'a key');
ok(!defined(%bases), 'No a value');
ok(!%bases{'c'}:exists, 'No c key');
ok(!%bases{'g'}:exists, 'No g key');
ok(%bases{'G'}:exists, 'G key');
ok(!defined(%bases), 'No G value');
ok(%bases{'t'}:exists, 't key');
ok(!defined(%bases), 'No t value');
ok(%bases.keys == 3, 'No other bases');
is("$1", "aca", 'Trailing aca');


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/match-object.t0000664000175000017500000000325612224265625020551 0ustar  moritzmoritzuse v6;
use Test;

# this file should become the test for systematically testing
# Match objects. Exception: .caps and .chunks are tested in caps.t

plan 21;

#?pugs todo
ok 'ab12de' ~~ /\d+/,           'match successful';
is $/.WHAT.gist, Match.gist,    'got right type';
#?pugs todo
ok $/.Bool,                     '.Bool';
ok $/.defined,                  '.defined';
#?pugs todo 'Match.Str'
is $/.Str,         '12',        '.Str';
#?pugs todo
is $/.from,           2,        '.from';
#?pugs todo
is $/.to,             4,        '.to';
#?pugs skip 'Match.prematch'
is $/.prematch,    'ab',        '.prematch';
#?pugs skip 'Match.postmatch'
is $/.postmatch,   'de',        '.postmatch';
#?pugs todo
is $/.list.elems,     0,        '.list (empty)';
#?pugs skip 'Unimplemented unaryOp: hash'
is $/.hash.elems,     0,        '.hash (empty)';
#?pugs skip 'Not a keyed value'
is $/.keys.elems,     0,        '.keys (empty)';
#?pugs skip 'Not a keyed value'
is $/.values.elems,   0,        '.values (empty)';
#?pugs skip 'Not a keyed value'
is $/.pairs.elems,    0,        '.pairs (empty)';
#?pugs skip 'Not a keyed value'
is $/.kv.elems,       0,        '.kv (empty)';

nok 'abde' ~~ /\d/,             'no match';
nok $/.Bool,                    'failed match is False';
is  $/.Str,          '',        'false match stringifies to empty string';

my $c;
#?rakudo skip 'Unsupported use of $¢ variable'
#?pugs todo
ok 'abc' ~~ /.{ $c = $¢ }/,     'current match state';
#?rakudo todo 'Unsupported use of $¢ variable'
#?pugs skip 'Cursor'
is $c.WHAT.gist, Cursor.gist,   'got right type';
#?rakudo skip "No such method pos for invocant of type Any"
#?pugs skip 'Scalar.pos'
ok defined($c.pos),             '.pos';
rakudo-2013.12/t/spec/S05-capture/named.t0000664000175000017500000000415512224265625017274 0ustar  moritzmoritzuse v6;

use Test;

plan 11;

=begin pod

Testing named capture variables nested inside each other. This doesn't appear to be tested by the ported Perl6::Rules tests. That may be because it's not specified in the synopsis, but Autrijus is sure this how it ought to work.

=end pod

# At the time of writing, these fail under Win32 so they are marked as bugs
# I haven't yet run them under UNIX but I believe they will work

#L

{
  my regex fishy { (.*)shark };
  "whaleshark" ~~ m//;
  is($/[0], "whale", "named rule ordinal capture");
  is($[0], "whale", "named rule ordinal capture with abbreviated variable");
  is $/.orig, 'whaleshark', '$/.orig works';
};

#L

#?pugs todo 'named captures'
{
  my $not_really_a_mammal;
  my regex fishy2 { $ = (.*)shark };
  "whaleshark" ~~ m//;
  is($/, "whale", "named rule named capture");
  is($, "whale", "named rule named capture with abbreviated variable");
};

#L

#?rakudo skip 'assigning to match object'
#?niecza skip "Writing to readonly scalar"
{
  my regex number {
    [ $ = <&roman_numeral>  { $ = 'roman' }
    | $ = <&arabic_numeral> { $ = 'arabic' }
    ]
  };
  my regex roman_numeral  { I | II | III | IV };
  my regex arabic_numeral { 1 |  2 |  3  |  4 };
  2 ~~ m//;
  is($/, '2', 'binding subrule to new alias');
  is($/, 'roman', 'binding to alias as side-effect');
}

# RT #111286
{
    my grammar G {
        token TOP { ? $='b' }
        token a { a }
    }
    ok G.parse('ab'), 'grammar sanity';
    is $/.keys.map(~*).sort.join(', '), 'a, b', 'right keys in top level match';
    is $.elems, 0, '$ has no captures';
}

# RT #107746
{
    grammar a {
        token x { a };
        token y { z };
        rule TOP { [  ]? [c || b ] }
    };
    is ~a.parse('a b z'), 'a', 'can capture inside a || alternation even if previous capture was quantified (RT 107746)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-capture/subrule.t0000664000175000017500000000615412224265625017672 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/subrule.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 46;

# L

my regex abc {abc}

my regex once {<&abc>}

ok("abcabcabcabcd" ~~ m/<&once>/, 'Once match');
ok($/, 'Once matched');
is(~$/, "abc", 'Once matched');
ok(@($/) == 0, 'Once no array capture');
ok(%($/).keys == 0, 'Once no hash capture');


my regex rep {<&abc>**4}

ok("abcabcabcabcd" ~~ m/<&rep>/, 'Rep match');
ok($/, 'Rep matched');
is(~$/, "abcabcabcabc", 'Rep matched');
ok(@($/) == 0, 'Rep no array capture');
ok(%($/).keys == 0, 'Rep no hash capture');


my regex cap {}

ok("abcabcabcabcd" ~~ m//, 'Cap match');
ok($/, 'Cap matched');
is(~$/, "abc", 'Cap zero matched');
is(~$/, "abc", 'Cap captured');

is(~$/, "abc", 'Cap abc captured');
ok(@($/) == 0, 'Cap no array capture');
ok(%($/).keys == 1, 'Cap hash capture');

my regex repcap {**4}

ok("abcabcabcabcd" ~~ m//, 'Repcap match');
ok($/, 'Repcap matched');
is(~$/, "abcabcabcabc", 'Repcap matched');
is(~$/, "abcabcabcabc", 'Repcap captured');
is(~$/[0], "abc", 'Repcap abc zero captured');
is(~$/[1], "abc", 'Repcap abc one captured');
is(~$/[2], "abc", 'Repcap abc two captured');
is(~$/[3], "abc", 'Repcap abc three captured');
ok(@($/) == 0, 'Repcap no array capture');


my regex caprep {(<&abc>**4)}

ok("abcabcabcabcd" ~~ m//, 'Caprep match');
ok($/, 'Caprep matched');
is(~$/, "abcabcabcabc", 'Caprep matched');
is(~$/, "abcabcabcabc", 'Caprep captured');
is(~$/[0], "abcabcabcabc", 'Caprep abc one captured');

# RT #76892
{
    nok 'abc' !~~ /(.)/, 'unsuccessful non-match';
    is $0,       'b', 'failed !~~ still makes $0 available';
    is $, 'a', 'failed !~~ still makes $ available';
}

# RT #96424 
{
    ok '0' ~~ /|/, 'regex matches';
    is $.Str, '', 'Can call methods on captures from unsuccessful matches';
}

{
    my $tracker;
    ok 'abc' ~~ / { $tracker = $ } /, 'sanity';
    is $tracker.Str, 'a',
        'can use $/ and subrule capture in embeeded code block';
}

# RT #107254
{
    grammar G {
        rule TOP { ^  ? ? $ }
        token w1 { \w+ }
        token w2 { \w+ }
        token w3 { \w+ }
    }
    ok G.parse('one two three'), 'basic grammar sanity';
    is $/, 'one two three', 'matched the whole string';
    is $.map({ "[$_]" }).join(' '), '[one] [two] [three]',
        'right sub captures';

    ok G.parse('one two'), 'basic grammar sanity part two';
    is $, 'one', 'got the right sub caputre for ordinary subrule';
    is $, 'two', 'got the right sub capture for quantified subrule';
}

# RT #112148
{
    my grammar H {
        token TOP { ^[ '?'  ]? [ '#'  ]? $ };
    }
    my $m = H.parse('?5');
    ok $m, 'basic grammar sanity (grammar H)';
    is $m, '5', 'correct capture for quantified ';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/action-stubs.t0000664000175000017500000001030712253365500020575 0ustar  moritzmoritzuse v6;

use Test;

plan 22;

# L

grammar A::Test::Grammar {
    rule  TOP {   }
    token a   { 'a' \w+ }
    token b   { 'b' \w+ }
}

class An::Action1 {
    has $.in-a = 0;
    has $.in-b = 0;
    has $.calls = '';
    method a($/) {
        $!in-a++;
        $!calls ~= 'a';
    }
    method b($x) {    #OK not used
        $!in-b++;
        $!calls ~= 'b';
    }
}

ok A::Test::Grammar.parse('alpha beta'), 'basic sanity: .parse works';
my $action = An::Action1.new();
lives_ok { A::Test::Grammar.parse('alpha beta', :actions($action)) },
        'parse with :action (and no make) lives';
is $action.in-a, 1, 'first action has been called';
is $action.in-b, 1, 'second action has been called';
is $action.calls, 'ab', '... and in the right order';

# L

{
    grammar Grammar::More::Test {
        rule TOP {    }
        token a { \d+  }
        token b { \w+  }
        token c { '' }      # no action stub
    }
    class Grammar::More::Test::Actions {
        method TOP($/) {
            make [ $.ast, $.ast ];
        }
        method a($/) {
            make 3 + $/;
        }
        method b($/) {
            # the given/when is pretty pointless, but rakudo
            # used to segfault on it, so test it here
            # http://rt.perl.org/rt3/Ticket/Display.html?id=64208
            given 2 {
                when * {
                    make $/ x 3;
                }
            }
        }
        method c($/) {
            #die "don't come here";
            # There's an implicit {*} at the end now
        }
    }

    # there's no reason why we can't use the actions as class methods
    my $match = Grammar::More::Test.parse('39 b', :actions(Grammar::More::Test::Actions));
    ok $match, 'grammar matches';
    isa_ok $match.ast, Array, '$/.ast is an Array';
    ok $match.ast.[0] == 42,  'make 3 + $/ worked';
    is $match.ast.[1], 'bbb',  'make $/ x 3 worked';
}

# used to be a Rakudo regression, RT #64104
{
    grammar Math {
        token TOP { ^  $  }
        token value { \d+ }
    }
    class Actions {
        method value($/) { make 1..$/};
        method TOP($/)   { make 1 + $/};
    }
    my $match = Math.parse('234', :actions(Actions.new));
    ok $match,  'can parse with action stubs that make() regexes';
    is $match.ast, 235, 'got the right .ast';

}

# another former rakudo regression, RT #71514
{
    grammar ActionsTestGrammar {
        token TOP {
            ^ .+ $
        }
    }
    class TestActions {
        method TOP($/) {
            "a\nb".subst(/\n+/, '', :g);
            make 123;
        }
    }

    is ActionsTestGrammar.parse("ab\ncd", :actions(TestActions.new)).ast, 123,
        'Can call Str.subst in an action method without any trouble';
    # RT #78510
    isa_ok ActionsTestGrammar.parse('a', :actions(
        class { method TOP($/) { make { a => 1 } } }
    )).ast, Hash, 'Can make() a Hash';
}

# Test for a Rakudo bug revealed by 5ce8fcfe5 that (given the
# below code) set $x.ast[0] to (1, 2).
{
    grammar Grammar::Trivial {
        token TOP { a }
    };

    class Grammar::Trivial::A {
       method TOP($/) { make (1, 2) }
    };

    my $x = Grammar::Trivial.parse: 'a',
        actions => Grammar::Trivial::A.new;
    ok $x, 'Trivial grammar parsed';
    is $x.ast[0], 1, 'make(Parcel) (1)';
    is $x.ast[1], 2, 'make(Parcel) (2)';

    class MethodMake {
        method TOP($m) { $m.make('x') }
    }
    #?niecza skip 'Match.make'
    is Grammar::Trivial.parse('a', actions => MethodMake).ast,
        'x', 'can use Match.make';
}

# Scoping tests
#

my $*A;
my $*B;
my $*C;
my $*D;

# intra rule/token availability of capture variables

grammar Grammar::ScopeTests {
        rule  TOP {^$}
	token a   {     { $*A = ~$/ } }
	token b   {     { $*B = ~$ } }
	token c   {   ; True }> }
	token d   {()   { $*D = ~$0 } }
}

ok Grammar::ScopeTests.parse("wxyz"), 'scope tests parse';
#?rakudo.jvm 4 todo '$/ within rules/tokens'
is $*A, 'w', '$/ availiable';
is $*B, 'x', 'token name';
is $*C, 'y', 'token name (assertion)';
is $*D, 'z', '$0 availiable';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/example.t0000664000175000017500000000257512224265625017632 0ustar  moritzmoritzuse v6;
use Test;

plan 3;

rule schedule {  [ <talk> ]+ }

token title { '<title>' <speaker> '' }

regex ws { .*? };

token talk { ''  '' };

token speaker { \w+ };


=begin pod

Use rules from a grammar.

=end pod

my $content = '
    
    8:30
	Conferences for Beginners
Jim Brandt, brian d foy
	—
    
	
    9:00
	Opening Ceremonies
Josh McAdams
	—
    
';

is(~($content ~~ m//), 'tr', 'read token from grammar namespace');

$content = 'Exactly aosihdas
A aosidh
B aosidh
C aosidh
D';

is($content ~~ m//, '<title>Exactly', 'match token');

# XXX this can't work this way
# 'schedule' is a rule (non-backtracking) so the implicit <.ws> will always
# match zero characters. 
#?rakudo todo 'test error
is($content ~~ m//, $content, 'match rule');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/inheritance.t0000664000175000017500000000577112224265625020471 0ustar  moritzmoritzuse v6;
use Test;

plan 31;

# L

# tests namespace, inheritance and override

grammar Grammar::Foo {
    token TOP {  };
    token foo { 'foo' };
};

#?niecza skip 'Cannot dispatch to a method on Foo because it is not inherited or done by Cursor'
is(~('foo' ~~ /^$/), 'foo', 'got right match (foo)');
ok Grammar::Foo.parse('foo'), 'got the right match through .parse TOP';
ok Grammar::Foo.parse('foo', :rule), 'got the right match through .parse foo';

grammar Grammar::Bar is Grammar::Foo {
    token TOP {  };
    token bar { 'bar' };
    token any {  |  };
};

isa_ok Grammar::Foo, Grammar, 'grammar isa Grammar';
isa_ok Grammar::Bar, Grammar, 'inherited grammar still isa Grammar';
isa_ok Grammar::Bar, Grammar::Foo, 'child isa parent';

#?niecza 4 skip 'Cannot dispatch to a method on Bar because it is not inherited or done by Cursor'
is(~('bar' ~~ /^$/), 'bar', 'got right match (bar)');
is(~('foo' ~~ /^$/), 'foo', 'got right match (foo)');
is(~('foo' ~~ /^$/), 'foo', 'got right match (any)');
is(~('bar' ~~ /^$/), 'bar', 'got right match (any)');

ok Grammar::Bar.parse('foo'), 'can parse foo through .parsed and inhertied subrule';
ok Grammar::Bar.parse('bar', :rule), 'got right match (bar)';
ok Grammar::Bar.parse('foo', :rule), 'got right match (foo)';
ok Grammar::Bar.parse('bar', :rule), 'got right match (any)';
ok Grammar::Bar.parse('foo', :rule), 'got right match (any)';
nok Grammar::Bar.parse('boo', :rule), 'No match for bad input (any)';

grammar Grammar::Baz is Grammar::Bar {
    token baz { 'baz' };
    token any {  |  |  };
};

#?niecza 6 skip 'Cannot dispatch to a method on Baz because it is not inherited or done by Cursor'
is(~('baz' ~~ /^$/), 'baz', 'got right match');
is(~('foo' ~~ /^$/), 'foo', 'got right match');
is(~('bar' ~~ /^$/), 'bar', 'got right match');
is(~('foo' ~~ /^$/), 'foo', 'got right match');
is(~('bar' ~~ /^$/), 'bar', 'got right match');
is(~('baz' ~~ /^$/), 'baz', 'got right match');

ok Grammar::Baz.parse('baz', :rule), 'got right match (baz)';
ok Grammar::Baz.parse('foo', :rule), 'got right match (foo)';
ok Grammar::Baz.parse('bar', :rule), 'got right match (bar)';
ok Grammar::Baz.parse('baz', :rule), 'got right match (any)';
ok Grammar::Baz.parse('foo', :rule), 'got right match (any)';
ok Grammar::Baz.parse('bar', :rule), 'got right match (any)';
nok Grammar::Baz.parse('boo', :rule), 'No match for bad input (any)';

{
    class A { };
    grammar B is A { };
    #?rakudo todo 'automatic Grammar superclass'
    #?niecza todo 'automatic Grammar superclass'
    isa_ok B, Grammar, 'A grammar isa Grammar, even if inherting from a class';

}

is(Grammar.WHAT.gist,"(Grammar)", "Grammar.WHAT.gist = Grammar()");

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/methods.t0000664000175000017500000000126312224265625017633 0ustar  moritzmoritzuse v6;
use Test;

plan 5;

grammar WithMethod {
    rule TOP { 'lorem' | <.panic> }
    method panic { die "The sky is falling!"; }
};

dies_ok { WithMethod.parse('unrelated') },
   'Can call die() from a method within a grammar';

try { WithMethod.parse('unrelated') };
ok "$!" ~~ /'The sky is falling!'/, 'and got the exception message';

my $x = 0;
grammar WithOuterLex {
    regex TOP { x { $x = 42 } }
}
WithOuterLex.parse('xxx');
is $x, 42, 'regex in a grammar can see outer lexicals';

grammar WithAttrib {
    has Str $.sep;
}
# RT #73680
is WithAttrib.new(sep => ',').sep, ',', 'attributes work in grammars too';
isa_ok WithAttrib.new.sep, Str, 'empty attribute intilized to Str';
rakudo-2013.12/t/spec/S05-grammar/namespace.t0000664000175000017500000000227312224265625020126 0ustar  moritzmoritzuse v6;
use Test;

plan 5;

# TODO: smart match against a grammar to get a Match object 
# isn't specced and will likely change; see
#
# http://rt.perl.org/rt3/Public/Bug/Display.html?id=58676
#
# http://irclog.perlgeek.de/parrot/2008-05-31#i_322527

=begin description

S05-Grammar namespace-related tests

=end description

=begin description

check that grammar and regex namespaces don't collide, RT #58678

=end description

grammar A {
    rule TOP {\d+};
};

my regex b {\d+};

isa_ok(A.WHAT, A, 'regex defined in separate namespace from grammar');

isa_ok(&b.WHAT, Regex, 'regex defined in separate namespace from grammar');

is('1245' ~~ &b, '1245', 'Match against regex');


=begin description

check that multi-jointed namespaces work with grammars

=end description

grammar Foo::Bar {
    token foo { foo }
}
ok("foo" ~~ &Foo::Bar::foo, 'regex in a namespace callable');

grammar Grammar::Deep { token foo { 'foo' }; }
grammar GrammarShallow { token TOP {  'bar' }; }
#?niecza skip 'Cannot dispatch to a method on GrammarShallow because it is not inherited or done by Cursor'
ok('foobar' ~~ //, 'regex can call regex in nested namespace');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/parse_and_parsefile.t0000664000175000017500000000345112224265625022157 0ustar  moritzmoritzuse v6;
use Test;

plan 12;

# tests .parse and .parsefile methods on a grammar

grammar Foo {
    token TOP { \d+ };
};
grammar Bar {
    token untop { \d+ }
}

nok(~Foo.parse("abc123xyz"), ".parse method invokes TOP rule, no match");
is(~Foo.parse("123"), "123",  ".parse method invokes TOP rule, match");
dies_ok({ Bar.parse("abc123xyz") }, "dies if no TOP rule");

my $fh = open("parse_and_parsefile_test", :w);
$fh.say("abc\n123\nxyz");
$fh.close();
#?niecza skip 'Unable to resolve method parsefile in class Foo'
nok(~Foo.parsefile("parse_and_parsefile_test"), ".parsefile method invokes TOP rule, no match");
unlink("parse_and_parsefile_test");

$fh = open("parse_and_parsefile_test", :w);
$fh.say("123");
$fh.close();
#?niecza skip 'Unable to resolve method parsefile in class Foo'
is(~Foo.parsefile("parse_and_parsefile_test"), "123",  ".parsefile method invokes TOP rule, match");
dies_ok({ Bar.parsefile("parse_and_parsefile_test") }, "dies if no TOP rule");
dies_ok({ Foo.parsefile("non_existent_file") },        "dies if file not found");

unlink("parse_and_parsefile_test");

grammar A::B {
    token TOP { \d+ }
}
nok(~A::B.parse("zzz42zzz"), ".parse works with namespaced grammars, no match");
is(~A::B.parse("42"), "42", ".parse works with namespaced grammars, match");

# TODO: Check for a good error message, not just the absence of a bad one.
eval_dies_ok '::No::Such::Grammar.parse()', '.parse on missing grammar dies';

# RT #71062
{
    grammar Integer { rule TOP { x } };
    lives_ok { Integer.parse('x') }, 'can .parse grammar named "Integer"';
}

# RT #76884
{
    grammar grr {
        token TOP {
            *
        }
        token line { .* \n }
    }

    my $match = grr.parse('foo bar asd');
    is $match[0].perl, "Any", 'empty match is Any, not Null PMC access';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/polymorphism.t0000664000175000017500000000361312224265625020733 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/der_grammar.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 28;

grammar Other {
    regex abc { a (<.bee>) c }

    regex bee { b }

    regex def { d  f }

    regex eh  { e }
}

grammar Another is Other { };

grammar Yet::Another is Another {

    regex bee { B }

    regex def { D  F }
};

# Test derivation and Liskov substitutability...

ok 'abc' ~~ m/ ^ () $ /, '' ;

is(~$/, "abc", 'abc $/');
is(~$0, "abc", 'abc $0');

ok('abc' ~~ m/ () /, '');
is(~$/, "b", 'bee $/');
is(~$0, "b", 'bee $0');

ok('b' ~~ m/ () /, '');

ok('def' ~~ m/^ () $/, '()');
is(~$/, "def", 'def $/');
is(~$0, "def", 'def $0');

ok('def' ~~ m/^ <.Another::def> $/, '<.Another::def>');
is(~$/, "def", '.def $/');
ok($0 ne "def", '.def $0');


# Test rederivation and polymorphism...

ok('aBc' ~~ m/^ () $/, '');
is(~$/, "aBc", 'abc $/');
is(~$0, "aBc", 'abc $0');

ok('abc' !~~ m/ () /, 'abc ');
ok('aBc' ~~ m/ () /, 'aBc ');
is(~$/, "B", 'Yet::Another::bee $/');
is(~$0, "B", 'Yet::Another::bee $0');

ok('def' !~~ m/^ () $/, 'def ()');
ok('DeF' ~~ m/^ () $/, 'DeF ()');
is(~$/, "DeF", 'DeF $/');
is(~$0, "DeF", 'DeF $0');

ok('DeF' ~~ m/^ <.Yet::Another::def> $/, '');
is(~$/, "DeF", '.Yet::Another.def $/');


# Non-existent rules...

eval_dies_ok q{ 'abc' ~~ m/ () /  }, '';

# RT #63466
{
    eval_dies_ok q{ 'x' ~~ /  / },
            'match against No::Such::Rule dies';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/protoregex.t0000664000175000017500000001073112250462647020370 0ustar  moritzmoritzuse v6;
use Test;
plan 30;

grammar Alts {
    token TOP { ^  $ };

    proto token alt {*}
    token alt:sym {  };
    token alt:sym { 'bar' };
    token alt:sym«baz» { 'argl' };    # RT #113590
    token alt:sym«=>»  {  };     # RT #113590
}

ok (my $match = Alts.parse('foo')), 'can parse with proto regexes (1)';

is $match, 'foo', 'and matched the full string';
is $match, 'foo', 'got the right name of the capture';

is $/, 'foo', 'also works with $/';

ok Alts.parse('bar'), 'can parse with second alternative';
ok Alts.parse('argl'), 'can parse third second alternative';

ok !Alts.parse('baz'), 'does not match sym of third alternative';
ok !Alts.parse('aldkfj'), 'does not match completely unrelated string';
ok !Alts.parse(''), 'does not match empty string';

# RT #113590
ok Alts.parse('=>'), 'can parse symbol inside double-angles';


class SomeActions {
    method alt:sym($/) {
        make 'bazbaz';
    }
}

ok ($match = Alts.parse('argl', :actions(SomeActions.new))),
    'can parse with action methods';
is $match.ast, 'bazbaz', 'action method got called, make() worked';


grammar LTM {
    proto token lit       {*}
    token lit:sym    { 'foo' }
    token lit:sym { 'foobar' }
    token lit:sym   { 'foob' }
    
    proto token cclass1  {*}
    token cclass1:sym { <[0..9]> }
    token cclass1:sym { <[0..9]> '.' <[0..9]> }
    
    proto token cclass2  {*}
    token cclass2:sym { <[0..9]> '.' <[0..9]> }
    token cclass2:sym { <[0..9]> }
    
    proto token cclass3 {*}
    token cclass3:sym { \d\d }
    token cclass3:sym { 1 }
    
    proto token cclass4 {*}
    token cclass4:sym { '.' }
    token cclass4:sym { \W\W }
    
    proto token quant1  {*}
    token quant1:sym { ab? }
    token quant1:sym { a }
    
    proto token quant2  {*}
    token quant2:sym { a }
    token quant2:sym { ab+ }
    token quant2:sym { ab? }
    
    proto token quant3  {*}
    token quant3:sym { aaa }
    token quant3:sym { a* }
    
    proto token declok {*}
    token declok:sym {
        :my $x := 42;           #OK not used
        .+
    }
    token declok:sym { aa }

    proto token cap1 {*}
    token cap1:sym { (.+) }
    token cap1:sym { aa }

    proto token cap2 {*}
    token cap2:sym { $=[.+] }
    token cap2:sym { aa }

    proto token ass1 {*}
    token ass1:sym { a  .+ }
    token ass1:sym { aa }

    proto token ass2 {*}
    token ass2:sym { a  .+ }
    token ass2:sym { aa }
    
    proto token block {*}
    token block:sym { a {} .+ }
    token block:sym { aa }
}

is ~LTM.parse('foobar', :rule('lit')),  'foobar', 'LTM picks longest literal';
is ~LTM.parse('1.2', :rule('cclass1')), '1.2',    'LTM picks longest with char classes';
is ~LTM.parse('1.2', :rule('cclass2')), '1.2',    '...and it not just luck with ordering';
is ~LTM.parse('11', :rule('cclass3')),  '11',     'LTM works with things like \d';
is ~LTM.parse('..', :rule('cclass4')),  '..',     '...and negated ones like \W';
is ~LTM.parse('ab', :rule('quant1')),   'ab',     'LTM and ? quantifier';
is ~LTM.parse('abbb', :rule('quant2')), 'abbb',   'LTM, ? and + quantifiers';
is ~LTM.parse('aaaa', :rule('quant3')), 'aaaa',   'LTM and * quantifier';
is ~LTM.parse('aaa', :rule('declok')),  'aaa',    ':my declarations do not terminate LTM';
is ~LTM.parse('aaa', :rule('cap1')),    'aaa',    'Positional captures do not terminate LTM';
is ~LTM.parse('aaa', :rule('cap2')),    'aaa',    'Named captures do not terminate LTM';
is ~LTM.parse('aaa', :rule('ass1')),    'aaa',    ' does not terminate LTM';
is ~LTM.parse('aaa', :rule('ass2')),    'aaa',    ' does not terminate LTM';
#?niecza todo '#89'
is ~LTM.parse('aaa', :rule('block')),   'aa',     'However, code blocks do terminate LTM';

# RT120146
#?niecza skip "Action method assertion:sym<...> not yet implemented"
{
    grammar G {

        token nmstrt   {<[_ a..z ]>}
        token nmreg    {<[_ \- a..z 0..9]>+}
        token ident    {'-'?*}
        token num      {[\+|\-]?\d+}

        proto token term { <...> }
        token term:sym   {}
        token term:sym  {}
    }

    is ~G.parse("-42", :rule), '-42', 'num parse';
    is ~G.parse("-my_id", :rule), '-my_id', 'id parse';
    is ~G.parse("my_id", :rule), 'my_id', 'term parse';
    #?rakudo todo 'RT120146'
    is ~G.parse("-my_id", :rule), '-my_id', 'term parse, leading "-"';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/protos.t0000664000175000017500000000112312237474612017513 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# L

grammar Grammar::With::Protos {
    token TOP {
        +
    }

    proto token fred { <...> }

    token fred:sym {
         \d+
    }
    rule fred:sym {
         'boz'+
    }
}

my $m = Grammar::With::Protos.parse("foo23bar bozboz foo42");

ok($m, 'parse succeeded');
is(~$m[0], "foo23",       "Submatch 1 correct");
is(~$m[1], "bar bozboz ", "Submatch 2 correct");
is(~$m[2], "foo42",       "Submatch 3 correct");

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/signatures.t0000664000175000017500000000073312224265625020355 0ustar  moritzmoritzuse v6;

use Test;

plan 2;

# L >>)/If the first character is a colon>

grammar Grammar::With::Signatures {
    token TOP {
        
        
    }

    token fred($arg, $bar?) {    #OK not used
        | { $arg == 1 } 'bar'
        | { $arg == 2 } 'foo'
    }
}

ok(Grammar::With::Signatures.parse("barfoo"), 'barfoo matches');
ok(Grammar::With::Signatures.parse("foobar"), 'foobar doesnt match');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/std.t0000664000175000017500000000025312224265625016760 0ustar  moritzmoritzuse v6;
use Test;
need STD;

plan 1;

# test some STD methods

my $match = STD.parse('say ');
is(~$match, 'say ', '.parse works on STD');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-grammar/ws.t0000664000175000017500000000222012224265625016613 0ustar  moritzmoritzuse v6;
use Test;
plan 12;

# L
# L

# test that implicit and explicit <.ws> rules are overridable
grammar T1 {
    token   ws { 'x' };
    rule    r1 {'a' 'b'};
    regex   r2 { 'a' <.ws> 'b' };
    regex   r3 { 'a'  'b' };
}

ok 'x'   ~~ m/^$/, 'basic sanity with custom  rules';
is $/, 'x',                'correct text captured';
ok 'axb' ~~ m/^$/, 'implicit <.ws> is overridden';
nok $.defined,   'implicit <.ws> did not capture';
ok 'axb' ~~ m/^$/, 'explicit <.ws> is overridden';
nok $.defined,   'explicit <.ws> did not capture';
ok 'axb' ~~ m/^$/, 'explicit   is overridden';
is $, 'x',     'explicit   did capture';

# RT #64094
{
    ok '' ~~ /   /, 'match   against empty string';
    ok '' ~~ / ? /, 'match ? against empty string';
    #?rakudo 2 skip 'infinite loop: RT #64094 (noauto)'
    ok '' ~~ / + /, 'match + against empty string';
    ok '' ~~ / * /, 'match * against empty string';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-interpolation/lexicals.t0000664000175000017500000000114112224265625021230 0ustar  moritzmoritzuse Test;
plan 10;

my regex abc { abc }

ok 'foo abc def' ~~ / <&abc> /, '<&abc> does lexical lookup';
is ~$/, 'abc', 'matched the right part of the string';

nok $, '... and does not capture (2)';
nok $<&abc>, '... and does not capture (3)';

ok 'fooabcdef' ~~ / .  . /, ' captures lexical regex';

is ~$/, 'oabcd', 'correctly matched string';
is $, 'abc', 'correctly captured to $';

ok 'fooabcdef' ~~ / .  . /, ' captures lexical regex';

is ~$/, 'oabcd', 'correctly matched string';
is $, 'abc', 'correctly captured to $';


done;
rakudo-2013.12/t/spec/S05-interpolation/regex-in-variable.t0000664000175000017500000000706112224265625022734 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/patvar.t.

=end pod

plan 34;

# L


my $var = rx/a+b/;

my @var = (rx/a/, rx/b/, rx/c/, rx/\w/);

my %var = (a=>rx/ 4/, b=>rx/ cos/, c=>rx/ \d+/);

my $foo = "a+b";

my @foo = ("a+b", "b+c");

# SCALARS

ok(!( "a+b" ~~ m/<{$var}>/ ), 'Simple scalar match 1');
ok(!( "a+b" ~~ m/<$var>/ ),   'Simple scalar match 2');
#?pugs todo
ok("a+b" ~~ m/$foo/,          'Simple scalar match 3');
ok(!( "zzzzzza+bzzzzzz" ~~ m/<{$var}>/ ), 'Nested scalar match 1');
ok(!( "zzzzzza+bzzzzzz" ~~ m/<$var>/ ),   'Nested scalar match 2');
#?pugs todo
ok("zzzzzza+bzzzzzz" ~~ m/$foo/ ,         'Nested scalar match 3');
#?pugs todo
ok("aaaaab" ~~ m/<{$var}>/, 'Rulish scalar match 1');
#?pugs todo
ok("aaaaab" ~~ m/<$var>/,   'Rulish scalar match 2');
#?pugs todo
ok("aaaaab" ~~ m/$var/,     'Rulish scalar match 3');
#?pugs todo
ok("aaaaab" ~~ m/<{$foo}>/, 'Rulish scalar match 4');
#?pugs todo
ok("aaaaab" ~~ m/<$foo>/,   'Rulish scalar match 5');
ok(!("aaaaab" ~~ m/$foo/),  'Rulish scalar match 6');
ok(!('aaaaab' ~~ m/"$foo"/), 'Rulish scalar match 7');

# RT #61960
#?pugs todo
{
    my $a = 'a';
    ok 'a' ~~ / $a /, 'match with string as rx works';
}

# Arrays

#?pugs todo
ok("a" ~~ m/@var/, 'Simple array match (a)');
#?pugs todo
ok("b" ~~ m/@var/, 'Simple array match (b)');
#?pugs todo
ok("c" ~~ m/@var/, 'Simple array match (c)');
#?pugs todo
ok("d" ~~ m/@var/, 'Simple array match (d)');
ok(!( "!" ~~ m/@var/ ), 'Simple array match (!)');
#?pugs todo
ok("!!!!a!!!!!" ~~ m/@var/, 'Nested array match (a)');
#?pugs todo
ok("!!!!e!!!!!" ~~ m/@var/, 'Nested array match (e)');
#?pugs skip 'parsefail'
is("foo123bar" ~~ /@( rx/\d+/ )/, '123', 'Match from correct position');

#?pugs todo
ok("abca" ~~ m/^@var+$/, 'Multiple array matching');
#?niecza skip 'Cannot cast from source type to destination type.'
ok(!( "abca!" ~~ m/^@var+$/ ), 'Multiple array non-matching');

#?pugs todo
ok("a+bb+ca+b" ~~ /^@foo+$/, 'Multiple array non-compiling');
ok(!("a+bb+ca+b" ~~ /^<@foo>+$/), 'Multiple array compiling');
ok(!("aaaabbbbbcaaab" ~~ /^@foo+$/), 'Multiple array non-compiling');
#?pugs todo
ok("aaaabbbbbcaaab" ~~ /^<@foo>+$/, 'Multiple array compiling');

# L
#?pugs todo
eval_dies_ok 'm/%var/', 'cannot interpolate hashes into regexes';

# L
# This is similar to a test in S05-match/capturing-contexts.t
#?niecza skip 'Object reference not set to an instance of an object'
#?pugs skip 'boom'
{
    my $u;
    ok 'a' !~~ /$u/, 'undefined variable does not match';
    BEGIN { @*INC.push: 't/spec/packages/' }
    use Test::Util;
    #?rakudo todo 'warn on undef'
    is_run(
            q{my $u; 'a' ~~ /$u/},
            {
                status  => 0,
                out     => '',
                err     => rx/undef/,
            },
            'interpolating undefined into a regex warns'
          );
}

#?rakudo 3 skip 'instance member interpolation'
#?niecza skip "Representation P6cursor does not support attributes"
#?pugs todo
{
    my class InterpolationTest {
        has $!pattern = 'a+b';

        method run {
            ok('aaab' ~~ / $!pattern /, 'Interpolation of instance member');
            ok('aaab' ~~ / <$!pattern> /, 'Interpolation of instance member');
            ok('aaab' ~~ / "$!pattern" /, 'Interpolation of instance member');
        }
    }

    InterpolationTest.new.run;
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/charsets.t0000664000175000017500000000564312241704255017323 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

tests over character sets. currently limited to ascii.

=end pod

# L >>)/"The special named assertions include">

plan 16;

#?niecza skip 'Tests not completing under niecza'
{
    my $ascii-chars = [~] chr(0)..chr(0xFF);

    is $ascii-chars.comb(//).join(" "), "ABCDEFGHIJKLMNOPQRSTUVWXYZ _ abcdefghijklmnopqrstuvwxyz ª µ º ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö øùúûüýþÿ", 'ident chars';

    is $ascii-chars.comb(//).join, "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyzªµºÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ", 'alpha chars';

    is $ascii-chars.comb(//)>>.ord.join(","), ((9..13,32,133,160).join(",")), 'space chars';

    is $ascii-chars.comb(//).join, "0123456789", 'digit chars';

    is $ascii-chars.comb(//).join, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyzªµºÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ", 'alnum chars';

    #?rakudo.parrot todo 'blank characters'
    is $ascii-chars.comb(//)>>.ord.join(","), '9,32,160', 'blank chars';

    is $ascii-chars.comb(//)>>.ord.join(","), ((0..31, 127..159).join(",")), 'cntrl chars';

    #?rakudo.parrot todo 'lower characters'
    is $ascii-chars.comb(//).join, "abcdefghijklmnopqrstuvwxyzªµºßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ", 'lower chars';

    # unicode 6.0 reclassifies § and ¶ as punctuation characters, so actual results may vary depending on
    # on unicode version bundled with jdk, icu etc.
    #?rakudo.parrot todo 'punct characters'
    #?rakudo.jvm todo 'unicode 6.0 punct characters'
    is $ascii-chars.comb(//).join, q, 'punct chars';
    #?rakudo todo 'unicode 6.0 punct characters'
    is $ascii-chars.comb(/<:Punctuation>/).join, q, ':Punctuation chars';

    is $ascii-chars.comb(//).join, "ABCDEFGHIJKLMNOPQRSTUVWXYZÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ", 'upper chars';

    is $ascii-chars.comb(//).join, "0123456789ABCDEFabcdef", 'xdigit chars';

    is $ascii-chars.comb(/<:Letter>/).join, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzªµºÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ", 'unicode Letter chars';

    is $ascii-chars.comb(/<+ xdigit - lower >/).join, "0123456789ABCDEF", 'combined builtin classes';
    is $ascii-chars.comb(/<+ :HexDigit - :Upper >/).join, "0123456789abcdef", 'combined unicode classes';
    is $ascii-chars.comb(/<+ :HexDigit - lower >/).join, "0123456789ABCDEF", 'combined unicode and builtins';

}
rakudo-2013.12/t/spec/S05-mass/named-chars.t0000664000175000017500000015504012224265625017672 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/named_chars.t.

# L

=end pod

plan 431; 


#?pugs todo
ok("abc\x[a]def" ~~ m/\c[LINE FEED (LF)]/, 'Unanchored named LINE FEED (LF)');
#?pugs todo
ok("abc\c[LINE FEED (LF)]def" ~~ m/\x[A]/, 'Unanchored \x[A]');
#?pugs todo
ok("abc\c[LINE FEED (LF)]def" ~~ m/\o[12]/, 'Unanchored \o[12]');
#?pugs todo
ok("abc\x[a]def" ~~ m/^ abc \c[LINE FEED (LF)] def $/, 'Anchored LINE FEED (LF)');
#?pugs todo
ok("abc\x[c]def" ~~ m/\c[FORM FEED (FF)]/, 'Unanchored named FORM FEED (FF)');
#?pugs todo
ok("abc\c[FORM FEED (FF)]def" ~~ m/\x[C]/, 'Unanchored \x[C]');
#?pugs todo
ok("abc\c[FORM FEED (FF)]def" ~~ m/\o[14]/, 'Unanchored \o[14]');
#?pugs todo
ok("abc\x[c]def" ~~ m/^ abc \c[FORM FEED (FF)] def $/, 'Anchored FORM FEED (FF)');
#?pugs todo
ok("abc\x[c]\x[a]def" ~~ m/\c[FORM FEED (FF), LINE FEED (LF)]/, 'Multiple FORM FEED (FF), LINE FEED (LF)');
#?pugs todo
ok("\x[c]\x[a]" ~~ m/<[\c[FORM FEED (FF), LINE FEED (LF)]]>/, 'Charclass multiple FORM FEED (FF), LINE FEED (LF)');
ok(!( "\x[c]\x[a]" ~~ m/^ <-[\c[FORM FEED (FF), LINE FEED (LF)]]>/ ), 'Negative charclass FORM FEED (FF), LINE FEED (LF)');
#?rakudo 2 todo '\C escape'
ok(!( "\x[c]" ~~ m/^ \C[FORM FEED (FF)]/ ), 'Negative named FORM FEED (FF) nomatch');
#?pugs todo
ok("\x[a]" ~~ m/^ \C[FORM FEED (FF)]/, 'Negative named FORM FEED (FF) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[c]" ~~ m/^ <[\C[FORM FEED (FF)]]>/ ), 'Negative charclass named FORM FEED (FF) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[a]" ~~ m/^ <[\C[FORM FEED (FF)]]>/, 'Negative charclass named FORM FEED (FF) match');
ok(!( "\x[c]" ~~ m/^ \X[C]/ ), 'Negative hex \X[C] nomatch');
ok(!( "\x[c]" ~~ m/^ <[\X[C]]>/ ), 'Negative charclass hex \X[C] nomatch');
#?pugs todo
ok("\x[c]" ~~ m/^ \X[A]/, 'Negative hex \X[A] match');
#?pugs todo
ok("\x[c]" ~~ m/^ <[\X[A]]>/, 'Negative charclass hex \X[A] match');
#?pugs todo
ok("abc\x[d]def" ~~ m/\c[CARRIAGE RETURN (CR)]/, 'Unanchored named CARRIAGE RETURN (CR)');
#?pugs todo
ok("abc\c[CARRIAGE RETURN (CR)]def" ~~ m/\x[d]/, 'Unanchored \x[d]');
#?pugs todo
ok("abc\c[CARRIAGE RETURN (CR)]def" ~~ m/\o[15]/, 'Unanchored \o[15]');
#?pugs todo
ok("abc\x[d]def" ~~ m/^ abc \c[CARRIAGE RETURN (CR)] def $/, 'Anchored CARRIAGE RETURN (CR)');
#?pugs todo
ok("abc\x[d]\x[c]def" ~~ m/\c[CARRIAGE RETURN (CR), FORM FEED (FF)]/, 'Multiple CARRIAGE RETURN (CR), FORM FEED (FF)');

#?pugs todo
ok("\x[d]\x[c]" ~~ m/<[\c[CARRIAGE RETURN (CR), FORM FEED (FF)]]>/, 'Charclass multiple CARRIAGE RETURN (CR), FORM FEED (FF)');
ok(!( "\x[d]\x[c]" ~~ m/^ <-[\c[CARRIAGE RETURN (CR), FORM FEED (FF)]]>/ ), 'Negative charclass CARRIAGE RETURN (CR), FORM FEED (FF)');
#?rakudo 2 todo '\C escape'
ok(!( "\x[d]" ~~ m/^ \C[CARRIAGE RETURN (CR)]/ ), 'Negative named CARRIAGE RETURN (CR) nomatch');
#?pugs todo
ok("\x[c]" ~~ m/^ \C[CARRIAGE RETURN (CR)]/, 'Negative named CARRIAGE RETURN (CR) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[d]" ~~ m/^ <[\C[CARRIAGE RETURN (CR)]]>/ ), 'Negative charclass named CARRIAGE RETURN (CR) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[c]" ~~ m/^ <[\C[CARRIAGE RETURN (CR)]]>/, 'Negative charclass named CARRIAGE RETURN (CR) match');
ok(!( "\x[d]" ~~ m/^ \X[D]/ ), 'Negative hex \X[D] nomatch');
ok(!( "\x[d]" ~~ m/^ <[\X[D]]>/ ), 'Negative charclass hex \X[D] nomatch');
#?pugs todo
ok("\x[d]" ~~ m/^ \X[C]/, 'Negative hex \X[C] match');
#?pugs todo
ok("\x[d]" ~~ m/^ <[\X[C]]>/, 'Negative charclass hex \X[C] match');
#?pugs todo
ok("abc\x[85]def" ~~ m/\c[NEXT LINE (NEL)]/, 'Unanchored named NEXT LINE (NEL)');
#?pugs todo
ok("abc\c[NEXT LINE (NEL)]def" ~~ m/\x[85]/, 'Unanchored \x[85]');
#?pugs todo
ok("abc\c[NEXT LINE (NEL)]def" ~~ m/\o[205]/, 'Unanchored \o[205]');
#?pugs todo
ok("abc\x[85]def" ~~ m/^ abc \c[NEXT LINE (NEL)] def $/, 'Anchored NEXT LINE (NEL)');
#?pugs todo
ok("abc\x[85]\x[d]def" ~~ m/\c[NEXT LINE (NEL), CARRIAGE RETURN (CR)]/, 'Multiple NEXT LINE (NEL), CARRIAGE RETURN (CR)');
#?pugs todo
ok("\x[85]\x[d]" ~~ m/<[\c[NEXT LINE (NEL), CARRIAGE RETURN (CR)]]>/, 'Charclass multiple NEXT LINE (NEL), CARRIAGE RETURN (CR)');
ok(!( "\x[85]\x[d]" ~~ m/^ <-[\c[NEXT LINE (NEL), CARRIAGE RETURN (CR)]]>/ ), 'Negative charclass NEXT LINE (NEL), CARRIAGE RETURN (CR)');
#?rakudo 2 todo '\C escape'
ok(!( "\x[85]" ~~ m/^ \C[NEXT LINE (NEL)]/ ), 'Negative named NEXT LINE (NEL) nomatch');
#?pugs todo
ok("\x[d]" ~~ m/^ \C[NEXT LINE (NEL)]/, 'Negative named NEXT LINE (NEL) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[85]" ~~ m/^ <[\C[NEXT LINE (NEL)]]>/ ), 'Negative charclass named NEXT LINE (NEL) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[d]" ~~ m/^ <[\C[NEXT LINE (NEL)]]>/, 'Negative charclass named NEXT LINE (NEL) match');
ok(!( "\x[85]" ~~ m/^ \X[85]/ ), 'Negative hex \X[85] nomatch');
ok(!( "\x[85]" ~~ m/^ <[\X[85]]>/ ), 'Negative charclass hex \X[85] nomatch');
#?pugs todo
ok("\x[85]" ~~ m/^ \X[D]/, 'Negative hex \X[D] match');
#?pugs todo
ok("\x[85]" ~~ m/^ <[\X[D]]>/, 'Negative charclass hex \X[D] match');

#?pugs todo
ok("abc\c[LINE FEED (LF)]def" ~~ m/\c[LINE FEED (LF)]/, 'Unanchored named LINE FEED (LF)');
#?pugs todo
ok("abc\c[LINE FEED (LF)]def" ~~ m/^ abc \c[LINE FEED (LF)] def $/, 'Anchored LINE FEED (LF)');
#?pugs todo
ok("abc\c[LINE FEED (LF)]\x[85]def" ~~ m/\c[LINE FEED (LF), NEXT LINE (NEL)]/, 'Multiple LINE FEED (LF), NEXT LINE (NEL)');
#?pugs todo
ok("\c[LINE FEED (LF)]\x[85]" ~~ m/<[\c[LINE FEED (LF), NEXT LINE (NEL)]]>/, 'Charclass multiple LINE FEED (LF), NEXT LINE (NEL)');
ok(!( "\c[LINE FEED (LF)]\x[85]" ~~ m/^ <-[\c[LINE FEED (LF), NEXT LINE (NEL)]]>/ ), 'Negative charclass LINE FEED (LF), NEXT LINE (NEL)');
#?rakudo 2 todo '\C escape'
ok(!( "\c[LINE FEED (LF)]" ~~ m/^ \C[LINE FEED (LF)]/ ), 'Negative named LINE FEED (LF) nomatch');
#?pugs todo
ok("\x[85]" ~~ m/^ \C[LINE FEED (LF)]/, 'Negative named LINE FEED (LF) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[LINE FEED (LF)]" ~~ m/^ <[\C[LINE FEED (LF)]]>/ ), 'Negative charclass named LINE FEED (LF) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[85]" ~~ m/^ <[\C[LINE FEED (LF)]]>/, 'Negative charclass named LINE FEED (LF) match');
#?pugs todo
ok("abc\c[FORM FEED (FF)]def" ~~ m/\c[FORM FEED (FF)]/, 'Unanchored named FORM FEED (FF)');
#?pugs todo
ok("abc\c[FORM FEED (FF)]def" ~~ m/^ abc \c[FORM FEED (FF)] def $/, 'Anchored FORM FEED (FF)');
#?pugs todo
ok("abc\c[FORM FEED (FF)]\c[LINE FEED (LF)]def" ~~ m/\c[FORM FEED (FF), LINE FEED (LF)]/, 'Multiple FORM FEED (FF), LINE FEED (LF)');
#?pugs todo
ok("\c[FORM FEED (FF)]\c[LINE FEED (LF)]" ~~ m/<[\c[FORM FEED (FF), LINE FEED (LF)]]>/, 'Charclass multiple FORM FEED (FF), LINE FEED (LF)');
ok(!( "\c[FORM FEED (FF)]\c[LINE FEED (LF)]" ~~ m/^ <-[\c[FORM FEED (FF), LINE FEED (LF)]]>/ ), 'Negative charclass FORM FEED (FF), LINE FEED (LF)');
#?rakudo 2 todo '\C escape'
ok(!( "\c[FORM FEED (FF)]" ~~ m/^ \C[FORM FEED (FF)]/ ), 'Negative named FORM FEED (FF) nomatch');
#?pugs todo
ok("\c[LINE FEED (LF)]" ~~ m/^ \C[FORM FEED (FF)]/, 'Negative named FORM FEED (FF) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[FORM FEED (FF)]" ~~ m/^ <[\C[FORM FEED (FF)]]>/ ), 'Negative charclass named FORM FEED (FF) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[LINE FEED (LF)]" ~~ m/^ <[\C[FORM FEED (FF)]]>/, 'Negative charclass named FORM FEED (FF) match');
#?pugs todo
ok("abc\c[CARRIAGE RETURN (CR)]def" ~~ m/\c[CARRIAGE RETURN (CR)]/, 'Unanchored named CARRIAGE RETURN (CR)');
#?pugs todo
ok("abc\c[CARRIAGE RETURN (CR)]def" ~~ m/^ abc \c[CARRIAGE RETURN (CR)] def $/, 'Anchored CARRIAGE RETURN (CR)');
#?pugs todo
ok("abc\c[CARRIAGE RETURN (CR)]\c[FORM FEED (FF)]def" ~~ m/\c[CARRIAGE RETURN (CR),FORM FEED (FF)]/, 'Multiple CARRIAGE RETURN (CR),FORM FEED (FF)');

#?pugs todo
ok("\c[CARRIAGE RETURN (CR)]\c[FORM FEED (FF)]" ~~ m/<[\c[CARRIAGE RETURN (CR),FORM FEED (FF)]]>/, 'Charclass multiple CARRIAGE RETURN (CR),FORM FEED (FF)');
ok(!( "\c[CARRIAGE RETURN (CR)]\c[FORM FEED (FF)]" ~~ m/^ <-[\c[CARRIAGE RETURN (CR),FORM FEED (FF)]]>/ ), 'Negative charclass CARRIAGE RETURN (CR),FORM FEED (FF)');
#?rakudo 2 todo '\C escape'
ok(!( "\c[CARRIAGE RETURN (CR)]" ~~ m/^ \C[CARRIAGE RETURN (CR)]/ ), 'Negative named CARRIAGE RETURN (CR) nomatch');
#?pugs todo
ok("\c[FORM FEED (FF)]" ~~ m/^ \C[CARRIAGE RETURN (CR)]/, 'Negative named CARRIAGE RETURN (CR) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[CARRIAGE RETURN (CR)]" ~~ m/^ <[\C[CARRIAGE RETURN (CR)]]>/ ), 'Negative charclass named CARRIAGE RETURN (CR) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[FORM FEED (FF)]" ~~ m/^ <[\C[CARRIAGE RETURN (CR)]]>/, 'Negative charclass named CARRIAGE RETURN (CR) match');
#?pugs todo
ok("abc\c[NEXT LINE (NEL)]def" ~~ m/\c[NEXT LINE (NEL)]/, 'Unanchored named NEXT LINE (NEL)');
#?pugs todo
ok("abc\c[NEXT LINE (NEL)]def" ~~ m/^ abc \c[NEXT LINE (NEL)] def $/, 'Anchored NEXT LINE (NEL)');
#?pugs todo
ok("abc\c[NEXT LINE (NEL)]\c[CARRIAGE RETURN (CR)]def" ~~ m/\c[NEXT LINE (NEL),CARRIAGE RETURN (CR)]/, 'Multiple NEXT LINE (NEL),CARRIAGE RETURN (CR)');
#?pugs todo
ok("\c[NEXT LINE (NEL)]\c[CARRIAGE RETURN (CR)]" ~~ m/<[\c[NEXT LINE (NEL),CARRIAGE RETURN (CR)]]>/, 'Charclass multiple NEXT LINE (NEL),CARRIAGE RETURN (CR)');
ok(!( "\c[NEXT LINE (NEL)]\c[CARRIAGE RETURN (CR)]" ~~ m/^ <-[\c[NEXT LINE (NEL),CARRIAGE RETURN (CR)]]>/ ), 'Negative charclass NEXT LINE (NEL),CARRIAGE RETURN (CR)');
#?rakudo 2 todo '\C escape'
ok(!( "\c[NEXT LINE (NEL)]" ~~ m/^ \C[NEXT LINE (NEL)]/ ), 'Negative named NEXT LINE (NEL) nomatch');
#?pugs todo
ok("\c[CARRIAGE RETURN (CR)]" ~~ m/^ \C[NEXT LINE (NEL)]/, 'Negative named NEXT LINE (NEL) match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[NEXT LINE (NEL)]" ~~ m/^ <[\C[NEXT LINE (NEL)]]>/ ), 'Negative charclass named NEXT LINE (NEL) nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[CARRIAGE RETURN (CR)]" ~~ m/^ <[\C[NEXT LINE (NEL)]]>/, 'Negative charclass named NEXT LINE (NEL) match');
#?rakudo 7 skip '\c[LF] not valid charname'
#?pugs todo
ok("abc\c[LF]def" ~~ m/\c[LF]/, 'Unanchored named LF');
#?pugs todo
ok("abc\c[LF]def" ~~ m/^ abc \c[LF] def $/, 'Anchored LF');
#?pugs todo
ok("abc\c[LF]\c[NEXT LINE (NEL)]def" ~~ m/\c[LF, NEXT LINE (NEL)]/, 'Multiple LF, NEXT LINE (NEL)');
#?pugs todo
ok("\c[LF]\c[NEXT LINE (NEL)]" ~~ m/<[\c[LF, NEXT LINE (NEL)]]>/, 'Charclass multiple LF, NEXT LINE (NEL)');
#?rakudo skip 'escapes in char classes'
ok(!( "\c[LF]\c[NEXT LINE (NEL)]" ~~ m/^ <-[\c[LF, NEXT LINE (NEL)]]>/ ), 'Negative charclass LF, NEXT LINE (NEL)');
#?rakudo 2 skip 'LF as char name'
ok(!( "\c[LF]" ~~ m/^ \C[LF]/ ), 'Negative named LF nomatch');
#?pugs todo
ok("\c[NEXT LINE (NEL)]" ~~ m/^ \C[LF]/, 'Negative named LF match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[LF]" ~~ m/^ <[\C[LF]]>/ ), 'Negative charclass named LF nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[NEXT LINE (NEL)]" ~~ m/^ <[\C[LF]]>/, 'Negative charclass named LF match');
#?rakudo 7 skip '\c[FF] not valid charname'
#?pugs todo
ok("abc\c[FF]def" ~~ m/\c[FF]/, 'Unanchored named FF');
#?pugs todo
ok("abc\c[FF]def" ~~ m/^ abc \c[FF] def $/, 'Anchored FF');
#?pugs todo
ok("abc\c[FF]\c[LF]def" ~~ m/\c[FF,LF]/, 'Multiple FF,LF');
#?pugs todo
ok("\c[FF]\c[LF]" ~~ m/<[\c[FF,LF]]>/, 'Charclass multiple FF,LF');
#?rakudo skip 'escapes in char classes'
ok(!( "\c[FF]\c[LF]" ~~ m/^ <-[\c[FF,LF]]>/ ), 'Negative charclass FF,LF');

#?rakudo 2 skip 'FF as char name'
ok(!( "\c[FF]" ~~ m/^ \C[FF]/ ), 'Negative named FF nomatch');
#?pugs todo
ok("\c[LF]" ~~ m/^ \C[FF]/, 'Negative named FF match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[FF]" ~~ m/^ <[\C[FF]]>/ ), 'Negative charclass named FF nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[LF]" ~~ m/^ <[\C[FF]]>/, 'Negative charclass named FF match');
#?rakudo 7 skip '\c[CR] not valid charname'
#?pugs todo
ok("abc\c[CR]def" ~~ m/\c[CR]/, 'Unanchored named CR');
#?pugs todo
ok("abc\c[CR]def" ~~ m/^ abc \c[CR] def $/, 'Anchored CR');
#?pugs todo
ok("abc\c[CR]\c[FF]def" ~~ m/\c[CR,FF]/, 'Multiple CR,FF');
#?pugs todo
ok("\c[CR]\c[FF]" ~~ m/<[\c[CR,FF]]>/, 'Charclass multiple CR,FF');
#?rakudo skip 'escapes in char classes'
ok(!( "\c[CR]\c[FF]" ~~ m/^ <-[\c[CR,FF]]>/ ), 'Negative charclass CR,FF');
#?rakudo 2 skip 'CR as char name'
ok(!( "\c[CR]" ~~ m/^ \C[CR]/ ), 'Negative named CR nomatch');
#?pugs todo
ok("\c[FF]" ~~ m/^ \C[CR]/, 'Negative named CR match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[CR]" ~~ m/^ <[\C[CR]]>/ ), 'Negative charclass named CR nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[FF]" ~~ m/^ <[\C[CR]]>/, 'Negative charclass named CR match');
#?rakudo 7 skip '\c[NEL] not valid charname'
#?pugs todo
ok("abc\c[NEL]def" ~~ m/\c[NEL]/, 'Unanchored named NEL');
#?pugs todo
ok("abc\c[NEL]def" ~~ m/^ abc \c[NEL] def $/, 'Anchored NEL');
#?pugs todo
ok("abc\c[NEL]\c[CR]def" ~~ m/\c[NEL,CR]/, 'Multiple NEL,CR');
#?pugs todo
ok("\c[NEL]\c[CR]" ~~ m/<[\c[NEL,CR]]>/, 'Charclass multiple NEL,CR');
#?rakudo skip 'escapes in char classes'
ok(!( "\c[NEL]\c[CR]" ~~ m/^ <-[\c[NEL,CR]]>/ ), 'Negative charclass NEL,CR');
#?rakudo 2 skip 'NEL as char name'
ok(!( "\c[NEL]" ~~ m/^ \C[NEL]/ ), 'Negative named NEL nomatch');
#?pugs todo
ok("\c[CR]" ~~ m/^ \C[NEL]/, 'Negative named NEL match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\c[NEL]" ~~ m/^ <[\C[NEL]]>/ ), 'Negative charclass named NEL nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[CR]" ~~ m/^ <[\C[NEL]]>/, 'Negative charclass named NEL match');
#?pugs todo
ok("abc\x[fd55]def" ~~ m/\c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]/, 'Unanchored named ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM');
#?pugs todo
ok("abc\c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]def" ~~ m/\x[fd55]/, 'Unanchored \x[fd55]');
#?pugs todo
ok("abc\c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]def" ~~ m/\o[176525]/, 'Unanchored \o[176525]');
#?pugs todo
ok("abc\x[fd55]def" ~~ m/^ abc \c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM] def $/, 'Anchored ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM');
#?rakudo 3 skip '\c[NEL] not valid charname'
#?pugs todo
ok("abc\x[fd55]\c[NEL]def" ~~ m/\c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM,NEL]/, 'Multiple ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM,NEL');
#?pugs todo
ok("\x[fd55]\c[NEL]" ~~ m/<[\c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM,NEL]]>/, 'Charclass multiple ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM,NEL');
#?rakudo skip 'escapes in char classes'
ok(!( "\x[fd55]\c[NEL]" ~~ m/^ <-[\c[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM,NEL]]>/ ), 'Negative charclass ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM,NEL');
#?rakudo 2 todo '\C escape'
ok(!( "\x[fd55]" ~~ m/^ \C[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]/ ), 'Negative named ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM nomatch');
#?rakudo skip '\c[NEL] not valid charname'
#?pugs todo
ok("\c[NEL]" ~~ m/^ \C[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]/, 'Negative named ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[fd55]" ~~ m/^ <[\C[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]]>/ ), 'Negative charclass named ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\c[NEL]" ~~ m/^ <[\C[ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]]>/, 'Negative charclass named ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM match');

ok(!( "\x[fd55]" ~~ m/^ \X[FD55]/ ), 'Negative hex \X[FD55] nomatch');
ok(!( "\x[fd55]" ~~ m/^ <[\X[FD55]]>/ ), 'Negative charclass hex \X[FD55] nomatch');
#?pugs todo
ok("abc\x[5b4]def" ~~ m/\c[HEBREW POINT HIRIQ]/, 'Unanchored named HEBREW POINT HIRIQ');
#?pugs todo
ok("abc\c[HEBREW POINT HIRIQ]def" ~~ m/\x[5B4]/, 'Unanchored \x[5B4]');
#?pugs todo
ok("abc\c[HEBREW POINT HIRIQ]def" ~~ m/\o[2664]/, 'Unanchored \o[2664]');
#?pugs todo
ok("abc\x[5b4]def" ~~ m/^ abc \c[HEBREW POINT HIRIQ] def $/, 'Anchored HEBREW POINT HIRIQ');
#?pugs todo
ok("abc\x[5b4]\x[fd55]def" ~~ m/\c[HEBREW POINT HIRIQ,ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]/, 'Multiple HEBREW POINT HIRIQ,ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM');
#?pugs todo
ok("\x[5b4]\x[fd55]" ~~ m/<[\c[HEBREW POINT HIRIQ,ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]]>/, 'Charclass multiple HEBREW POINT HIRIQ,ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM');
ok(!( "\x[5b4]\x[fd55]" ~~ m/^ <-[\c[HEBREW POINT HIRIQ,ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM]]>/ ), 'Negative charclass HEBREW POINT HIRIQ,ARABIC LIGATURE TEH WITH MEEM WITH JEEM INITIAL FORM');
#?rakudo 2 todo '\C escape'
ok(!( "\x[5b4]" ~~ m/^ \C[HEBREW POINT HIRIQ]/ ), 'Negative named HEBREW POINT HIRIQ nomatch');
#?pugs todo
ok("\x[fd55]" ~~ m/^ \C[HEBREW POINT HIRIQ]/, 'Negative named HEBREW POINT HIRIQ match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[5b4]" ~~ m/^ <[\C[HEBREW POINT HIRIQ]]>/ ), 'Negative charclass named HEBREW POINT HIRIQ nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[fd55]" ~~ m/^ <[\C[HEBREW POINT HIRIQ]]>/, 'Negative charclass named HEBREW POINT HIRIQ match');
ok(!( "\x[5b4]" ~~ m/^ \X[5B4]/ ), 'Negative hex \X[5B4] nomatch');
ok(!( "\x[5b4]" ~~ m/^ <[\X[5B4]]>/ ), 'Negative charclass hex \X[5B4] nomatch');
#?pugs todo
ok("\x[5b4]" ~~ m/^ \X[FD55]/, 'Negative hex \X[FD55] match');
#?pugs todo
ok("\x[5b4]" ~~ m/^ <[\X[FD55]]>/, 'Negative charclass hex \X[FD55] match');
#?pugs todo
ok("abc\x[1ea2]def" ~~ m/\c[LATIN CAPITAL LETTER A WITH HOOK ABOVE]/, 'Unanchored named LATIN CAPITAL LETTER A WITH HOOK ABOVE');
#?pugs todo
ok("abc\c[LATIN CAPITAL LETTER A WITH HOOK ABOVE]def" ~~ m/\x[1EA2]/, 'Unanchored \x[1EA2]');
#?pugs todo
ok("abc\c[LATIN CAPITAL LETTER A WITH HOOK ABOVE]def" ~~ m/\o[17242]/, 'Unanchored \o[17242]');
#?pugs todo
ok("abc\x[1ea2]def" ~~ m/^ abc \c[LATIN CAPITAL LETTER A WITH HOOK ABOVE] def $/, 'Anchored LATIN CAPITAL LETTER A WITH HOOK ABOVE');
#?pugs todo
ok("abc\x[1ea2]\x[5b4]def" ~~ m/\c[LATIN CAPITAL LETTER A WITH HOOK ABOVE,HEBREW POINT HIRIQ]/, 'Multiple LATIN CAPITAL LETTER A WITH HOOK ABOVE,HEBREW POINT HIRIQ');
#?pugs todo
ok("\x[1ea2]\x[5b4]" ~~ m/<[\c[LATIN CAPITAL LETTER A WITH HOOK ABOVE,HEBREW POINT HIRIQ]]>/, 'Charclass multiple LATIN CAPITAL LETTER A WITH HOOK ABOVE,HEBREW POINT HIRIQ');
ok(!( "\x[1ea2]\x[5b4]" ~~ m/^ <-[\c[LATIN CAPITAL LETTER A WITH HOOK ABOVE,HEBREW POINT HIRIQ]]>/ ), 'Negative charclass LATIN CAPITAL LETTER A WITH HOOK ABOVE,HEBREW POINT HIRIQ');
#?rakudo 2 todo '\C escape'
ok(!( "\x[1ea2]" ~~ m/^ \C[LATIN CAPITAL LETTER A WITH HOOK ABOVE]/ ), 'Negative named LATIN CAPITAL LETTER A WITH HOOK ABOVE nomatch');
#?pugs todo
ok("\x[5b4]" ~~ m/^ \C[LATIN CAPITAL LETTER A WITH HOOK ABOVE]/, 'Negative named LATIN CAPITAL LETTER A WITH HOOK ABOVE match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[1ea2]" ~~ m/^ <[\C[LATIN CAPITAL LETTER A WITH HOOK ABOVE]]>/ ), 'Negative charclass named LATIN CAPITAL LETTER A WITH HOOK ABOVE nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[5b4]" ~~ m/^ <[\C[LATIN CAPITAL LETTER A WITH HOOK ABOVE]]>/, 'Negative charclass named LATIN CAPITAL LETTER A WITH HOOK ABOVE match');
ok(!( "\x[1ea2]" ~~ m/^ \X[1EA2]/ ), 'Negative hex \X[1EA2] nomatch');
ok(!( "\x[1ea2]" ~~ m/^ <[\X[1EA2]]>/ ), 'Negative charclass hex \X[1EA2] nomatch');
#?pugs todo
ok("\x[1ea2]" ~~ m/^ \X[5B4]/, 'Negative hex \X[5B4] match');
#?pugs todo
ok("\x[1ea2]" ~~ m/^ <[\X[5B4]]>/, 'Negative charclass hex \X[5B4] match');
#?pugs todo
ok("abc\x[565]def" ~~ m/\c[ARMENIAN SMALL LETTER ECH]/, 'Unanchored named ARMENIAN SMALL LETTER ECH');
#?pugs todo
ok("abc\c[ARMENIAN SMALL LETTER ECH]def" ~~ m/\x[565]/, 'Unanchored \x[565]');
#?pugs todo
ok("abc\c[ARMENIAN SMALL LETTER ECH]def" ~~ m/\o[2545]/, 'Unanchored \o[2545]');
#?pugs todo
ok("abc\x[565]def" ~~ m/^ abc \c[ARMENIAN SMALL LETTER ECH] def $/, 'Anchored ARMENIAN SMALL LETTER ECH');
#?pugs todo
ok("abc\x[565]\x[1ea2]def" ~~ m/\c[ARMENIAN SMALL LETTER ECH,LATIN CAPITAL LETTER A WITH HOOK ABOVE]/, 'Multiple ARMENIAN SMALL LETTER ECH,LATIN CAPITAL LETTER A WITH HOOK ABOVE');
#?pugs todo
ok("\x[565]\x[1ea2]" ~~ m/<[\c[ARMENIAN SMALL LETTER ECH,LATIN CAPITAL LETTER A WITH HOOK ABOVE]]>/, 'Charclass multiple ARMENIAN SMALL LETTER ECH,LATIN CAPITAL LETTER A WITH HOOK ABOVE');
ok(!( "\x[565]\x[1ea2]" ~~ m/^ <-[\c[ARMENIAN SMALL LETTER ECH,LATIN CAPITAL LETTER A WITH HOOK ABOVE]]>/ ), 'Negative charclass ARMENIAN SMALL LETTER ECH,LATIN CAPITAL LETTER A WITH HOOK ABOVE');
#?rakudo 2 todo '\C escape'
ok(!( "\x[565]" ~~ m/^ \C[ARMENIAN SMALL LETTER ECH]/ ), 'Negative named ARMENIAN SMALL LETTER ECH nomatch');
#?pugs todo
ok("\x[1ea2]" ~~ m/^ \C[ARMENIAN SMALL LETTER ECH]/, 'Negative named ARMENIAN SMALL LETTER ECH match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[565]" ~~ m/^ <[\C[ARMENIAN SMALL LETTER ECH]]>/ ), 'Negative charclass named ARMENIAN SMALL LETTER ECH nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[1ea2]" ~~ m/^ <[\C[ARMENIAN SMALL LETTER ECH]]>/, 'Negative charclass named ARMENIAN SMALL LETTER ECH match');
ok(!( "\x[565]" ~~ m/^ \X[565]/ ), 'Negative hex \X[565] nomatch');
ok(!( "\x[565]" ~~ m/^ <[\X[565]]>/ ), 'Negative charclass hex \X[565] nomatch');
#?pugs todo
ok("\x[565]" ~~ m/^ \X[1EA2]/, 'Negative hex \X[1EA2] match');
#?pugs todo
ok("\x[565]" ~~ m/^ <[\X[1EA2]]>/, 'Negative charclass hex \X[1EA2] match');
#?pugs todo
ok("abc\x[25db]def" ~~ m/\c[LOWER HALF INVERSE WHITE CIRCLE]/, 'Unanchored named LOWER HALF INVERSE WHITE CIRCLE');
#?pugs todo
ok("abc\c[LOWER HALF INVERSE WHITE CIRCLE]def" ~~ m/\x[25DB]/, 'Unanchored \x[25DB]');
#?pugs todo
ok("abc\c[LOWER HALF INVERSE WHITE CIRCLE]def" ~~ m/\o[22733]/, 'Unanchored \o[22733]');
#?pugs todo
ok("abc\x[25db]def" ~~ m/^ abc \c[LOWER HALF INVERSE WHITE CIRCLE] def $/, 'Anchored LOWER HALF INVERSE WHITE CIRCLE');
#?pugs todo
ok("abc\x[25db]\x[565]def" ~~ m/\c[LOWER HALF INVERSE WHITE CIRCLE,ARMENIAN SMALL LETTER ECH]/, 'Multiple LOWER HALF INVERSE WHITE CIRCLE,ARMENIAN SMALL LETTER ECH');
#?pugs todo
ok("\x[25db]\x[565]" ~~ m/<[\c[LOWER HALF INVERSE WHITE CIRCLE,ARMENIAN SMALL LETTER ECH]]>/, 'Charclass multiple LOWER HALF INVERSE WHITE CIRCLE,ARMENIAN SMALL LETTER ECH');
ok(!( "\x[25db]\x[565]" ~~ m/^ <-[\c[LOWER HALF INVERSE WHITE CIRCLE,ARMENIAN SMALL LETTER ECH]]>/ ), 'Negative charclass LOWER HALF INVERSE WHITE CIRCLE,ARMENIAN SMALL LETTER ECH');
#?rakudo 2 todo '\C escape'
ok(!( "\x[25db]" ~~ m/^ \C[LOWER HALF INVERSE WHITE CIRCLE]/ ), 'Negative named LOWER HALF INVERSE WHITE CIRCLE nomatch');
#?pugs todo
ok("\x[565]" ~~ m/^ \C[LOWER HALF INVERSE WHITE CIRCLE]/, 'Negative named LOWER HALF INVERSE WHITE CIRCLE match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[25db]" ~~ m/^ <[\C[LOWER HALF INVERSE WHITE CIRCLE]]>/ ), 'Negative charclass named LOWER HALF INVERSE WHITE CIRCLE nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[565]" ~~ m/^ <[\C[LOWER HALF INVERSE WHITE CIRCLE]]>/, 'Negative charclass named LOWER HALF INVERSE WHITE CIRCLE match');
ok(!( "\x[25db]" ~~ m/^ \X[25DB]/ ), 'Negative hex \X[25DB] nomatch');
ok(!( "\x[25db]" ~~ m/^ <[\X[25DB]]>/ ), 'Negative charclass hex \X[25DB] nomatch');
#?pugs todo
ok("\x[25db]" ~~ m/^ \X[565]/, 'Negative hex \X[565] match');
#?pugs todo
ok("\x[25db]" ~~ m/^ <[\X[565]]>/, 'Negative charclass hex \X[565] match');
#?pugs todo
ok("abc\x[fe7d]def" ~~ m/\c[ARABIC SHADDA MEDIAL FORM]/, 'Unanchored named ARABIC SHADDA MEDIAL FORM');
#?pugs todo
ok("abc\c[ARABIC SHADDA MEDIAL FORM]def" ~~ m/\x[fe7d]/, 'Unanchored \x[fe7d]');
#?pugs todo
ok("abc\c[ARABIC SHADDA MEDIAL FORM]def" ~~ m/\o[177175]/, 'Unanchored \o[177175]');
#?pugs todo
ok("abc\x[fe7d]def" ~~ m/^ abc \c[ARABIC SHADDA MEDIAL FORM] def $/, 'Anchored ARABIC SHADDA MEDIAL FORM');
#?pugs todo
ok("abc\x[fe7d]\x[25db]def" ~~ m/\c[ARABIC SHADDA MEDIAL FORM,LOWER HALF INVERSE WHITE CIRCLE]/, 'Multiple ARABIC SHADDA MEDIAL FORM,LOWER HALF INVERSE WHITE CIRCLE');
#?pugs todo
ok("\x[fe7d]\x[25db]" ~~ m/<[\c[ARABIC SHADDA MEDIAL FORM,LOWER HALF INVERSE WHITE CIRCLE]]>/, 'Charclass multiple ARABIC SHADDA MEDIAL FORM,LOWER HALF INVERSE WHITE CIRCLE');
ok(!( "\x[fe7d]\x[25db]" ~~ m/^ <-[\c[ARABIC SHADDA MEDIAL FORM,LOWER HALF INVERSE WHITE CIRCLE]]>/ ), 'Negative charclass ARABIC SHADDA MEDIAL FORM,LOWER HALF INVERSE WHITE CIRCLE');
#?rakudo 2 todo '\C escape'
ok(!( "\x[fe7d]" ~~ m/^ \C[ARABIC SHADDA MEDIAL FORM]/ ), 'Negative named ARABIC SHADDA MEDIAL FORM nomatch');
#?pugs todo
ok("\x[25db]" ~~ m/^ \C[ARABIC SHADDA MEDIAL FORM]/, 'Negative named ARABIC SHADDA MEDIAL FORM match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[fe7d]" ~~ m/^ <[\C[ARABIC SHADDA MEDIAL FORM]]>/ ), 'Negative charclass named ARABIC SHADDA MEDIAL FORM nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[25db]" ~~ m/^ <[\C[ARABIC SHADDA MEDIAL FORM]]>/, 'Negative charclass named ARABIC SHADDA MEDIAL FORM match');
ok(!( "\x[fe7d]" ~~ m/^ \X[FE7D]/ ), 'Negative hex \X[FE7D] nomatch');
ok(!( "\x[fe7d]" ~~ m/^ <[\X[FE7D]]>/ ), 'Negative charclass hex \X[FE7D] nomatch');
#?pugs todo
ok("\x[fe7d]" ~~ m/^ \X[25DB]/, 'Negative hex \X[25DB] match');
#?pugs todo
ok("\x[fe7d]" ~~ m/^ <[\X[25DB]]>/, 'Negative charclass hex \X[25DB] match');
#?pugs todo
ok("abc\x[a15d]def" ~~ m/\c[YI SYLLABLE NDO]/, 'Unanchored named YI SYLLABLE NDO');
#?pugs todo
ok("abc\c[YI SYLLABLE NDO]def" ~~ m/\x[A15D]/, 'Unanchored \x[A15D]');
#?pugs todo
ok("abc\c[YI SYLLABLE NDO]def" ~~ m/\o[120535]/, 'Unanchored \o[120535]');
#?pugs todo
ok("abc\x[a15d]def" ~~ m/^ abc \c[YI SYLLABLE NDO] def $/, 'Anchored YI SYLLABLE NDO');
#?pugs todo
ok("abc\x[a15d]\x[fe7d]def" ~~ m/\c[YI SYLLABLE NDO, ARABIC SHADDA MEDIAL FORM]/, 'Multiple YI SYLLABLE NDO, ARABIC SHADDA MEDIAL FORM');
#?pugs todo
ok("\x[a15d]\x[fe7d]" ~~ m/<[\c[YI SYLLABLE NDO, ARABIC SHADDA MEDIAL FORM]]>/, 'Charclass multiple YI SYLLABLE NDO, ARABIC SHADDA MEDIAL FORM');
ok(!( "\x[a15d]\x[fe7d]" ~~ m/^ <-[\c[YI SYLLABLE NDO, ARABIC SHADDA MEDIAL FORM]]>/ ), 'Negative charclass YI SYLLABLE NDO, ARABIC SHADDA MEDIAL FORM');
#?rakudo 2 todo '\C escape'
ok(!( "\x[a15d]" ~~ m/^ \C[YI SYLLABLE NDO]/ ), 'Negative named YI SYLLABLE NDO nomatch');
#?pugs todo
ok("\x[fe7d]" ~~ m/^ \C[YI SYLLABLE NDO]/, 'Negative named YI SYLLABLE NDO match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[a15d]" ~~ m/^ <[\C[YI SYLLABLE NDO]]>/ ), 'Negative charclass named YI SYLLABLE NDO nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[fe7d]" ~~ m/^ <[\C[YI SYLLABLE NDO]]>/, 'Negative charclass named YI SYLLABLE NDO match');
ok(!( "\x[a15d]" ~~ m/^ \X[A15D]/ ), 'Negative hex \X[A15D] nomatch');
ok(!( "\x[a15d]" ~~ m/^ <[\X[A15D]]>/ ), 'Negative charclass hex \X[A15D] nomatch');
#?pugs todo
ok("\x[a15d]" ~~ m/^ \X[FE7D]/, 'Negative hex \X[FE7D] match');
#?pugs todo
ok("\x[a15d]" ~~ m/^ <[\X[FE7D]]>/, 'Negative charclass hex \X[FE7D] match');
#?pugs todo
ok("abc\x[2964]def" ~~ m/\c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]/, 'Unanchored named RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN');
#?pugs todo
ok("abc\c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]def" ~~ m/\x[2964]/, 'Unanchored \x[2964]');
#?pugs todo
ok("abc\c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]def" ~~ m/\o[24544]/, 'Unanchored \o[24544]');
#?pugs todo
ok("abc\x[2964]def" ~~ m/^ abc \c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN] def $/, 'Anchored RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN');
#?pugs todo
ok("abc\x[2964]\x[a15d]def" ~~ m/\c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN,YI SYLLABLE NDO]/, 'Multiple RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN,YI SYLLABLE NDO');
#?pugs todo
ok("\x[2964]\x[a15d]" ~~ m/<[\c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN,YI SYLLABLE NDO]]>/, 'Charclass multiple RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN,YI SYLLABLE NDO');
ok(!( "\x[2964]\x[a15d]" ~~ m/^ <-[\c[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN,YI SYLLABLE NDO]]>/ ), 'Negative charclass RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN,YI SYLLABLE NDO');
#?rakudo 2 todo '\C escape'
ok(!( "\x[2964]" ~~ m/^ \C[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]/ ), 'Negative named RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN nomatch');
#?pugs todo
ok("\x[a15d]" ~~ m/^ \C[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]/, 'Negative named RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[2964]" ~~ m/^ <[\C[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]]>/ ), 'Negative charclass named RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[a15d]" ~~ m/^ <[\C[RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]]>/, 'Negative charclass named RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN match');
ok(!( "\x[2964]" ~~ m/^ \X[2964]/ ), 'Negative hex \X[2964] nomatch');
ok(!( "\x[2964]" ~~ m/^ <[\X[2964]]>/ ), 'Negative charclass hex \X[2964] nomatch');
#?pugs todo
ok("\x[2964]" ~~ m/^ \X[A15D]/, 'Negative hex \X[A15D] match');
#?pugs todo
ok("\x[2964]" ~~ m/^ <[\X[A15D]]>/, 'Negative charclass hex \X[A15D] match');
#?pugs todo
ok("abc\x[ff6d]def" ~~ m/\c[HALFWIDTH KATAKANA LETTER SMALL YU]/, 'Unanchored named HALFWIDTH KATAKANA LETTER SMALL YU');
#?pugs todo
ok("abc\c[HALFWIDTH KATAKANA LETTER SMALL YU]def" ~~ m/\x[FF6D]/, 'Unanchored \x[FF6D]');
#?pugs todo
ok("abc\c[HALFWIDTH KATAKANA LETTER SMALL YU]def" ~~ m/\o[177555]/, 'Unanchored \o[177555]');
#?pugs todo
ok("abc\x[ff6d]def" ~~ m/^ abc \c[HALFWIDTH KATAKANA LETTER SMALL YU] def $/, 'Anchored HALFWIDTH KATAKANA LETTER SMALL YU');
#?pugs todo
ok("abc\x[ff6d]\x[2964]def" ~~ m/\c[HALFWIDTH KATAKANA LETTER SMALL YU, RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]/, 'Multiple HALFWIDTH KATAKANA LETTER SMALL YU, RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN');
#?pugs todo
ok("\x[ff6d]\x[2964]" ~~ m/<[\c[HALFWIDTH KATAKANA LETTER SMALL YU, RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]]>/, 'Charclass multiple HALFWIDTH KATAKANA LETTER SMALL YU, RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN');
ok(!( "\x[ff6d]\x[2964]" ~~ m/^ <-[\c[HALFWIDTH KATAKANA LETTER SMALL YU, RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN]]>/ ), 'Negative charclass HALFWIDTH KATAKANA LETTER SMALL YU, RIGHTWARDS HARPOON WITH BARB UP ABOVE RIGHTWARDS HARPOON WITH BARB DOWN');
#?rakudo 2 todo '\C escape'
ok(!( "\x[ff6d]" ~~ m/^ \C[HALFWIDTH KATAKANA LETTER SMALL YU]/ ), 'Negative named HALFWIDTH KATAKANA LETTER SMALL YU nomatch');
#?pugs todo
ok("\x[2964]" ~~ m/^ \C[HALFWIDTH KATAKANA LETTER SMALL YU]/, 'Negative named HALFWIDTH KATAKANA LETTER SMALL YU match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[ff6d]" ~~ m/^ <[\C[HALFWIDTH KATAKANA LETTER SMALL YU]]>/ ), 'Negative charclass named HALFWIDTH KATAKANA LETTER SMALL YU nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[2964]" ~~ m/^ <[\C[HALFWIDTH KATAKANA LETTER SMALL YU]]>/, 'Negative charclass named HALFWIDTH KATAKANA LETTER SMALL YU match');
ok(!( "\x[ff6d]" ~~ m/^ \X[FF6D]/ ), 'Negative hex \X[FF6D] nomatch');
ok(!( "\x[ff6d]" ~~ m/^ <[\X[FF6D]]>/ ), 'Negative charclass hex \X[FF6D] nomatch');
#?pugs todo
ok("\x[ff6d]" ~~ m/^ \X[2964]/, 'Negative hex \X[2964] match');
#?pugs todo
ok("\x[ff6d]" ~~ m/^ <[\X[2964]]>/, 'Negative charclass hex \X[2964] match');
#?pugs todo
ok("abc\x[36]def" ~~ m/\c[DIGIT SIX]/, 'Unanchored named DIGIT SIX');
#?pugs todo
ok("abc\c[DIGIT SIX]def" ~~ m/\x[36]/, 'Unanchored \x[36]');
#?pugs todo
ok("abc\c[DIGIT SIX]def" ~~ m/\o[66]/, 'Unanchored \o[66]');
#?pugs todo
ok("abc\x[36]def" ~~ m/^ abc \c[DIGIT SIX] def $/, 'Anchored DIGIT SIX');
#?pugs todo
ok("abc\x[36]\x[ff6d]def" ~~ m/\c[DIGIT SIX,HALFWIDTH KATAKANA LETTER SMALL YU]/, 'Multiple DIGIT SIX,HALFWIDTH KATAKANA LETTER SMALL YU');
#?pugs todo
ok("\x[36]\x[ff6d]" ~~ m/<[\c[DIGIT SIX,HALFWIDTH KATAKANA LETTER SMALL YU]]>/, 'Charclass multiple DIGIT SIX,HALFWIDTH KATAKANA LETTER SMALL YU');
ok(!( "\x[36]\x[ff6d]" ~~ m/^ <-[\c[DIGIT SIX,HALFWIDTH KATAKANA LETTER SMALL YU]]>/ ), 'Negative charclass DIGIT SIX,HALFWIDTH KATAKANA LETTER SMALL YU');
#?rakudo 2 todo '\C escape'
ok(!( "\x[36]" ~~ m/^ \C[DIGIT SIX]/ ), 'Negative named DIGIT SIX nomatch');
#?pugs todo
ok("\x[ff6d]" ~~ m/^ \C[DIGIT SIX]/, 'Negative named DIGIT SIX match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[36]" ~~ m/^ <[\C[DIGIT SIX]]>/ ), 'Negative charclass named DIGIT SIX nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[ff6d]" ~~ m/^ <[\C[DIGIT SIX]]>/, 'Negative charclass named DIGIT SIX match');
ok(!( "\x[36]" ~~ m/^ \X[36]/ ), 'Negative hex \X[36] nomatch');
ok(!( "\x[36]" ~~ m/^ <[\X[36]]>/ ), 'Negative charclass hex \X[36] nomatch');
#?pugs todo
ok("\x[36]" ~~ m/^ \X[FF6D]/, 'Negative hex \X[FF6D] match');
#?pugs todo
ok("\x[36]" ~~ m/^ <[\X[FF6D]]>/, 'Negative charclass hex \X[FF6D] match');
#?pugs todo
ok("abc\x[1323]def" ~~ m/\c[ETHIOPIC SYLLABLE THAA]/, 'Unanchored named ETHIOPIC SYLLABLE THAA');
#?pugs todo
ok("abc\c[ETHIOPIC SYLLABLE THAA]def" ~~ m/\x[1323]/, 'Unanchored \x[1323]');
#?pugs todo
ok("abc\c[ETHIOPIC SYLLABLE THAA]def" ~~ m/\o[11443]/, 'Unanchored \o[11443]');
#?pugs todo
ok("abc\x[1323]def" ~~ m/^ abc \c[ETHIOPIC SYLLABLE THAA] def $/, 'Anchored ETHIOPIC SYLLABLE THAA');
#?pugs todo
ok("abc\x[1323]\x[36]def" ~~ m/\c[ETHIOPIC SYLLABLE THAA, DIGIT SIX]/, 'Multiple ETHIOPIC SYLLABLE THAA, DIGIT SIX');
#?pugs todo
ok("\x[1323]\x[36]" ~~ m/<[\c[ETHIOPIC SYLLABLE THAA, DIGIT SIX]]>/, 'Charclass multiple ETHIOPIC SYLLABLE THAA, DIGIT SIX');
ok(!( "\x[1323]\x[36]" ~~ m/^ <-[\c[ETHIOPIC SYLLABLE THAA, DIGIT SIX]]>/ ), 'Negative charclass ETHIOPIC SYLLABLE THAA, DIGIT SIX');
#?rakudo 2 todo '\C escape'
ok(!( "\x[1323]" ~~ m/^ \C[ETHIOPIC SYLLABLE THAA]/ ), 'Negative named ETHIOPIC SYLLABLE THAA nomatch');
#?pugs todo
ok("\x[36]" ~~ m/^ \C[ETHIOPIC SYLLABLE THAA]/, 'Negative named ETHIOPIC SYLLABLE THAA match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[1323]" ~~ m/^ <[\C[ETHIOPIC SYLLABLE THAA]]>/ ), 'Negative charclass named ETHIOPIC SYLLABLE THAA nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[36]" ~~ m/^ <[\C[ETHIOPIC SYLLABLE THAA]]>/, 'Negative charclass named ETHIOPIC SYLLABLE THAA match');
ok(!( "\x[1323]" ~~ m/^ \X[1323]/ ), 'Negative hex \X[1323] nomatch');
ok(!( "\x[1323]" ~~ m/^ <[\X[1323]]>/ ), 'Negative charclass hex \X[1323] nomatch');
#?pugs todo
ok("\x[1323]" ~~ m/^ \X[36]/, 'Negative hex \X[36] match');
#?pugs todo
ok("\x[1323]" ~~ m/^ <[\X[36]]>/, 'Negative charclass hex \X[36] match');
#?pugs todo
ok("abc\x[1697]def" ~~ m/\c[OGHAM LETTER UILLEANN]/, 'Unanchored named OGHAM LETTER UILLEANN');
#?pugs todo
ok("abc\c[OGHAM LETTER UILLEANN]def" ~~ m/\x[1697]/, 'Unanchored \x[1697]');
#?pugs todo
ok("abc\c[OGHAM LETTER UILLEANN]def" ~~ m/\o[13227]/, 'Unanchored \o[13227]');
#?pugs todo
ok("abc\x[1697]def" ~~ m/^ abc \c[OGHAM LETTER UILLEANN] def $/, 'Anchored OGHAM LETTER UILLEANN');
#?pugs todo
ok("abc\x[1697]\x[1323]def" ~~ m/\c[OGHAM LETTER UILLEANN,ETHIOPIC SYLLABLE THAA]/, 'Multiple OGHAM LETTER UILLEANN,ETHIOPIC SYLLABLE THAA');
#?pugs todo
ok("\x[1697]\x[1323]" ~~ m/<[\c[OGHAM LETTER UILLEANN,ETHIOPIC SYLLABLE THAA]]>/, 'Charclass multiple OGHAM LETTER UILLEANN,ETHIOPIC SYLLABLE THAA');
ok(!( "\x[1697]\x[1323]" ~~ m/^ <-[\c[OGHAM LETTER UILLEANN,ETHIOPIC SYLLABLE THAA]]>/ ), 'Negative charclass OGHAM LETTER UILLEANN,ETHIOPIC SYLLABLE THAA');
#?rakudo 2 todo '\C escape'
ok(!( "\x[1697]" ~~ m/^ \C[OGHAM LETTER UILLEANN]/ ), 'Negative named OGHAM LETTER UILLEANN nomatch');
#?pugs todo
ok("\x[1323]" ~~ m/^ \C[OGHAM LETTER UILLEANN]/, 'Negative named OGHAM LETTER UILLEANN match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[1697]" ~~ m/^ <[\C[OGHAM LETTER UILLEANN]]>/ ), 'Negative charclass named OGHAM LETTER UILLEANN nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[1323]" ~~ m/^ <[\C[OGHAM LETTER UILLEANN]]>/, 'Negative charclass named OGHAM LETTER UILLEANN match');
ok(!( "\x[1697]" ~~ m/^ \X[1697]/ ), 'Negative hex \X[1697] nomatch');
ok(!( "\x[1697]" ~~ m/^ <[\X[1697]]>/ ), 'Negative charclass hex \X[1697] nomatch');
#?pugs todo
ok("\x[1697]" ~~ m/^ \X[1323]/, 'Negative hex \X[1323] match');
#?pugs todo
ok("\x[1697]" ~~ m/^ <[\X[1323]]>/, 'Negative charclass hex \X[1323] match');
#?pugs todo
ok("abc\x[fe8b]def" ~~ m/\c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]/, 'Unanchored named ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM');
#?pugs todo
ok("abc\c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]def" ~~ m/\x[fe8b]/, 'Unanchored \x[fe8b]');
#?pugs todo
ok("abc\c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]def" ~~ m/\o[177213]/, 'Unanchored \o[177213]');
#?pugs todo
ok("abc\x[fe8b]def" ~~ m/^ abc \c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM] def $/, 'Anchored ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM');
#?pugs todo
ok("abc\x[fe8b]\x[1697]def" ~~ m/\c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM,OGHAM LETTER UILLEANN]/, 'Multiple ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM,OGHAM LETTER UILLEANN');
#?pugs todo
ok("\x[fe8b]\x[1697]" ~~ m/<[\c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM,OGHAM LETTER UILLEANN]]>/, 'Charclass multiple ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM,OGHAM LETTER UILLEANN');
ok(!( "\x[fe8b]\x[1697]" ~~ m/^ <-[\c[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM,OGHAM LETTER UILLEANN]]>/ ), 'Negative charclass ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM,OGHAM LETTER UILLEANN');
#?rakudo 2 todo '\C escape'
ok(!( "\x[fe8b]" ~~ m/^ \C[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]/ ), 'Negative named ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM nomatch');
#?pugs todo
ok("\x[1697]" ~~ m/^ \C[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]/, 'Negative named ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[fe8b]" ~~ m/^ <[\C[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]]>/ ), 'Negative charclass named ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[1697]" ~~ m/^ <[\C[ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]]>/, 'Negative charclass named ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM match');
ok(!( "\x[fe8b]" ~~ m/^ \X[FE8B]/ ), 'Negative hex \X[FE8B] nomatch');
ok(!( "\x[fe8b]" ~~ m/^ <[\X[FE8B]]>/ ), 'Negative charclass hex \X[FE8B] nomatch');
#?pugs todo
ok("\x[fe8b]" ~~ m/^ \X[1697]/, 'Negative hex \X[1697] match');
#?pugs todo
ok("\x[fe8b]" ~~ m/^ <[\X[1697]]>/, 'Negative charclass hex \X[1697] match');
#?pugs todo
ok("abc\x[16de]def" ~~ m/\c[RUNIC LETTER DAGAZ DAEG D]/, 'Unanchored named RUNIC LETTER DAGAZ DAEG D');
#?pugs todo
ok("abc\c[RUNIC LETTER DAGAZ DAEG D]def" ~~ m/\x[16DE]/, 'Unanchored \x[16DE]');
#?pugs todo
ok("abc\c[RUNIC LETTER DAGAZ DAEG D]def" ~~ m/\o[13336]/, 'Unanchored \o[13336]');
#?pugs todo
ok("abc\x[16de]def" ~~ m/^ abc \c[RUNIC LETTER DAGAZ DAEG D] def $/, 'Anchored RUNIC LETTER DAGAZ DAEG D');
#?pugs todo
ok("abc\x[16de]\x[fe8b]def" ~~ m/\c[RUNIC LETTER DAGAZ DAEG D,ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]/, 'Multiple RUNIC LETTER DAGAZ DAEG D,ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM');
#?pugs todo
ok("\x[16de]\x[fe8b]" ~~ m/<[\c[RUNIC LETTER DAGAZ DAEG D,ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]]>/, 'Charclass multiple RUNIC LETTER DAGAZ DAEG D,ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM');
ok(!( "\x[16de]\x[fe8b]" ~~ m/^ <-[\c[RUNIC LETTER DAGAZ DAEG D,ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM]]>/ ), 'Negative charclass RUNIC LETTER DAGAZ DAEG D,ARABIC LETTER YEH WITH HAMZA ABOVE INITIAL FORM');
#?rakudo 2 todo '\C escape'
ok(!( "\x[16de]" ~~ m/^ \C[RUNIC LETTER DAGAZ DAEG D]/ ), 'Negative named RUNIC LETTER DAGAZ DAEG D nomatch');
#?pugs todo
ok("\x[fe8b]" ~~ m/^ \C[RUNIC LETTER DAGAZ DAEG D]/, 'Negative named RUNIC LETTER DAGAZ DAEG D match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[16de]" ~~ m/^ <[\C[RUNIC LETTER DAGAZ DAEG D]]>/ ), 'Negative charclass named RUNIC LETTER DAGAZ DAEG D nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[fe8b]" ~~ m/^ <[\C[RUNIC LETTER DAGAZ DAEG D]]>/, 'Negative charclass named RUNIC LETTER DAGAZ DAEG D match');
ok(!( "\x[16de]" ~~ m/^ \X[16DE]/ ), 'Negative hex \X[16DE] nomatch');
ok(!( "\x[16de]" ~~ m/^ <[\X[16DE]]>/ ), 'Negative charclass hex \X[16DE] nomatch');
#?pugs todo
ok("\x[16de]" ~~ m/^ \X[FE8B]/, 'Negative hex \X[FE8B] match');
#?pugs todo
ok("\x[16de]" ~~ m/^ <[\X[FE8B]]>/, 'Negative charclass hex \X[FE8B] match');
#?pugs todo
ok("abc\x[64]def" ~~ m/\c[LATIN SMALL LETTER D]/, 'Unanchored named LATIN SMALL LETTER D');
#?pugs todo
ok("abc\c[LATIN SMALL LETTER D]def" ~~ m/\x[64]/, 'Unanchored \x[64]');
#?pugs todo
ok("abc\c[LATIN SMALL LETTER D]def" ~~ m/\o[144]/, 'Unanchored \o[144]');
#?pugs todo
ok("abc\x[64]def" ~~ m/^ abc \c[LATIN SMALL LETTER D] def $/, 'Anchored LATIN SMALL LETTER D');
#?pugs todo
ok("abc\x[64]\x[16de]def" ~~ m/\c[LATIN SMALL LETTER D,RUNIC LETTER DAGAZ DAEG D]/, 'Multiple LATIN SMALL LETTER D,RUNIC LETTER DAGAZ DAEG D');
#?pugs todo
ok("\x[64]\x[16de]" ~~ m/<[\c[LATIN SMALL LETTER D,RUNIC LETTER DAGAZ DAEG D]]>/, 'Charclass multiple LATIN SMALL LETTER D,RUNIC LETTER DAGAZ DAEG D');
ok(!( "\x[64]\x[16de]" ~~ m/^ <-[\c[LATIN SMALL LETTER D,RUNIC LETTER DAGAZ DAEG D]]>/ ), 'Negative charclass LATIN SMALL LETTER D,RUNIC LETTER DAGAZ DAEG D');
#?rakudo 2 todo '\C escape'
ok(!( "\x[64]" ~~ m/^ \C[LATIN SMALL LETTER D]/ ), 'Negative named LATIN SMALL LETTER D nomatch');
#?pugs todo
ok("\x[16de]" ~~ m/^ \C[LATIN SMALL LETTER D]/, 'Negative named LATIN SMALL LETTER D match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[64]" ~~ m/^ <[\C[LATIN SMALL LETTER D]]>/ ), 'Negative charclass named LATIN SMALL LETTER D nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[16de]" ~~ m/^ <[\C[LATIN SMALL LETTER D]]>/, 'Negative charclass named LATIN SMALL LETTER D match');
ok(!( "\x[64]" ~~ m/^ \X[64]/ ), 'Negative hex \X[64] nomatch');
ok(!( "\x[64]" ~~ m/^ <[\X[64]]>/ ), 'Negative charclass hex \X[64] nomatch');
#?pugs todo
ok("\x[64]" ~~ m/^ \X[16DE]/, 'Negative hex \X[16DE] match');
#?pugs todo
ok("\x[64]" ~~ m/^ <[\X[16DE]]>/, 'Negative charclass hex \X[16DE] match');
#?pugs todo
ok("abc\x[2724]def" ~~ m/\c[HEAVY FOUR BALLOON-SPOKED ASTERISK]/, 'Unanchored named HEAVY FOUR BALLOON-SPOKED ASTERISK');
#?pugs todo
ok("abc\c[HEAVY FOUR BALLOON-SPOKED ASTERISK]def" ~~ m/\x[2724]/, 'Unanchored \x[2724]');
#?pugs todo
ok("abc\c[HEAVY FOUR BALLOON-SPOKED ASTERISK]def" ~~ m/\o[23444]/, 'Unanchored \o[23444]');
#?pugs todo
ok("abc\x[2724]def" ~~ m/^ abc \c[HEAVY FOUR BALLOON-SPOKED ASTERISK] def $/, 'Anchored HEAVY FOUR BALLOON-SPOKED ASTERISK');
#?pugs todo
ok("abc\x[2724]\x[64]def" ~~ m/\c[HEAVY FOUR BALLOON-SPOKED ASTERISK,LATIN SMALL LETTER D]/, 'Multiple HEAVY FOUR BALLOON-SPOKED ASTERISK,LATIN SMALL LETTER D');
#?pugs todo
ok("\x[2724]\x[64]" ~~ m/<[\c[HEAVY FOUR BALLOON-SPOKED ASTERISK,LATIN SMALL LETTER D]]>/, 'Charclass multiple HEAVY FOUR BALLOON-SPOKED ASTERISK,LATIN SMALL LETTER D');
ok(!( "\x[2724]\x[64]" ~~ m/^ <-[\c[HEAVY FOUR BALLOON-SPOKED ASTERISK,LATIN SMALL LETTER D]]>/ ), 'Negative charclass HEAVY FOUR BALLOON-SPOKED ASTERISK,LATIN SMALL LETTER D');
#?rakudo 2 todo '\C escape'
ok(!( "\x[2724]" ~~ m/^ \C[HEAVY FOUR BALLOON-SPOKED ASTERISK]/ ), 'Negative named HEAVY FOUR BALLOON-SPOKED ASTERISK nomatch');
#?pugs todo
ok("\x[64]" ~~ m/^ \C[HEAVY FOUR BALLOON-SPOKED ASTERISK]/, 'Negative named HEAVY FOUR BALLOON-SPOKED ASTERISK match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[2724]" ~~ m/^ <[\C[HEAVY FOUR BALLOON-SPOKED ASTERISK]]>/ ), 'Negative charclass named HEAVY FOUR BALLOON-SPOKED ASTERISK nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[64]" ~~ m/^ <[\C[HEAVY FOUR BALLOON-SPOKED ASTERISK]]>/, 'Negative charclass named HEAVY FOUR BALLOON-SPOKED ASTERISK match');
ok(!( "\x[2724]" ~~ m/^ \X[2724]/ ), 'Negative hex \X[2724] nomatch');
ok(!( "\x[2724]" ~~ m/^ <[\X[2724]]>/ ), 'Negative charclass hex \X[2724] nomatch');
#?pugs todo
ok("\x[2724]" ~~ m/^ \X[64]/, 'Negative hex \X[64] match');
#?pugs todo
ok("\x[2724]" ~~ m/^ <[\X[64]]>/, 'Negative charclass hex \X[64] match');
#?pugs todo
ok("abc\x[2719]def" ~~ m/\c[OUTLINED GREEK CROSS]/, 'Unanchored named OUTLINED GREEK CROSS');
#?pugs todo
ok("abc\c[OUTLINED GREEK CROSS]def" ~~ m/\x[2719]/, 'Unanchored \x[2719]');
#?pugs todo
ok("abc\c[OUTLINED GREEK CROSS]def" ~~ m/\o[23431]/, 'Unanchored \o[23431]');
#?pugs todo
ok("abc\x[2719]def" ~~ m/^ abc \c[OUTLINED GREEK CROSS] def $/, 'Anchored OUTLINED GREEK CROSS');
#?pugs todo
ok("abc\x[2719]\x[2724]def" ~~ m/\c[OUTLINED GREEK CROSS,HEAVY FOUR BALLOON-SPOKED ASTERISK]/, 'Multiple OUTLINED GREEK CROSS,HEAVY FOUR BALLOON-SPOKED ASTERISK');
#?pugs todo
ok("\x[2719]\x[2724]" ~~ m/<[\c[OUTLINED GREEK CROSS,HEAVY FOUR BALLOON-SPOKED ASTERISK]]>/, 'Charclass multiple OUTLINED GREEK CROSS,HEAVY FOUR BALLOON-SPOKED ASTERISK');
ok(!( "\x[2719]\x[2724]" ~~ m/^ <-[\c[OUTLINED GREEK CROSS,HEAVY FOUR BALLOON-SPOKED ASTERISK]]>/ ), 'Negative charclass OUTLINED GREEK CROSS,HEAVY FOUR BALLOON-SPOKED ASTERISK');
#?rakudo 2 todo '\C escape'
ok(!( "\x[2719]" ~~ m/^ \C[OUTLINED GREEK CROSS]/ ), 'Negative named OUTLINED GREEK CROSS nomatch');
#?pugs todo
ok("\x[2724]" ~~ m/^ \C[OUTLINED GREEK CROSS]/, 'Negative named OUTLINED GREEK CROSS match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[2719]" ~~ m/^ <[\C[OUTLINED GREEK CROSS]]>/ ), 'Negative charclass named OUTLINED GREEK CROSS nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[2724]" ~~ m/^ <[\C[OUTLINED GREEK CROSS]]>/, 'Negative charclass named OUTLINED GREEK CROSS match');
ok(!( "\x[2719]" ~~ m/^ \X[2719]/ ), 'Negative hex \X[2719] nomatch');
ok(!( "\x[2719]" ~~ m/^ <[\X[2719]]>/ ), 'Negative charclass hex \X[2719] nomatch');
#?pugs todo
ok("\x[2719]" ~~ m/^ \X[2724]/, 'Negative hex \X[2724] match');
#?pugs todo
ok("\x[2719]" ~~ m/^ <[\X[2724]]>/, 'Negative charclass hex \X[2724] match');
#?pugs todo
ok("abc\x[e97]def" ~~ m/\c[LAO LETTER THO TAM]/, 'Unanchored named LAO LETTER THO TAM');
#?pugs todo
ok("abc\c[LAO LETTER THO TAM]def" ~~ m/\x[e97]/, 'Unanchored \x[e97]');
#?pugs todo
ok("abc\c[LAO LETTER THO TAM]def" ~~ m/\o[7227]/, 'Unanchored \o[7227]');
#?pugs todo
ok("abc\x[e97]def" ~~ m/^ abc \c[LAO LETTER THO TAM] def $/, 'Anchored LAO LETTER THO TAM');
#?pugs todo
ok("abc\x[e97]\x[2719]def" ~~ m/\c[LAO LETTER THO TAM, OUTLINED GREEK CROSS]/, 'Multiple LAO LETTER THO TAM, OUTLINED GREEK CROSS');
#?pugs todo
ok("\x[e97]\x[2719]" ~~ m/<[\c[LAO LETTER THO TAM, OUTLINED GREEK CROSS]]>/, 'Charclass multiple LAO LETTER THO TAM, OUTLINED GREEK CROSS');
ok(!( "\x[e97]\x[2719]" ~~ m/^ <-[\c[LAO LETTER THO TAM, OUTLINED GREEK CROSS]]>/ ), 'Negative charclass LAO LETTER THO TAM, OUTLINED GREEK CROSS');
#?rakudo 2 todo '\C escape'
ok(!( "\x[e97]" ~~ m/^ \C[LAO LETTER THO TAM]/ ), 'Negative named LAO LETTER THO TAM nomatch');
#?pugs todo
ok("\x[2719]" ~~ m/^ \C[LAO LETTER THO TAM]/, 'Negative named LAO LETTER THO TAM match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[e97]" ~~ m/^ <[\C[LAO LETTER THO TAM]]>/ ), 'Negative charclass named LAO LETTER THO TAM nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[2719]" ~~ m/^ <[\C[LAO LETTER THO TAM]]>/, 'Negative charclass named LAO LETTER THO TAM match');
ok(!( "\x[e97]" ~~ m/^ \X[E97]/ ), 'Negative hex \X[E97] nomatch');
ok(!( "\x[e97]" ~~ m/^ <[\X[E97]]>/ ), 'Negative charclass hex \X[E97] nomatch');
#?pugs todo
ok("\x[e97]" ~~ m/^ \X[2719]/, 'Negative hex \X[2719] match');
#?pugs todo
ok("\x[e97]" ~~ m/^ <[\X[2719]]>/, 'Negative charclass hex \X[2719] match');
#?pugs todo
ok("abc\x[a42d]def" ~~ m/\c[YI SYLLABLE JJYT]/, 'Unanchored named YI SYLLABLE JJYT');
#?pugs todo
ok("abc\c[YI SYLLABLE JJYT]def" ~~ m/\x[a42d]/, 'Unanchored \x[a42d]');
#?pugs todo
ok("abc\c[YI SYLLABLE JJYT]def" ~~ m/\o[122055]/, 'Unanchored \o[122055]');
#?pugs todo
ok("abc\x[a42d]def" ~~ m/^ abc \c[YI SYLLABLE JJYT] def $/, 'Anchored YI SYLLABLE JJYT');
#?pugs todo
ok("abc\x[a42d]\x[e97]def" ~~ m/\c[YI SYLLABLE JJYT,LAO LETTER THO TAM]/, 'Multiple YI SYLLABLE JJYT,LAO LETTER THO TAM');
#?pugs todo
ok("\x[a42d]\x[e97]" ~~ m/<[\c[YI SYLLABLE JJYT,LAO LETTER THO TAM]]>/, 'Charclass multiple YI SYLLABLE JJYT,LAO LETTER THO TAM');
ok(!( "\x[a42d]\x[e97]" ~~ m/^ <-[\c[YI SYLLABLE JJYT,LAO LETTER THO TAM]]>/ ), 'Negative charclass YI SYLLABLE JJYT,LAO LETTER THO TAM');
#?rakudo 2 todo '\C escape'
ok(!( "\x[a42d]" ~~ m/^ \C[YI SYLLABLE JJYT]/ ), 'Negative named YI SYLLABLE JJYT nomatch');
#?pugs todo
ok("\x[e97]" ~~ m/^ \C[YI SYLLABLE JJYT]/, 'Negative named YI SYLLABLE JJYT match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[a42d]" ~~ m/^ <[\C[YI SYLLABLE JJYT]]>/ ), 'Negative charclass named YI SYLLABLE JJYT nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[e97]" ~~ m/^ <[\C[YI SYLLABLE JJYT]]>/, 'Negative charclass named YI SYLLABLE JJYT match');
ok(!( "\x[a42d]" ~~ m/^ \X[A42D]/ ), 'Negative hex \X[A42D] nomatch');
ok(!( "\x[a42d]" ~~ m/^ <[\X[A42D]]>/ ), 'Negative charclass hex \X[A42D] nomatch');
#?pugs todo
ok("\x[a42d]" ~~ m/^ \X[E97]/, 'Negative hex \X[E97] match');
#?pugs todo
ok("\x[a42d]" ~~ m/^ <[\X[E97]]>/, 'Negative charclass hex \X[E97] match');
#?pugs todo
ok("abc\x[ff6e]def" ~~ m/\c[HALFWIDTH KATAKANA LETTER SMALL YO]/, 'Unanchored named HALFWIDTH KATAKANA LETTER SMALL YO');
#?pugs todo
ok("abc\c[HALFWIDTH KATAKANA LETTER SMALL YO]def" ~~ m/\x[FF6E]/, 'Unanchored \x[FF6E]');
#?pugs todo
ok("abc\c[HALFWIDTH KATAKANA LETTER SMALL YO]def" ~~ m/\o[177556]/, 'Unanchored \o[177556]');
#?pugs todo
ok("abc\x[ff6e]def" ~~ m/^ abc \c[HALFWIDTH KATAKANA LETTER SMALL YO] def $/, 'Anchored HALFWIDTH KATAKANA LETTER SMALL YO');
#?pugs todo
ok("abc\x[ff6e]\x[a42d]def" ~~ m/\c[HALFWIDTH KATAKANA LETTER SMALL YO,YI SYLLABLE JJYT]/, 'Multiple HALFWIDTH KATAKANA LETTER SMALL YO,YI SYLLABLE JJYT');
#?pugs todo
ok("\x[ff6e]\x[a42d]" ~~ m/<[\c[HALFWIDTH KATAKANA LETTER SMALL YO,YI SYLLABLE JJYT]]>/, 'Charclass multiple HALFWIDTH KATAKANA LETTER SMALL YO,YI SYLLABLE JJYT');
ok(!( "\x[ff6e]\x[a42d]" ~~ m/^ <-[\c[HALFWIDTH KATAKANA LETTER SMALL YO,YI SYLLABLE JJYT]]>/ ), 'Negative charclass HALFWIDTH KATAKANA LETTER SMALL YO,YI SYLLABLE JJYT');
#?rakudo 2 todo '\C escape'
ok(!( "\x[ff6e]" ~~ m/^ \C[HALFWIDTH KATAKANA LETTER SMALL YO]/ ), 'Negative named HALFWIDTH KATAKANA LETTER SMALL YO nomatch');
#?pugs todo
ok("\x[a42d]" ~~ m/^ \C[HALFWIDTH KATAKANA LETTER SMALL YO]/, 'Negative named HALFWIDTH KATAKANA LETTER SMALL YO match');
#?rakudo skip 'negative char class in enumerated list'
ok(!( "\x[ff6e]" ~~ m/^ <[\C[HALFWIDTH KATAKANA LETTER SMALL YO]]>/ ), 'Negative charclass named HALFWIDTH KATAKANA LETTER SMALL YO nomatch');
#?rakudo skip 'negative char class in enumerated list'
#?pugs todo
ok("\x[a42d]" ~~ m/^ <[\C[HALFWIDTH KATAKANA LETTER SMALL YO]]>/, 'Negative charclass named HALFWIDTH KATAKANA LETTER SMALL YO match');
ok(!( "\x[ff6e]" ~~ m/^ \X[FF6E]/ ), 'Negative hex \X[FF6E] nomatch');
ok(!( "\x[ff6e]" ~~ m/^ <[\X[FF6E]]>/ ), 'Negative charclass hex \X[FF6E] nomatch');
#?pugs todo
ok("\x[ff6e]" ~~ m/^ \X[A42D]/, 'Negative hex \X[A42D] match');
#?pugs todo
ok("\x[ff6e]" ~~ m/^ <[\X[A42D]]>/, 'Negative charclass hex \X[A42D] match');
 

# names special cases (see http://www.unicode.org/reports/tr18/#Name_Properties) "... that require special-casing ..."

#?pugs todo
ok("\x[0F68]" ~~ m/\c[TIBETAN LETTER A]/, 'match named TIBETAN LETTER A');
#?pugs todo
ok("\x[0F60]" ~~ m/\c[TIBETAN LETTER -A]/, 'match named TIBETAN LETTER -A');
ok(!("\c[TIBETAN LETTER A]" ~~ m/\c[TIBETAN LETTER -A]/), 'nomatch named TIBETAN LETTER A versus -A');
ok(!("\c[TIBETAN LETTER -A]" ~~ m/\c[TIBETAN LETTER A]/), 'nomatch named TIBETAN LETTER -A versus A');

#?pugs todo
ok("\x[0FB8]" ~~ m/\c[TIBETAN SUBJOINED LETTER A]/, 'match named TIBETAN SUBJOINED LETTER A');
#?pugs todo
ok("\x[0FB0]" ~~ m/\c[TIBETAN SUBJOINED LETTER -A]/, 'match named TIBETAN SUBJOINED LETTER -A');
ok(!("\c[TIBETAN SUBJOINED LETTER A]" ~~ m/\c[TIBETAN SUBJOINED LETTER -A]/), 'nomatch named TIBETAN SUBJOINED LETTER A versus -A');
ok(!("\c[TIBETAN SUBJOINED LETTER -A]" ~~ m/\c[TIBETAN SUBJOINED LETTER A]/), 'nomatch named TIBETAN SUBJOINED LETTER -A versus A');

#?pugs todo
ok("\x[116C]" ~~ m/\c[HANGUL JUNGSEONG OE]/, 'match named HANGUL JUNGSEONG OE');
#?pugs todo
ok("\x[1180]" ~~ m/\c[HANGUL JUNGSEONG O-E]/, 'match named HANGUL JUNGSEONG O-E');
ok(!("\c[HANGUL JUNGSEONG OE]" ~~ m/\c[HANGUL JUNGSEONG O-E]/), 'nomatch named HANGUL JUNGSEONG OE versus O-E');
ok(!("\c[HANGUL JUNGSEONG O-E]" ~~ m/\c[HANGUL JUNGSEONG OE]/), 'nomatch named HANGUL JUNGSEONG O-E versus OE');

# TODO: name aliases (see http://www.unicode.org/reports/tr18/#Name_Properties)
# for U+0009 the implementation could accept the official name CHARACTER TABULATION, and also the aliases HORIZONTAL TABULATION, HT, and TAB
# XXX should Perl-5 aliases be supported as a minimum?
# XXX should there be something like "use warning 'deprecated'"?

# TODO: named sequences (see http://www.unicode.org/reports/tr18/#Name_Properties)

# TODO: loose match, disregarding case, spaces and hyphen (see http://www.unicode.org/reports/tr18/#Name_Properties)

# TODO: global prefix like "LATIN LETTER" (see http://www.unicode.org/reports/tr18/#Name_Properties)
# XXX should this be supported?

# TODO: border values
# \x[0000], \x[007F], \x[0080], \x[00FF],
# \x[FFFF], \x[00010000], \x[0010FFFF], 
# \x[00110000], ... \x[FFFFFFFF] XXX should do what?

# TODO: Grapheme
# XXX The character name of a grapheme is a list of NFC-names?

# TODO: no-names (like ) , invalid names, deprecated names

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/properties-block.t0000664000175000017500000022364512224265625021003 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/properties_slow_to_compile.t.

XXX needs more clarification on the case of the rules, 
ie letter vs. Letter vs isLetter

=end pod

plan 670;

# InAlphabeticPresentationForms

ok(!( "\x[531A]"  ~~ m/^<:InAlphabeticPresentationForms>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[531A]"  ~~ m/^<:!InAlphabeticPresentationForms>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[531A]"  ~~ m/^<-:InAlphabeticPresentationForms>$/, q{Match unrelated inverted } );

# InArabic


#?pugs todo
ok("\c[ARABIC NUMBER SIGN]" ~~ m/^<:InArabic>$/, q{Match <:InArabic>} );
ok(!( "\c[ARABIC NUMBER SIGN]" ~~ m/^<:!InArabic>$/ ), q{Don't match negated } );
ok(!( "\c[ARABIC NUMBER SIGN]" ~~ m/^<-:InArabic>$/ ), q{Don't match inverted } );
ok(!( "\x[7315]"  ~~ m/^<:InArabic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7315]"  ~~ m/^<:!InArabic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7315]"  ~~ m/^<-:InArabic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7315]\c[ARABIC NUMBER SIGN]" ~~ m/<:InArabic>/, q{Match unanchored } );

# InArabicPresentationFormsA


ok(!( "\x[8340]"  ~~ m/^<:InArabicPresentationFormsA>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8340]"  ~~ m/^<:!InArabicPresentationFormsA>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8340]"  ~~ m/^<-:InArabicPresentationFormsA>$/, q{Match unrelated inverted } );

# InArabicPresentationFormsB


ok(!( "\x[BEEC]"  ~~ m/^<:InArabicPresentationFormsB>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BEEC]"  ~~ m/^<:!InArabicPresentationFormsB>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BEEC]"  ~~ m/^<-:InArabicPresentationFormsB>$/, q{Match unrelated inverted } );

# InArmenian


#?pugs todo
ok("\x[0530]" ~~ m/^<:InArmenian>$/, q{Match <:InArmenian>} );
ok(!( "\x[0530]" ~~ m/^<:!InArmenian>$/ ), q{Don't match negated } );
ok(!( "\x[0530]" ~~ m/^<-:InArmenian>$/ ), q{Don't match inverted } );
ok(!( "\x[3B0D]"  ~~ m/^<:InArmenian>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3B0D]"  ~~ m/^<:!InArmenian>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3B0D]"  ~~ m/^<-:InArmenian>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3B0D]\x[0530]" ~~ m/<:InArmenian>/, q{Match unanchored } );

# InArrows


#?pugs todo
ok("\c[LEFTWARDS ARROW]" ~~ m/^<:InArrows>$/, q{Match <:InArrows>} );
ok(!( "\c[LEFTWARDS ARROW]" ~~ m/^<:!InArrows>$/ ), q{Don't match negated } );
ok(!( "\c[LEFTWARDS ARROW]" ~~ m/^<-:InArrows>$/ ), q{Don't match inverted } );
ok(!( "\x[C401]"  ~~ m/^<:InArrows>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C401]"  ~~ m/^<:!InArrows>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C401]"  ~~ m/^<-:InArrows>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[C401]\c[LEFTWARDS ARROW]" ~~ m/<:InArrows>/, q{Match unanchored } );


# InBasicLatin


#?pugs todo
ok("\c[NULL]" ~~ m/^<:InBasicLatin>$/, q{Match <:InBasicLatin>} );
ok(!( "\c[NULL]" ~~ m/^<:!InBasicLatin>$/ ), q{Don't match negated } );
ok(!( "\c[NULL]" ~~ m/^<-:InBasicLatin>$/ ), q{Don't match inverted } );
ok(!( "\x[46EA]"  ~~ m/^<:InBasicLatin>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[46EA]"  ~~ m/^<:!InBasicLatin>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[46EA]"  ~~ m/^<-:InBasicLatin>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[46EA]\c[NULL]" ~~ m/<:InBasicLatin>/, q{Match unanchored } );

# InBengali


#?pugs todo
ok("\x[0980]" ~~ m/^<:InBengali>$/, q{Match <:InBengali>} );
ok(!( "\x[0980]" ~~ m/^<:!InBengali>$/ ), q{Don't match negated } );
ok(!( "\x[0980]" ~~ m/^<-:InBengali>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE HMY]"  ~~ m/^<:InBengali>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE HMY]"  ~~ m/^<:!InBengali>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE HMY]"  ~~ m/^<-:InBengali>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE HMY]\x[0980]" ~~ m/<:InBengali>/, q{Match unanchored } );

# InBlockElements


#?pugs todo
ok("\c[UPPER HALF BLOCK]" ~~ m/^<:InBlockElements>$/, q{Match <:InBlockElements>} );
ok(!( "\c[UPPER HALF BLOCK]" ~~ m/^<:!InBlockElements>$/ ), q{Don't match negated } );
ok(!( "\c[UPPER HALF BLOCK]" ~~ m/^<-:InBlockElements>$/ ), q{Don't match inverted } );
ok(!( "\x[5F41]"  ~~ m/^<:InBlockElements>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5F41]"  ~~ m/^<:!InBlockElements>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5F41]"  ~~ m/^<-:InBlockElements>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[5F41]\c[UPPER HALF BLOCK]" ~~ m/<:InBlockElements>/, q{Match unanchored } );

# InBopomofo


#?pugs todo
ok("\x[3100]" ~~ m/^<:InBopomofo>$/, q{Match <:InBopomofo>} );
ok(!( "\x[3100]" ~~ m/^<:!InBopomofo>$/ ), q{Don't match negated } );
ok(!( "\x[3100]" ~~ m/^<-:InBopomofo>$/ ), q{Don't match inverted } );
ok(!( "\x[9F8E]"  ~~ m/^<:InBopomofo>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9F8E]"  ~~ m/^<:!InBopomofo>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9F8E]"  ~~ m/^<-:InBopomofo>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9F8E]\x[3100]" ~~ m/<:InBopomofo>/, q{Match unanchored } );

# InBopomofoExtended


#?pugs todo
ok("\c[BOPOMOFO LETTER BU]" ~~ m/^<:InBopomofoExtended>$/, q{Match <:InBopomofoExtended>} );
ok(!( "\c[BOPOMOFO LETTER BU]" ~~ m/^<:!InBopomofoExtended>$/ ), q{Don't match negated } );
ok(!( "\c[BOPOMOFO LETTER BU]" ~~ m/^<-:InBopomofoExtended>$/ ), q{Don't match inverted } );
ok(!( "\x[43A6]"  ~~ m/^<:InBopomofoExtended>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[43A6]"  ~~ m/^<:!InBopomofoExtended>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[43A6]"  ~~ m/^<-:InBopomofoExtended>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[43A6]\c[BOPOMOFO LETTER BU]" ~~ m/<:InBopomofoExtended>/, q{Match unanchored } );

# InBoxDrawing


#?pugs todo
ok("\c[BOX DRAWINGS LIGHT HORIZONTAL]" ~~ m/^<:InBoxDrawing>$/, q{Match <:InBoxDrawing>} );
ok(!( "\c[BOX DRAWINGS LIGHT HORIZONTAL]" ~~ m/^<:!InBoxDrawing>$/ ), q{Don't match negated } );
ok(!( "\c[BOX DRAWINGS LIGHT HORIZONTAL]" ~~ m/^<-:InBoxDrawing>$/ ), q{Don't match inverted } );
ok(!( "\x[7865]"  ~~ m/^<:InBoxDrawing>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7865]"  ~~ m/^<:!InBoxDrawing>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7865]"  ~~ m/^<-:InBoxDrawing>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7865]\c[BOX DRAWINGS LIGHT HORIZONTAL]" ~~ m/<:InBoxDrawing>/, q{Match unanchored } );

# InBraillePatterns


#?pugs todo
ok("\c[BRAILLE PATTERN BLANK]" ~~ m/^<:InBraillePatterns>$/, q{Match <:InBraillePatterns>} );
ok(!( "\c[BRAILLE PATTERN BLANK]" ~~ m/^<:!InBraillePatterns>$/ ), q{Don't match negated } );
ok(!( "\c[BRAILLE PATTERN BLANK]" ~~ m/^<-:InBraillePatterns>$/ ), q{Don't match inverted } );
ok(!( "\c[THAI CHARACTER KHO KHAI]"  ~~ m/^<:InBraillePatterns>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[THAI CHARACTER KHO KHAI]"  ~~ m/^<:!InBraillePatterns>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[THAI CHARACTER KHO KHAI]"  ~~ m/^<-:InBraillePatterns>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[THAI CHARACTER KHO KHAI]\c[BRAILLE PATTERN BLANK]" ~~ m/<:InBraillePatterns>/, q{Match unanchored } );

# InBuhid


#?pugs todo
ok("\c[BUHID LETTER A]" ~~ m/^<:InBuhid>$/, q{Match <:InBuhid>} );
ok(!( "\c[BUHID LETTER A]" ~~ m/^<:!InBuhid>$/ ), q{Don't match negated } );
ok(!( "\c[BUHID LETTER A]" ~~ m/^<-:InBuhid>$/ ), q{Don't match inverted } );
ok(!( "\x[D208]"  ~~ m/^<:InBuhid>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D208]"  ~~ m/^<:!InBuhid>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D208]"  ~~ m/^<-:InBuhid>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D208]\c[BUHID LETTER A]" ~~ m/<:InBuhid>/, q{Match unanchored } );

# InByzantineMusicalSymbols


ok(!( "\x[9B1D]"  ~~ m/^<:InByzantineMusicalSymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9B1D]"  ~~ m/^<:!InByzantineMusicalSymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9B1D]"  ~~ m/^<-:InByzantineMusicalSymbols>$/, q{Match unrelated inverted } );

# InCJKCompatibility


#?pugs todo
ok("\c[SQUARE APAATO]" ~~ m/^<:InCJKCompatibility>$/, q{Match <:InCJKCompatibility>} );
ok(!( "\c[SQUARE APAATO]" ~~ m/^<:!InCJKCompatibility>$/ ), q{Don't match negated } );
ok(!( "\c[SQUARE APAATO]" ~~ m/^<-:InCJKCompatibility>$/ ), q{Don't match inverted } );
ok(!( "\x[B8A5]"  ~~ m/^<:InCJKCompatibility>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B8A5]"  ~~ m/^<:!InCJKCompatibility>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B8A5]"  ~~ m/^<-:InCJKCompatibility>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[B8A5]\c[SQUARE APAATO]" ~~ m/<:InCJKCompatibility>/, q{Match unanchored } );

# InCJKCompatibilityForms


ok(!( "\x[3528]"  ~~ m/^<:InCJKCompatibilityForms>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3528]"  ~~ m/^<:!InCJKCompatibilityForms>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3528]"  ~~ m/^<-:InCJKCompatibilityForms>$/, q{Match unrelated inverted } );

# InCJKCompatibilityIdeographs


ok(!( "\x[69F7]"  ~~ m/^<:InCJKCompatibilityIdeographs>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[69F7]"  ~~ m/^<:!InCJKCompatibilityIdeographs>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[69F7]"  ~~ m/^<-:InCJKCompatibilityIdeographs>$/, q{Match unrelated inverted } );

# InCJKCompatibilityIdeographsSupplement


ok(!( "\c[CANADIAN SYLLABICS NUNAVIK HO]"  ~~ m/^<:InCJKCompatibilityIdeographsSupplement>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS NUNAVIK HO]"  ~~ m/^<:!InCJKCompatibilityIdeographsSupplement>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS NUNAVIK HO]"  ~~ m/^<-:InCJKCompatibilityIdeographsSupplement>$/, q{Match unrelated inverted } );

# InCJKRadicalsSupplement


#?pugs todo
ok("\c[CJK RADICAL REPEAT]" ~~ m/^<:InCJKRadicalsSupplement>$/, q{Match <:InCJKRadicalsSupplement>} );
ok(!( "\c[CJK RADICAL REPEAT]" ~~ m/^<:!InCJKRadicalsSupplement>$/ ), q{Don't match negated } );
ok(!( "\c[CJK RADICAL REPEAT]" ~~ m/^<-:InCJKRadicalsSupplement>$/ ), q{Don't match inverted } );
ok(!( "\x[37B4]"  ~~ m/^<:InCJKRadicalsSupplement>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[37B4]"  ~~ m/^<:!InCJKRadicalsSupplement>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[37B4]"  ~~ m/^<-:InCJKRadicalsSupplement>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[37B4]\c[CJK RADICAL REPEAT]" ~~ m/<:InCJKRadicalsSupplement>/, q{Match unanchored } );

# InCJKSymbolsAndPunctuation


#?pugs todo
ok("\c[IDEOGRAPHIC SPACE]" ~~ m/^<:InCJKSymbolsAndPunctuation>$/, q{Match <:InCJKSymbolsAndPunctuation>} );
ok(!( "\c[IDEOGRAPHIC SPACE]" ~~ m/^<:!InCJKSymbolsAndPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[IDEOGRAPHIC SPACE]" ~~ m/^<-:InCJKSymbolsAndPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[80AA]"  ~~ m/^<:InCJKSymbolsAndPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[80AA]"  ~~ m/^<:!InCJKSymbolsAndPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[80AA]"  ~~ m/^<-:InCJKSymbolsAndPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[80AA]\c[IDEOGRAPHIC SPACE]" ~~ m/<:InCJKSymbolsAndPunctuation>/, q{Match unanchored } );

# InCJKUnifiedIdeographs


#?pugs todo
ok("\x[4E00]" ~~ m/^<:InCJKUnifiedIdeographs>$/, q{Match <:InCJKUnifiedIdeographs>} );
ok(!( "\x[4E00]" ~~ m/^<:!InCJKUnifiedIdeographs>$/ ), q{Don't match negated } );
ok(!( "\x[4E00]" ~~ m/^<-:InCJKUnifiedIdeographs>$/ ), q{Don't match inverted } );
ok(!( "\x[3613]"  ~~ m/^<:InCJKUnifiedIdeographs>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3613]"  ~~ m/^<:!InCJKUnifiedIdeographs>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3613]"  ~~ m/^<-:InCJKUnifiedIdeographs>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3613]\x[4E00]" ~~ m/<:InCJKUnifiedIdeographs>/, q{Match unanchored } );

# InCJKUnifiedIdeographsExtensionA


#?pugs todo
ok("\x[3400]" ~~ m/^<:InCJKUnifiedIdeographsExtensionA>$/, q{Match <:InCJKUnifiedIdeographsExtensionA>} );
ok(!( "\x[3400]" ~~ m/^<:!InCJKUnifiedIdeographsExtensionA>$/ ), q{Don't match negated } );
ok(!( "\x[3400]" ~~ m/^<-:InCJKUnifiedIdeographsExtensionA>$/ ), q{Don't match inverted } );
ok(!( "\c[SQUARE HOORU]"  ~~ m/^<:InCJKUnifiedIdeographsExtensionA>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[SQUARE HOORU]"  ~~ m/^<:!InCJKUnifiedIdeographsExtensionA>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[SQUARE HOORU]"  ~~ m/^<-:InCJKUnifiedIdeographsExtensionA>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[SQUARE HOORU]\x[3400]" ~~ m/<:InCJKUnifiedIdeographsExtensionA>/, q{Match unanchored } );

# InCJKUnifiedIdeographsExtensionB


ok(!( "\x[AC3B]"  ~~ m/^<:InCJKUnifiedIdeographsExtensionB>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[AC3B]"  ~~ m/^<:!InCJKUnifiedIdeographsExtensionB>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[AC3B]"  ~~ m/^<-:InCJKUnifiedIdeographsExtensionB>$/, q{Match unrelated inverted } );

# InCherokee


#?pugs todo
ok("\c[CHEROKEE LETTER A]" ~~ m/^<:InCherokee>$/, q{Match <:InCherokee>} );
ok(!( "\c[CHEROKEE LETTER A]" ~~ m/^<:!InCherokee>$/ ), q{Don't match negated } );
ok(!( "\c[CHEROKEE LETTER A]" ~~ m/^<-:InCherokee>$/ ), q{Don't match inverted } );
ok(!( "\x[985F]"  ~~ m/^<:InCherokee>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[985F]"  ~~ m/^<:!InCherokee>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[985F]"  ~~ m/^<-:InCherokee>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[985F]\c[CHEROKEE LETTER A]" ~~ m/<:InCherokee>/, q{Match unanchored } );

# InCombiningDiacriticalMarks


#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:InCombiningDiacriticalMarks>$/, q{Match <:InCombiningDiacriticalMarks>} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!InCombiningDiacriticalMarks>$/ ), q{Don't match negated } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:InCombiningDiacriticalMarks>$/ ), q{Don't match inverted } );
ok(!( "\x[76DA]"  ~~ m/^<:InCombiningDiacriticalMarks>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[76DA]"  ~~ m/^<:!InCombiningDiacriticalMarks>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[76DA]"  ~~ m/^<-:InCombiningDiacriticalMarks>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[76DA]\c[COMBINING GRAVE ACCENT]" ~~ m/<:InCombiningDiacriticalMarks>/, q{Match unanchored } );

# InCombiningDiacriticalMarksforSymbols


#?pugs todo
ok("\c[COMBINING LEFT HARPOON ABOVE]" ~~ m/^<:InCombiningDiacriticalMarksforSymbols>$/, q{Match <:InCombiningDiacriticalMarksforSymbols>} );
ok(!( "\c[COMBINING LEFT HARPOON ABOVE]" ~~ m/^<:!InCombiningDiacriticalMarksforSymbols>$/ ), q{Don't match negated } );
ok(!( "\c[COMBINING LEFT HARPOON ABOVE]" ~~ m/^<-:InCombiningDiacriticalMarksforSymbols>$/ ), q{Don't match inverted } );
ok(!( "\x[7345]"  ~~ m/^<:InCombiningDiacriticalMarksforSymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7345]"  ~~ m/^<:!InCombiningDiacriticalMarksforSymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7345]"  ~~ m/^<-:InCombiningDiacriticalMarksforSymbols>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7345]\c[COMBINING LEFT HARPOON ABOVE]" ~~ m/<:InCombiningDiacriticalMarksforSymbols>/, q{Match unanchored } );

# InCombiningHalfMarks


ok(!( "\x[6C2E]"  ~~ m/^<:InCombiningHalfMarks>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[6C2E]"  ~~ m/^<:!InCombiningHalfMarks>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[6C2E]"  ~~ m/^<-:InCombiningHalfMarks>$/, q{Match unrelated inverted } );

# InControlPictures


#?pugs todo
ok("\c[SYMBOL FOR NULL]" ~~ m/^<:InControlPictures>$/, q{Match <:InControlPictures>} );
ok(!( "\c[SYMBOL FOR NULL]" ~~ m/^<:!InControlPictures>$/ ), q{Don't match negated } );
ok(!( "\c[SYMBOL FOR NULL]" ~~ m/^<-:InControlPictures>$/ ), q{Don't match inverted } );
ok(!( "\x[BCE2]"  ~~ m/^<:InControlPictures>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BCE2]"  ~~ m/^<:!InControlPictures>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BCE2]"  ~~ m/^<-:InControlPictures>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BCE2]\c[SYMBOL FOR NULL]" ~~ m/<:InControlPictures>/, q{Match unanchored } );

# InCurrencySymbols


#?pugs todo
ok("\c[EURO-CURRENCY SIGN]" ~~ m/^<:InCurrencySymbols>$/, q{Match <:InCurrencySymbols>} );
ok(!( "\c[EURO-CURRENCY SIGN]" ~~ m/^<:!InCurrencySymbols>$/ ), q{Don't match negated } );
ok(!( "\c[EURO-CURRENCY SIGN]" ~~ m/^<-:InCurrencySymbols>$/ ), q{Don't match inverted } );
ok(!( "\x[8596]"  ~~ m/^<:InCurrencySymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8596]"  ~~ m/^<:!InCurrencySymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8596]"  ~~ m/^<-:InCurrencySymbols>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[8596]\c[EURO-CURRENCY SIGN]" ~~ m/<:InCurrencySymbols>/, q{Match unanchored } );

# InCyrillic


#?pugs todo
ok("\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/^<:InCyrillic>$/, q{Match <:InCyrillic>} );
ok(!( "\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/^<:!InCyrillic>$/ ), q{Don't match negated } );
ok(!( "\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/^<-:InCyrillic>$/ ), q{Don't match inverted } );
ok(!( "\x[51B2]"  ~~ m/^<:InCyrillic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[51B2]"  ~~ m/^<:!InCyrillic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[51B2]"  ~~ m/^<-:InCyrillic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[51B2]\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/<:InCyrillic>/, q{Match unanchored } );

# InCyrillicSupplementary


#?pugs todo
ok("\c[CYRILLIC CAPITAL LETTER KOMI DE]" ~~ m/^<:InCyrillicSupplementary>$/, q{Match <:InCyrillicSupplementary>} );
ok(!( "\c[CYRILLIC CAPITAL LETTER KOMI DE]" ~~ m/^<:!InCyrillicSupplementary>$/ ), q{Don't match negated } );
ok(!( "\c[CYRILLIC CAPITAL LETTER KOMI DE]" ~~ m/^<-:InCyrillicSupplementary>$/ ), q{Don't match inverted } );
ok(!( "\x[7BD9]"  ~~ m/^<:InCyrillicSupplementary>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7BD9]"  ~~ m/^<:!InCyrillicSupplementary>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7BD9]"  ~~ m/^<-:InCyrillicSupplementary>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7BD9]\c[CYRILLIC CAPITAL LETTER KOMI DE]" ~~ m/<:InCyrillicSupplementary>/, q{Match unanchored } );

# InDeseret


ok(!( "\c[TAMIL DIGIT FOUR]"  ~~ m/^<:InDeseret>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[TAMIL DIGIT FOUR]"  ~~ m/^<:!InDeseret>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[TAMIL DIGIT FOUR]"  ~~ m/^<-:InDeseret>$/, q{Match unrelated inverted } );

# InDevanagari


#?pugs todo
ok("\x[0900]" ~~ m/^<:InDevanagari>$/, q{Match <:InDevanagari>} );
ok(!( "\x[0900]" ~~ m/^<:!InDevanagari>$/ ), q{Don't match negated } );
ok(!( "\x[0900]" ~~ m/^<-:InDevanagari>$/ ), q{Don't match inverted } );
ok(!( "\x[BB12]"  ~~ m/^<:InDevanagari>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BB12]"  ~~ m/^<:!InDevanagari>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BB12]"  ~~ m/^<-:InDevanagari>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BB12]\x[0900]" ~~ m/<:InDevanagari>/, q{Match unanchored } );

# InDingbats


#?pugs todo
ok("\x[2700]" ~~ m/^<:InDingbats>$/, q{Match <:InDingbats>} );
ok(!( "\x[2700]" ~~ m/^<:!InDingbats>$/ ), q{Don't match negated } );
ok(!( "\x[2700]" ~~ m/^<-:InDingbats>$/ ), q{Don't match inverted } );
ok(!( "\x[D7A8]"  ~~ m/^<:InDingbats>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D7A8]"  ~~ m/^<:!InDingbats>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D7A8]"  ~~ m/^<-:InDingbats>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D7A8]\x[2700]" ~~ m/<:InDingbats>/, q{Match unanchored } );

# InEnclosedAlphanumerics


#?pugs todo
ok("\c[CIRCLED DIGIT ONE]" ~~ m/^<:InEnclosedAlphanumerics>$/, q{Match <:InEnclosedAlphanumerics>} );
ok(!( "\c[CIRCLED DIGIT ONE]" ~~ m/^<:!InEnclosedAlphanumerics>$/ ), q{Don't match negated } );
ok(!( "\c[CIRCLED DIGIT ONE]" ~~ m/^<-:InEnclosedAlphanumerics>$/ ), q{Don't match inverted } );
ok(!( "\x[C3A2]"  ~~ m/^<:InEnclosedAlphanumerics>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C3A2]"  ~~ m/^<:!InEnclosedAlphanumerics>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C3A2]"  ~~ m/^<-:InEnclosedAlphanumerics>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[C3A2]\c[CIRCLED DIGIT ONE]" ~~ m/<:InEnclosedAlphanumerics>/, q{Match unanchored } );

# InEnclosedCJKLettersAndMonths


#?pugs todo
ok("\c[PARENTHESIZED HANGUL KIYEOK]" ~~ m/^<:InEnclosedCJKLettersAndMonths>$/, q{Match <:InEnclosedCJKLettersAndMonths>} );
ok(!( "\c[PARENTHESIZED HANGUL KIYEOK]" ~~ m/^<:!InEnclosedCJKLettersAndMonths>$/ ), q{Don't match negated } );
ok(!( "\c[PARENTHESIZED HANGUL KIYEOK]" ~~ m/^<-:InEnclosedCJKLettersAndMonths>$/ ), q{Don't match inverted } );
ok(!( "\x[5B44]"  ~~ m/^<:InEnclosedCJKLettersAndMonths>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5B44]"  ~~ m/^<:!InEnclosedCJKLettersAndMonths>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5B44]"  ~~ m/^<-:InEnclosedCJKLettersAndMonths>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[5B44]\c[PARENTHESIZED HANGUL KIYEOK]" ~~ m/<:InEnclosedCJKLettersAndMonths>/, q{Match unanchored } );

# InEthiopic


#?pugs todo
ok("\c[ETHIOPIC SYLLABLE HA]" ~~ m/^<:InEthiopic>$/, q{Match <:InEthiopic>} );
ok(!( "\c[ETHIOPIC SYLLABLE HA]" ~~ m/^<:!InEthiopic>$/ ), q{Don't match negated } );
ok(!( "\c[ETHIOPIC SYLLABLE HA]" ~~ m/^<-:InEthiopic>$/ ), q{Don't match inverted } );
ok(!( "\x[BBAE]"  ~~ m/^<:InEthiopic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BBAE]"  ~~ m/^<:!InEthiopic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BBAE]"  ~~ m/^<-:InEthiopic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BBAE]\c[ETHIOPIC SYLLABLE HA]" ~~ m/<:InEthiopic>/, q{Match unanchored } );

# InGeneralPunctuation


#?pugs todo
ok("\c[EN QUAD]" ~~ m/^<:InGeneralPunctuation>$/, q{Match <:InGeneralPunctuation>} );
ok(!( "\c[EN QUAD]" ~~ m/^<:!InGeneralPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[EN QUAD]" ~~ m/^<-:InGeneralPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\c[MEDIUM RIGHT PARENTHESIS ORNAMENT]"  ~~ m/^<:InGeneralPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[MEDIUM RIGHT PARENTHESIS ORNAMENT]"  ~~ m/^<:!InGeneralPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[MEDIUM RIGHT PARENTHESIS ORNAMENT]"  ~~ m/^<-:InGeneralPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[MEDIUM RIGHT PARENTHESIS ORNAMENT]\c[EN QUAD]" ~~ m/<:InGeneralPunctuation>/, q{Match unanchored } );

# InGeometricShapes


#?pugs todo
ok("\c[BLACK SQUARE]" ~~ m/^<:InGeometricShapes>$/, q{Match <:InGeometricShapes>} );
ok(!( "\c[BLACK SQUARE]" ~~ m/^<:!InGeometricShapes>$/ ), q{Don't match negated } );
ok(!( "\c[BLACK SQUARE]" ~~ m/^<-:InGeometricShapes>$/ ), q{Don't match inverted } );
ok(!( "\x[B700]"  ~~ m/^<:InGeometricShapes>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B700]"  ~~ m/^<:!InGeometricShapes>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B700]"  ~~ m/^<-:InGeometricShapes>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[B700]\c[BLACK SQUARE]" ~~ m/<:InGeometricShapes>/, q{Match unanchored } );


# InGeorgian


#?pugs todo
ok("\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/^<:InGeorgian>$/, q{Match <:InGeorgian>} );
ok(!( "\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/^<:!InGeorgian>$/ ), q{Don't match negated } );
ok(!( "\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/^<-:InGeorgian>$/ ), q{Don't match inverted } );
ok(!( "\c[IDEOGRAPHIC TELEGRAPH SYMBOL FOR HOUR ONE]"  ~~ m/^<:InGeorgian>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[IDEOGRAPHIC TELEGRAPH SYMBOL FOR HOUR ONE]"  ~~ m/^<:!InGeorgian>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[IDEOGRAPHIC TELEGRAPH SYMBOL FOR HOUR ONE]"  ~~ m/^<-:InGeorgian>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[IDEOGRAPHIC TELEGRAPH SYMBOL FOR HOUR ONE]\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/<:InGeorgian>/, q{Match unanchored } );

# InGothic


ok(!( "\x[4825]"  ~~ m/^<:InGothic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4825]"  ~~ m/^<:!InGothic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4825]"  ~~ m/^<-:InGothic>$/, q{Match unrelated inverted } );

# InGreekExtended


#?pugs todo
ok("\c[GREEK SMALL LETTER ALPHA WITH PSILI]" ~~ m/^<:InGreekExtended>$/, q{Match <:InGreekExtended>} );
ok(!( "\c[GREEK SMALL LETTER ALPHA WITH PSILI]" ~~ m/^<:!InGreekExtended>$/ ), q{Don't match negated } );
ok(!( "\c[GREEK SMALL LETTER ALPHA WITH PSILI]" ~~ m/^<-:InGreekExtended>$/ ), q{Don't match inverted } );
ok(!( "\x[B9B7]"  ~~ m/^<:InGreekExtended>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B9B7]"  ~~ m/^<:!InGreekExtended>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B9B7]"  ~~ m/^<-:InGreekExtended>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[B9B7]\c[GREEK SMALL LETTER ALPHA WITH PSILI]" ~~ m/<:InGreekExtended>/, q{Match unanchored } );

# InGreekAndCoptic


#?pugs todo
ok("\x[0370]" ~~ m/^<:InGreekAndCoptic>$/, q{Match <:InGreekAndCoptic>} );
ok(!( "\x[0370]" ~~ m/^<:!InGreekAndCoptic>$/ ), q{Don't match negated } );
ok(!( "\x[0370]" ~~ m/^<-:InGreekAndCoptic>$/ ), q{Don't match inverted } );
ok(!( "\x[7197]"  ~~ m/^<:InGreekAndCoptic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7197]"  ~~ m/^<:!InGreekAndCoptic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7197]"  ~~ m/^<-:InGreekAndCoptic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7197]\x[0370]" ~~ m/<:InGreekAndCoptic>/, q{Match unanchored } );

# InGujarati


#?pugs todo
ok("\x[0A80]" ~~ m/^<:InGujarati>$/, q{Match <:InGujarati>} );
ok(!( "\x[0A80]" ~~ m/^<:!InGujarati>$/ ), q{Don't match negated } );
ok(!( "\x[0A80]" ~~ m/^<-:InGujarati>$/ ), q{Don't match inverted } );
ok(!( "\x[3B63]"  ~~ m/^<:InGujarati>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3B63]"  ~~ m/^<:!InGujarati>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3B63]"  ~~ m/^<-:InGujarati>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3B63]\x[0A80]" ~~ m/<:InGujarati>/, q{Match unanchored } );

# InGurmukhi


#?pugs todo
ok("\x[0A00]" ~~ m/^<:InGurmukhi>$/, q{Match <:InGurmukhi>} );
ok(!( "\x[0A00]" ~~ m/^<:!InGurmukhi>$/ ), q{Don't match negated } );
ok(!( "\x[0A00]" ~~ m/^<-:InGurmukhi>$/ ), q{Don't match inverted } );
ok(!( "\x[10C8]"  ~~ m/^<:InGurmukhi>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[10C8]"  ~~ m/^<:!InGurmukhi>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[10C8]"  ~~ m/^<-:InGurmukhi>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[10C8]\x[0A00]" ~~ m/<:InGurmukhi>/, q{Match unanchored } );

# InHalfwidthAndFullwidthForms


ok(!( "\x[CA55]"  ~~ m/^<:InHalfwidthAndFullwidthForms>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[CA55]"  ~~ m/^<:!InHalfwidthAndFullwidthForms>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[CA55]"  ~~ m/^<-:InHalfwidthAndFullwidthForms>$/, q{Match unrelated inverted } );

# InHangulCompatibilityJamo


#?pugs todo
ok("\x[3130]" ~~ m/^<:InHangulCompatibilityJamo>$/, q{Match <:InHangulCompatibilityJamo>} );
ok(!( "\x[3130]" ~~ m/^<:!InHangulCompatibilityJamo>$/ ), q{Don't match negated } );
ok(!( "\x[3130]" ~~ m/^<-:InHangulCompatibilityJamo>$/ ), q{Don't match inverted } );
ok(!( "\c[MEASURED BY]"  ~~ m/^<:InHangulCompatibilityJamo>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[MEASURED BY]"  ~~ m/^<:!InHangulCompatibilityJamo>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[MEASURED BY]"  ~~ m/^<-:InHangulCompatibilityJamo>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[MEASURED BY]\x[3130]" ~~ m/<:InHangulCompatibilityJamo>/, q{Match unanchored } );

# InHangulJamo


#?pugs todo
ok("\c[HANGUL CHOSEONG KIYEOK]" ~~ m/^<:InHangulJamo>$/, q{Match <:InHangulJamo>} );
ok(!( "\c[HANGUL CHOSEONG KIYEOK]" ~~ m/^<:!InHangulJamo>$/ ), q{Don't match negated } );
ok(!( "\c[HANGUL CHOSEONG KIYEOK]" ~~ m/^<-:InHangulJamo>$/ ), q{Don't match inverted } );
ok(!( "\x[3B72]"  ~~ m/^<:InHangulJamo>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3B72]"  ~~ m/^<:!InHangulJamo>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3B72]"  ~~ m/^<-:InHangulJamo>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3B72]\c[HANGUL CHOSEONG KIYEOK]" ~~ m/<:InHangulJamo>/, q{Match unanchored } );

# InHangulSyllables


#?pugs todo
ok("\x[CD95]" ~~ m/^<:InHangulSyllables>$/, q{Match <:InHangulSyllables>} );
ok(!( "\x[CD95]" ~~ m/^<:!InHangulSyllables>$/ ), q{Don't match negated } );
ok(!( "\x[CD95]" ~~ m/^<-:InHangulSyllables>$/ ), q{Don't match inverted } );
ok(!( "\x[D7B0]"  ~~ m/^<:InHangulSyllables>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D7B0]"  ~~ m/^<:!InHangulSyllables>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D7B0]"  ~~ m/^<-:InHangulSyllables>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D7B0]\x[CD95]" ~~ m/<:InHangulSyllables>/, q{Match unanchored } );

# InHanunoo


#?pugs todo
ok("\c[HANUNOO LETTER A]" ~~ m/^<:InHanunoo>$/, q{Match <:InHanunoo>} );
ok(!( "\c[HANUNOO LETTER A]" ~~ m/^<:!InHanunoo>$/ ), q{Don't match negated } );
ok(!( "\c[HANUNOO LETTER A]" ~~ m/^<-:InHanunoo>$/ ), q{Don't match inverted } );
ok(!( "\x[6F4F]"  ~~ m/^<:InHanunoo>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[6F4F]"  ~~ m/^<:!InHanunoo>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[6F4F]"  ~~ m/^<-:InHanunoo>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[6F4F]\c[HANUNOO LETTER A]" ~~ m/<:InHanunoo>/, q{Match unanchored } );

# InHebrew


#?pugs todo
ok("\x[0590]" ~~ m/^<:InHebrew>$/, q{Match <:InHebrew>} );
ok(!( "\x[0590]" ~~ m/^<:!InHebrew>$/ ), q{Don't match negated } );
ok(!( "\x[0590]" ~~ m/^<-:InHebrew>$/ ), q{Don't match inverted } );
ok(!( "\x[0777]"  ~~ m/^<:InHebrew>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[0777]"  ~~ m/^<:!InHebrew>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[0777]"  ~~ m/^<-:InHebrew>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[0777]\x[0590]" ~~ m/<:InHebrew>/, q{Match unanchored } );

# InHighPrivateUseSurrogates


ok(!( "\x[D04F]"  ~~ m/^<:InHighPrivateUseSurrogates>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D04F]"  ~~ m/^<:!InHighPrivateUseSurrogates>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D04F]"  ~~ m/^<-:InHighPrivateUseSurrogates>$/, q{Match unrelated inverted } );

# InHighSurrogates


ok(!( "\x[D085]"  ~~ m/^<:InHighSurrogates>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D085]"  ~~ m/^<:!InHighSurrogates>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D085]"  ~~ m/^<-:InHighSurrogates>$/, q{Match unrelated inverted } );

# InHiragana


#?pugs todo
ok("\x[3040]" ~~ m/^<:InHiragana>$/, q{Match <:InHiragana>} );
ok(!( "\x[3040]" ~~ m/^<:!InHiragana>$/ ), q{Don't match negated } );
ok(!( "\x[3040]" ~~ m/^<-:InHiragana>$/ ), q{Don't match inverted } );
ok(!( "\x[AC7C]"  ~~ m/^<:InHiragana>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[AC7C]"  ~~ m/^<:!InHiragana>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[AC7C]"  ~~ m/^<-:InHiragana>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[AC7C]\x[3040]" ~~ m/<:InHiragana>/, q{Match unanchored } );

# InIPAExtensions


#?pugs todo
ok("\c[LATIN SMALL LETTER TURNED A]" ~~ m/^<:InIPAExtensions>$/, q{Match <:InIPAExtensions>} );
ok(!( "\c[LATIN SMALL LETTER TURNED A]" ~~ m/^<:!InIPAExtensions>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN SMALL LETTER TURNED A]" ~~ m/^<-:InIPAExtensions>$/ ), q{Don't match inverted } );
ok(!( "\c[HANGUL LETTER SSANGIEUNG]"  ~~ m/^<:InIPAExtensions>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[HANGUL LETTER SSANGIEUNG]"  ~~ m/^<:!InIPAExtensions>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[HANGUL LETTER SSANGIEUNG]"  ~~ m/^<-:InIPAExtensions>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[HANGUL LETTER SSANGIEUNG]\c[LATIN SMALL LETTER TURNED A]" ~~ m/<:InIPAExtensions>/, q{Match unanchored } );

# InIdeographicDescriptionCharacters


#?pugs todo
ok("\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/^<:InIdeographicDescriptionCharacters>$/, q{Match <:InIdeographicDescriptionCharacters>} );
ok(!( "\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/^<:!InIdeographicDescriptionCharacters>$/ ), q{Don't match negated } );
ok(!( "\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/^<-:InIdeographicDescriptionCharacters>$/ ), q{Don't match inverted } );
ok(!( "\x[9160]"  ~~ m/^<:InIdeographicDescriptionCharacters>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9160]"  ~~ m/^<:!InIdeographicDescriptionCharacters>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9160]"  ~~ m/^<-:InIdeographicDescriptionCharacters>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9160]\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/<:InIdeographicDescriptionCharacters>/, q{Match unanchored } );

# InKanbun


#?pugs todo
ok("\c[IDEOGRAPHIC ANNOTATION LINKING MARK]" ~~ m/^<:InKanbun>$/, q{Match <:InKanbun>} );
ok(!( "\c[IDEOGRAPHIC ANNOTATION LINKING MARK]" ~~ m/^<:!InKanbun>$/ ), q{Don't match negated } );
ok(!( "\c[IDEOGRAPHIC ANNOTATION LINKING MARK]" ~~ m/^<-:InKanbun>$/ ), q{Don't match inverted } );
ok(!( "\x[A80C]"  ~~ m/^<:InKanbun>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[A80C]"  ~~ m/^<:!InKanbun>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[A80C]"  ~~ m/^<-:InKanbun>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[A80C]\c[IDEOGRAPHIC ANNOTATION LINKING MARK]" ~~ m/<:InKanbun>/, q{Match unanchored } );

# InKangxiRadicals


#?pugs todo
ok("\c[KANGXI RADICAL ONE]" ~~ m/^<:InKangxiRadicals>$/, q{Match <:InKangxiRadicals>} );
ok(!( "\c[KANGXI RADICAL ONE]" ~~ m/^<:!InKangxiRadicals>$/ ), q{Don't match negated } );
ok(!( "\c[KANGXI RADICAL ONE]" ~~ m/^<-:InKangxiRadicals>$/ ), q{Don't match inverted } );
ok(!( "\x[891A]"  ~~ m/^<:InKangxiRadicals>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[891A]"  ~~ m/^<:!InKangxiRadicals>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[891A]"  ~~ m/^<-:InKangxiRadicals>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[891A]\c[KANGXI RADICAL ONE]" ~~ m/<:InKangxiRadicals>/, q{Match unanchored } );

# InKannada


#?pugs todo
ok("\x[0C80]" ~~ m/^<:InKannada>$/, q{Match <:InKannada>} );
ok(!( "\x[0C80]" ~~ m/^<:!InKannada>$/ ), q{Don't match negated } );
ok(!( "\x[0C80]" ~~ m/^<-:InKannada>$/ ), q{Don't match inverted } );
ok(!( "\x[B614]"  ~~ m/^<:InKannada>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B614]"  ~~ m/^<:!InKannada>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B614]"  ~~ m/^<-:InKannada>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[B614]\x[0C80]" ~~ m/<:InKannada>/, q{Match unanchored } );

# InKatakana


#?pugs todo
ok("\c[KATAKANA-HIRAGANA DOUBLE HYPHEN]" ~~ m/^<:InKatakana>$/, q{Match <:InKatakana>} );
ok(!( "\c[KATAKANA-HIRAGANA DOUBLE HYPHEN]" ~~ m/^<:!InKatakana>$/ ), q{Don't match negated } );
ok(!( "\c[KATAKANA-HIRAGANA DOUBLE HYPHEN]" ~~ m/^<-:InKatakana>$/ ), q{Don't match inverted } );
ok(!( "\x[7EB8]"  ~~ m/^<:InKatakana>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7EB8]"  ~~ m/^<:!InKatakana>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7EB8]"  ~~ m/^<-:InKatakana>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7EB8]\c[KATAKANA-HIRAGANA DOUBLE HYPHEN]" ~~ m/<:InKatakana>/, q{Match unanchored } );

# InKatakanaPhoneticExtensions


#?pugs todo
ok("\c[KATAKANA LETTER SMALL KU]" ~~ m/^<:InKatakanaPhoneticExtensions>$/, q{Match <:InKatakanaPhoneticExtensions>} );
ok(!( "\c[KATAKANA LETTER SMALL KU]" ~~ m/^<:!InKatakanaPhoneticExtensions>$/ ), q{Don't match negated } );
ok(!( "\c[KATAKANA LETTER SMALL KU]" ~~ m/^<-:InKatakanaPhoneticExtensions>$/ ), q{Don't match inverted } );
ok(!( "\x[97C2]"  ~~ m/^<:InKatakanaPhoneticExtensions>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[97C2]"  ~~ m/^<:!InKatakanaPhoneticExtensions>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[97C2]"  ~~ m/^<-:InKatakanaPhoneticExtensions>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[97C2]\c[KATAKANA LETTER SMALL KU]" ~~ m/<:InKatakanaPhoneticExtensions>/, q{Match unanchored } );

# InKhmer

#?pugs todo
ok("\c[KHMER LETTER KA]" ~~ m/^<:InKhmer>$/, q{Match <:InKhmer>} );
ok(!( "\c[KHMER LETTER KA]" ~~ m/^<:!InKhmer>$/ ), q{Don't match negated } );
ok(!( "\c[KHMER LETTER KA]" ~~ m/^<-:InKhmer>$/ ), q{Don't match inverted } );
ok(!( "\x[CAFA]"  ~~ m/^<:InKhmer>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[CAFA]"  ~~ m/^<:!InKhmer>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[CAFA]"  ~~ m/^<-:InKhmer>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[CAFA]\c[KHMER LETTER KA]" ~~ m/<:InKhmer>/, q{Match unanchored } );

# InLao


#?pugs todo
ok("\x[0E80]" ~~ m/^<:InLao>$/, q{Match <:InLao>} );
ok(!( "\x[0E80]" ~~ m/^<:!InLao>$/ ), q{Don't match negated } );
ok(!( "\x[0E80]" ~~ m/^<-:InLao>$/ ), q{Don't match inverted } );
ok(!( "\x[07BF]"  ~~ m/^<:InLao>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[07BF]"  ~~ m/^<:!InLao>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[07BF]"  ~~ m/^<-:InLao>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[07BF]\x[0E80]" ~~ m/<:InLao>/, q{Match unanchored } );

# InLatin1Supplement


#?pugs todo
ok("\x[0080]" ~~ m/^<:InLatin1Supplement>$/, q{Match <:InLatin1Supplement>} );
ok(!( "\x[0080]" ~~ m/^<:!InLatin1Supplement>$/ ), q{Don't match negated } );
ok(!( "\x[0080]" ~~ m/^<-:InLatin1Supplement>$/ ), q{Don't match inverted } );
ok(!( "\x[D062]"  ~~ m/^<:InLatin1Supplement>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D062]"  ~~ m/^<:!InLatin1Supplement>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D062]"  ~~ m/^<-:InLatin1Supplement>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D062]\x[0080]" ~~ m/<:InLatin1Supplement>/, q{Match unanchored } );

# InLatinExtendedA


#?pugs todo
ok("\c[LATIN CAPITAL LETTER A WITH MACRON]" ~~ m/^<:InLatinExtendedA>$/, q{Match <:InLatinExtendedA>} );
ok(!( "\c[LATIN CAPITAL LETTER A WITH MACRON]" ~~ m/^<:!InLatinExtendedA>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN CAPITAL LETTER A WITH MACRON]" ~~ m/^<-:InLatinExtendedA>$/ ), q{Don't match inverted } );
ok(!( "\c[IDEOGRAPHIC ANNOTATION EARTH MARK]"  ~~ m/^<:InLatinExtendedA>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[IDEOGRAPHIC ANNOTATION EARTH MARK]"  ~~ m/^<:!InLatinExtendedA>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[IDEOGRAPHIC ANNOTATION EARTH MARK]"  ~~ m/^<-:InLatinExtendedA>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[IDEOGRAPHIC ANNOTATION EARTH MARK]\c[LATIN CAPITAL LETTER A WITH MACRON]" ~~ m/<:InLatinExtendedA>/, q{Match unanchored } );

# InLatinExtendedAdditional


#?pugs todo
ok("\c[LATIN CAPITAL LETTER A WITH RING BELOW]" ~~ m/^<:InLatinExtendedAdditional>$/, q{Match <:InLatinExtendedAdditional>} );
ok(!( "\c[LATIN CAPITAL LETTER A WITH RING BELOW]" ~~ m/^<:!InLatinExtendedAdditional>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN CAPITAL LETTER A WITH RING BELOW]" ~~ m/^<-:InLatinExtendedAdditional>$/ ), q{Don't match inverted } );
ok(!( "\x[9A44]"  ~~ m/^<:InLatinExtendedAdditional>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9A44]"  ~~ m/^<:!InLatinExtendedAdditional>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9A44]"  ~~ m/^<-:InLatinExtendedAdditional>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9A44]\c[LATIN CAPITAL LETTER A WITH RING BELOW]" ~~ m/<:InLatinExtendedAdditional>/, q{Match unanchored } );

# InLatinExtendedB


#?pugs todo
ok("\c[LATIN SMALL LETTER B WITH STROKE]" ~~ m/^<:InLatinExtendedB>$/, q{Match <:InLatinExtendedB>} );
ok(!( "\c[LATIN SMALL LETTER B WITH STROKE]" ~~ m/^<:!InLatinExtendedB>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN SMALL LETTER B WITH STROKE]" ~~ m/^<-:InLatinExtendedB>$/ ), q{Don't match inverted } );
ok(!( "\x[7544]"  ~~ m/^<:InLatinExtendedB>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7544]"  ~~ m/^<:!InLatinExtendedB>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7544]"  ~~ m/^<-:InLatinExtendedB>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7544]\c[LATIN SMALL LETTER B WITH STROKE]" ~~ m/<:InLatinExtendedB>/, q{Match unanchored } );

# InLetterlikeSymbols


#?pugs todo
ok("\c[ACCOUNT OF]" ~~ m/^<:InLetterlikeSymbols>$/, q{Match <:InLetterlikeSymbols>} );
ok(!( "\c[ACCOUNT OF]" ~~ m/^<:!InLetterlikeSymbols>$/ ), q{Don't match negated } );
ok(!( "\c[ACCOUNT OF]" ~~ m/^<-:InLetterlikeSymbols>$/ ), q{Don't match inverted } );
ok(!( "\c[LATIN CAPITAL LETTER X WITH DOT ABOVE]"  ~~ m/^<:InLetterlikeSymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[LATIN CAPITAL LETTER X WITH DOT ABOVE]"  ~~ m/^<:!InLetterlikeSymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[LATIN CAPITAL LETTER X WITH DOT ABOVE]"  ~~ m/^<-:InLetterlikeSymbols>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[LATIN CAPITAL LETTER X WITH DOT ABOVE]\c[ACCOUNT OF]" ~~ m/<:InLetterlikeSymbols>/, q{Match unanchored } );

# InLowSurrogates


ok(!( "\x[5ECC]"  ~~ m/^<:InLowSurrogates>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5ECC]"  ~~ m/^<:!InLowSurrogates>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5ECC]"  ~~ m/^<-:InLowSurrogates>$/, q{Match unrelated inverted } );

# InMalayalam


#?pugs todo
ok("\x[0D00]" ~~ m/^<:InMalayalam>$/, q{Match <:InMalayalam>} );
ok(!( "\x[0D00]" ~~ m/^<:!InMalayalam>$/ ), q{Don't match negated } );
ok(!( "\x[0D00]" ~~ m/^<-:InMalayalam>$/ ), q{Don't match inverted } );
ok(!( "\x[3457]"  ~~ m/^<:InMalayalam>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3457]"  ~~ m/^<:!InMalayalam>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3457]"  ~~ m/^<-:InMalayalam>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3457]\x[0D00]" ~~ m/<:InMalayalam>/, q{Match unanchored } );

# InMathematicalAlphanumericSymbols


ok(!( "\x[6B79]"  ~~ m/^<:InMathematicalAlphanumericSymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[6B79]"  ~~ m/^<:!InMathematicalAlphanumericSymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[6B79]"  ~~ m/^<-:InMathematicalAlphanumericSymbols>$/, q{Match unrelated inverted } );

# InMathematicalOperators


#?pugs todo
ok("\c[FOR ALL]" ~~ m/^<:InMathematicalOperators>$/, q{Match <:InMathematicalOperators>} );
ok(!( "\c[FOR ALL]" ~~ m/^<:!InMathematicalOperators>$/ ), q{Don't match negated } );
ok(!( "\c[FOR ALL]" ~~ m/^<-:InMathematicalOperators>$/ ), q{Don't match inverted } );
ok(!( "\x[BBC6]"  ~~ m/^<:InMathematicalOperators>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BBC6]"  ~~ m/^<:!InMathematicalOperators>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BBC6]"  ~~ m/^<-:InMathematicalOperators>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BBC6]\c[FOR ALL]" ~~ m/<:InMathematicalOperators>/, q{Match unanchored } );

# InMiscellaneousMathematicalSymbolsA


#?pugs todo
ok("\x[27C0]" ~~ m/^<:InMiscellaneousMathematicalSymbolsA>$/, q{Match <:InMiscellaneousMathematicalSymbolsA>} );
ok(!( "\x[27C0]" ~~ m/^<:!InMiscellaneousMathematicalSymbolsA>$/ ), q{Don't match negated } );
ok(!( "\x[27C0]" ~~ m/^<-:InMiscellaneousMathematicalSymbolsA>$/ ), q{Don't match inverted } );
ok(!( "\x[065D]"  ~~ m/^<:InMiscellaneousMathematicalSymbolsA>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[065D]"  ~~ m/^<:!InMiscellaneousMathematicalSymbolsA>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[065D]"  ~~ m/^<-:InMiscellaneousMathematicalSymbolsA>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[065D]\x[27C0]" ~~ m/<:InMiscellaneousMathematicalSymbolsA>/, q{Match unanchored } );

# InMiscellaneousMathematicalSymbolsB


#?pugs todo
ok("\c[TRIPLE VERTICAL BAR DELIMITER]" ~~ m/^<:InMiscellaneousMathematicalSymbolsB>$/, q{Match <:InMiscellaneousMathematicalSymbolsB>} );
ok(!( "\c[TRIPLE VERTICAL BAR DELIMITER]" ~~ m/^<:!InMiscellaneousMathematicalSymbolsB>$/ ), q{Don't match negated } );
ok(!( "\c[TRIPLE VERTICAL BAR DELIMITER]" ~~ m/^<-:InMiscellaneousMathematicalSymbolsB>$/ ), q{Don't match inverted } );
ok(!( "\x[56A6]"  ~~ m/^<:InMiscellaneousMathematicalSymbolsB>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[56A6]"  ~~ m/^<:!InMiscellaneousMathematicalSymbolsB>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[56A6]"  ~~ m/^<-:InMiscellaneousMathematicalSymbolsB>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[56A6]\c[TRIPLE VERTICAL BAR DELIMITER]" ~~ m/<:InMiscellaneousMathematicalSymbolsB>/, q{Match unanchored } );

# InMiscellaneousSymbols


#?pugs todo
ok("\c[BLACK SUN WITH RAYS]" ~~ m/^<:InMiscellaneousSymbols>$/, q{Match <:InMiscellaneousSymbols>} );
ok(!( "\c[BLACK SUN WITH RAYS]" ~~ m/^<:!InMiscellaneousSymbols>$/ ), q{Don't match negated } );
ok(!( "\c[BLACK SUN WITH RAYS]" ~~ m/^<-:InMiscellaneousSymbols>$/ ), q{Don't match inverted } );
ok(!( "\x[3EE7]"  ~~ m/^<:InMiscellaneousSymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3EE7]"  ~~ m/^<:!InMiscellaneousSymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3EE7]"  ~~ m/^<-:InMiscellaneousSymbols>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3EE7]\c[BLACK SUN WITH RAYS]" ~~ m/<:InMiscellaneousSymbols>/, q{Match unanchored } );

# InMiscellaneousTechnical


#?pugs todo
ok("\c[DIAMETER SIGN]" ~~ m/^<:InMiscellaneousTechnical>$/, q{Match <:InMiscellaneousTechnical>} );
ok(!( "\c[DIAMETER SIGN]" ~~ m/^<:!InMiscellaneousTechnical>$/ ), q{Don't match negated } );
ok(!( "\c[DIAMETER SIGN]" ~~ m/^<-:InMiscellaneousTechnical>$/ ), q{Don't match inverted } );
ok(!( "\x[2EFC]"  ~~ m/^<:InMiscellaneousTechnical>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[2EFC]"  ~~ m/^<:!InMiscellaneousTechnical>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[2EFC]"  ~~ m/^<-:InMiscellaneousTechnical>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[2EFC]\c[DIAMETER SIGN]" ~~ m/<:InMiscellaneousTechnical>/, q{Match unanchored } );

# InMongolian


#?pugs todo
ok("\c[MONGOLIAN BIRGA]" ~~ m/^<:InMongolian>$/, q{Match <:InMongolian>} );
ok(!( "\c[MONGOLIAN BIRGA]" ~~ m/^<:!InMongolian>$/ ), q{Don't match negated } );
ok(!( "\c[MONGOLIAN BIRGA]" ~~ m/^<-:InMongolian>$/ ), q{Don't match inverted } );
ok(!( "\x[AFB4]"  ~~ m/^<:InMongolian>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[AFB4]"  ~~ m/^<:!InMongolian>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[AFB4]"  ~~ m/^<-:InMongolian>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[AFB4]\c[MONGOLIAN BIRGA]" ~~ m/<:InMongolian>/, q{Match unanchored } );

# InMusicalSymbols


ok(!( "\x[0CE4]"  ~~ m/^<:InMusicalSymbols>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[0CE4]"  ~~ m/^<:!InMusicalSymbols>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[0CE4]"  ~~ m/^<-:InMusicalSymbols>$/, q{Match unrelated inverted } );

# InMyanmar


#?pugs todo
ok("\c[MYANMAR LETTER KA]" ~~ m/^<:InMyanmar>$/, q{Match <:InMyanmar>} );
ok(!( "\c[MYANMAR LETTER KA]" ~~ m/^<:!InMyanmar>$/ ), q{Don't match negated } );
ok(!( "\c[MYANMAR LETTER KA]" ~~ m/^<-:InMyanmar>$/ ), q{Don't match inverted } );
ok(!( "\x[1DDB]"  ~~ m/^<:InMyanmar>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[1DDB]"  ~~ m/^<:!InMyanmar>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[1DDB]"  ~~ m/^<-:InMyanmar>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[1DDB]\c[MYANMAR LETTER KA]" ~~ m/<:InMyanmar>/, q{Match unanchored } );

# InNumberForms

#?pugs todo
ok("\x[2150]" ~~ m/^<:InNumberForms>$/, q{Match <:InNumberForms>} );
ok(!( "\x[2150]" ~~ m/^<:!InNumberForms>$/ ), q{Don't match negated } );
ok(!( "\x[2150]" ~~ m/^<-:InNumberForms>$/ ), q{Don't match inverted } );
ok(!( "\c[BLACK RIGHT-POINTING SMALL TRIANGLE]"  ~~ m/^<:InNumberForms>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[BLACK RIGHT-POINTING SMALL TRIANGLE]"  ~~ m/^<:!InNumberForms>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[BLACK RIGHT-POINTING SMALL TRIANGLE]"  ~~ m/^<-:InNumberForms>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[BLACK RIGHT-POINTING SMALL TRIANGLE]\x[2150]" ~~ m/<:InNumberForms>/, q{Match unanchored } );

# InOgham


#?pugs todo
ok("\c[OGHAM SPACE MARK]" ~~ m/^<:InOgham>$/, q{Match <:InOgham>} );
ok(!( "\c[OGHAM SPACE MARK]" ~~ m/^<:!InOgham>$/ ), q{Don't match negated } );
ok(!( "\c[OGHAM SPACE MARK]" ~~ m/^<-:InOgham>$/ ), q{Don't match inverted } );
ok(!( "\x[768C]"  ~~ m/^<:InOgham>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[768C]"  ~~ m/^<:!InOgham>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[768C]"  ~~ m/^<-:InOgham>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[768C]\c[OGHAM SPACE MARK]" ~~ m/<:InOgham>/, q{Match unanchored } );

# InOldItalic


ok(!( "\x[C597]"  ~~ m/^<:InOldItalic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C597]"  ~~ m/^<:!InOldItalic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C597]"  ~~ m/^<-:InOldItalic>$/, q{Match unrelated inverted } );

# InOpticalCharacterRecognition


#?pugs todo
ok("\c[OCR HOOK]" ~~ m/^<:InOpticalCharacterRecognition>$/, q{Match <:InOpticalCharacterRecognition>} );
ok(!( "\c[OCR HOOK]" ~~ m/^<:!InOpticalCharacterRecognition>$/ ), q{Don't match negated } );
ok(!( "\c[OCR HOOK]" ~~ m/^<-:InOpticalCharacterRecognition>$/ ), q{Don't match inverted } );
ok(!( "\x[BE80]"  ~~ m/^<:InOpticalCharacterRecognition>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BE80]"  ~~ m/^<:!InOpticalCharacterRecognition>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BE80]"  ~~ m/^<-:InOpticalCharacterRecognition>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BE80]\c[OCR HOOK]" ~~ m/<:InOpticalCharacterRecognition>/, q{Match unanchored } );

# InOriya


#?pugs todo
ok("\x[0B00]" ~~ m/^<:InOriya>$/, q{Match <:InOriya>} );
ok(!( "\x[0B00]" ~~ m/^<:!InOriya>$/ ), q{Don't match negated } );
ok(!( "\x[0B00]" ~~ m/^<-:InOriya>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE GGEX]"  ~~ m/^<:InOriya>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE GGEX]"  ~~ m/^<:!InOriya>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE GGEX]"  ~~ m/^<-:InOriya>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE GGEX]\x[0B00]" ~~ m/<:InOriya>/, q{Match unanchored } );

# InPrivateUseArea


ok(!( "\x[B6B1]"  ~~ m/^<:InPrivateUseArea>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B6B1]"  ~~ m/^<:!InPrivateUseArea>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B6B1]"  ~~ m/^<-:InPrivateUseArea>$/, q{Match unrelated inverted } );

# InRunic


#?pugs todo
ok("\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/^<:InRunic>$/, q{Match <:InRunic>} );
ok(!( "\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/^<:!InRunic>$/ ), q{Don't match negated } );
ok(!( "\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/^<-:InRunic>$/ ), q{Don't match inverted } );
ok(!( "\c[SINHALA LETTER MAHAAPRAANA KAYANNA]"  ~~ m/^<:InRunic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[SINHALA LETTER MAHAAPRAANA KAYANNA]"  ~~ m/^<:!InRunic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[SINHALA LETTER MAHAAPRAANA KAYANNA]"  ~~ m/^<-:InRunic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[SINHALA LETTER MAHAAPRAANA KAYANNA]\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/<:InRunic>/, q{Match unanchored } );

# InSinhala


#?pugs todo
ok("\x[0D80]" ~~ m/^<:InSinhala>$/, q{Match <:InSinhala>} );
ok(!( "\x[0D80]" ~~ m/^<:!InSinhala>$/ ), q{Don't match negated } );
ok(!( "\x[0D80]" ~~ m/^<-:InSinhala>$/ ), q{Don't match inverted } );
ok(!( "\x[1060]"  ~~ m/^<:InSinhala>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[1060]"  ~~ m/^<:!InSinhala>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[1060]"  ~~ m/^<-:InSinhala>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[1060]\x[0D80]" ~~ m/<:InSinhala>/, q{Match unanchored } );

# InSmallFormVariants


ok(!( "\x[5285]"  ~~ m/^<:InSmallFormVariants>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5285]"  ~~ m/^<:!InSmallFormVariants>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5285]"  ~~ m/^<-:InSmallFormVariants>$/, q{Match unrelated inverted } );

# InSpacingModifierLetters


#?pugs todo
ok("\c[MODIFIER LETTER SMALL H]" ~~ m/^<:InSpacingModifierLetters>$/, q{Match <:InSpacingModifierLetters>} );
ok(!( "\c[MODIFIER LETTER SMALL H]" ~~ m/^<:!InSpacingModifierLetters>$/ ), q{Don't match negated } );
ok(!( "\c[MODIFIER LETTER SMALL H]" ~~ m/^<-:InSpacingModifierLetters>$/ ), q{Don't match inverted } );
ok(!( "\x[5326]"  ~~ m/^<:InSpacingModifierLetters>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5326]"  ~~ m/^<:!InSpacingModifierLetters>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5326]"  ~~ m/^<-:InSpacingModifierLetters>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[5326]\c[MODIFIER LETTER SMALL H]" ~~ m/<:InSpacingModifierLetters>/, q{Match unanchored } );

# InSpecials


ok(!( "\x[3DF1]"  ~~ m/^<:InSpecials>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3DF1]"  ~~ m/^<:!InSpecials>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3DF1]"  ~~ m/^<-:InSpecials>$/, q{Match unrelated inverted } );

# InSuperscriptsAndSubscripts


#?pugs todo
ok("\c[SUPERSCRIPT ZERO]" ~~ m/^<:InSuperscriptsAndSubscripts>$/, q{Match <:InSuperscriptsAndSubscripts>} );
ok(!( "\c[SUPERSCRIPT ZERO]" ~~ m/^<:!InSuperscriptsAndSubscripts>$/ ), q{Don't match negated } );
ok(!( "\c[SUPERSCRIPT ZERO]" ~~ m/^<-:InSuperscriptsAndSubscripts>$/ ), q{Don't match inverted } );
ok(!( "\x[3E71]"  ~~ m/^<:InSuperscriptsAndSubscripts>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3E71]"  ~~ m/^<:!InSuperscriptsAndSubscripts>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3E71]"  ~~ m/^<-:InSuperscriptsAndSubscripts>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3E71]\c[SUPERSCRIPT ZERO]" ~~ m/<:InSuperscriptsAndSubscripts>/, q{Match unanchored } );

# InSupplementalArrowsA


#?pugs todo
ok("\c[UPWARDS QUADRUPLE ARROW]" ~~ m/^<:InSupplementalArrowsA>$/, q{Match <:InSupplementalArrowsA>} );
ok(!( "\c[UPWARDS QUADRUPLE ARROW]" ~~ m/^<:!InSupplementalArrowsA>$/ ), q{Don't match negated } );
ok(!( "\c[UPWARDS QUADRUPLE ARROW]" ~~ m/^<-:InSupplementalArrowsA>$/ ), q{Don't match inverted } );
ok(!( "\c[GREEK SMALL LETTER OMICRON WITH TONOS]"  ~~ m/^<:InSupplementalArrowsA>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[GREEK SMALL LETTER OMICRON WITH TONOS]"  ~~ m/^<:!InSupplementalArrowsA>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[GREEK SMALL LETTER OMICRON WITH TONOS]"  ~~ m/^<-:InSupplementalArrowsA>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[GREEK SMALL LETTER OMICRON WITH TONOS]\c[UPWARDS QUADRUPLE ARROW]" ~~ m/<:InSupplementalArrowsA>/, q{Match unanchored } );

# InSupplementalArrowsB


#?pugs todo
ok("\c[RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE]" ~~ m/^<:InSupplementalArrowsB>$/, q{Match <:InSupplementalArrowsB>} );
ok(!( "\c[RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE]" ~~ m/^<:!InSupplementalArrowsB>$/ ), q{Don't match negated } );
ok(!( "\c[RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE]" ~~ m/^<-:InSupplementalArrowsB>$/ ), q{Don't match inverted } );
ok(!( "\x[C1A9]"  ~~ m/^<:InSupplementalArrowsB>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C1A9]"  ~~ m/^<:!InSupplementalArrowsB>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C1A9]"  ~~ m/^<-:InSupplementalArrowsB>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[C1A9]\c[RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE]" ~~ m/<:InSupplementalArrowsB>/, q{Match unanchored } );

# InSupplementalMathematicalOperators


#?pugs todo
ok("\c[N-ARY CIRCLED DOT OPERATOR]" ~~ m/^<:InSupplementalMathematicalOperators>$/, q{Match <:InSupplementalMathematicalOperators>} );
ok(!( "\c[N-ARY CIRCLED DOT OPERATOR]" ~~ m/^<:!InSupplementalMathematicalOperators>$/ ), q{Don't match negated } );
ok(!( "\c[N-ARY CIRCLED DOT OPERATOR]" ~~ m/^<-:InSupplementalMathematicalOperators>$/ ), q{Don't match inverted } );
ok(!( "\x[9EBD]"  ~~ m/^<:InSupplementalMathematicalOperators>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9EBD]"  ~~ m/^<:!InSupplementalMathematicalOperators>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9EBD]"  ~~ m/^<-:InSupplementalMathematicalOperators>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9EBD]\c[N-ARY CIRCLED DOT OPERATOR]" ~~ m/<:InSupplementalMathematicalOperators>/, q{Match unanchored } );

# InSupplementaryPrivateUseAreaA


ok(!( "\x[07E3]"  ~~ m/^<:InSupplementaryPrivateUseAreaA>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[07E3]"  ~~ m/^<:!InSupplementaryPrivateUseAreaA>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[07E3]"  ~~ m/^<-:InSupplementaryPrivateUseAreaA>$/, q{Match unrelated inverted } );

# InSupplementaryPrivateUseAreaB


ok(!( "\x[4C48]"  ~~ m/^<:InSupplementaryPrivateUseAreaB>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4C48]"  ~~ m/^<:!InSupplementaryPrivateUseAreaB>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4C48]"  ~~ m/^<-:InSupplementaryPrivateUseAreaB>$/, q{Match unrelated inverted } );

# InSyriac


#?pugs todo
ok("\c[SYRIAC END OF PARAGRAPH]" ~~ m/^<:InSyriac>$/, q{Match <:InSyriac>} );
ok(!( "\c[SYRIAC END OF PARAGRAPH]" ~~ m/^<:!InSyriac>$/ ), q{Don't match negated } );
ok(!( "\c[SYRIAC END OF PARAGRAPH]" ~~ m/^<-:InSyriac>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE NZIEP]"  ~~ m/^<:InSyriac>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE NZIEP]"  ~~ m/^<:!InSyriac>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE NZIEP]"  ~~ m/^<-:InSyriac>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE NZIEP]\c[SYRIAC END OF PARAGRAPH]" ~~ m/<:InSyriac>/, q{Match unanchored } );

# InTagalog


#?pugs todo
ok("\c[TAGALOG LETTER A]" ~~ m/^<:InTagalog>$/, q{Match <:InTagalog>} );
ok(!( "\c[TAGALOG LETTER A]" ~~ m/^<:!InTagalog>$/ ), q{Don't match negated } );
ok(!( "\c[TAGALOG LETTER A]" ~~ m/^<-:InTagalog>$/ ), q{Don't match inverted } );
ok(!( "\c[GEORGIAN LETTER BAN]"  ~~ m/^<:InTagalog>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[GEORGIAN LETTER BAN]"  ~~ m/^<:!InTagalog>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[GEORGIAN LETTER BAN]"  ~~ m/^<-:InTagalog>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[GEORGIAN LETTER BAN]\c[TAGALOG LETTER A]" ~~ m/<:InTagalog>/, q{Match unanchored } );

# InTagbanwa


#?pugs todo
ok("\c[TAGBANWA LETTER A]" ~~ m/^<:InTagbanwa>$/, q{Match <:InTagbanwa>} );
ok(!( "\c[TAGBANWA LETTER A]" ~~ m/^<:!InTagbanwa>$/ ), q{Don't match negated } );
ok(!( "\c[TAGBANWA LETTER A]" ~~ m/^<-:InTagbanwa>$/ ), q{Don't match inverted } );
ok(!( "\x[5776]"  ~~ m/^<:InTagbanwa>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5776]"  ~~ m/^<:!InTagbanwa>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5776]"  ~~ m/^<-:InTagbanwa>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[5776]\c[TAGBANWA LETTER A]" ~~ m/<:InTagbanwa>/, q{Match unanchored } );

# InTags


ok(!( "\x[3674]"  ~~ m/^<:InTags>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3674]"  ~~ m/^<:!InTags>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3674]"  ~~ m/^<-:InTags>$/, q{Match unrelated inverted } );

# InTamil


#?pugs todo
ok("\x[0B80]" ~~ m/^<:InTamil>$/, q{Match <:InTamil>} );
ok(!( "\x[0B80]" ~~ m/^<:!InTamil>$/ ), q{Don't match negated } );
ok(!( "\x[0B80]" ~~ m/^<-:InTamil>$/ ), q{Don't match inverted } );
ok(!( "\x[B58F]"  ~~ m/^<:InTamil>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B58F]"  ~~ m/^<:!InTamil>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B58F]"  ~~ m/^<-:InTamil>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[B58F]\x[0B80]" ~~ m/<:InTamil>/, q{Match unanchored } );

# InTelugu


#?pugs todo
ok("\x[0C00]" ~~ m/^<:InTelugu>$/, q{Match <:InTelugu>} );
ok(!( "\x[0C00]" ~~ m/^<:!InTelugu>$/ ), q{Don't match negated } );
ok(!( "\x[0C00]" ~~ m/^<-:InTelugu>$/ ), q{Don't match inverted } );
ok(!( "\x[8AC5]"  ~~ m/^<:InTelugu>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8AC5]"  ~~ m/^<:!InTelugu>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8AC5]"  ~~ m/^<-:InTelugu>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[8AC5]\x[0C00]" ~~ m/<:InTelugu>/, q{Match unanchored } );

# InThaana


#?pugs todo
ok("\c[THAANA LETTER HAA]" ~~ m/^<:InThaana>$/, q{Match <:InThaana>} );
ok(!( "\c[THAANA LETTER HAA]" ~~ m/^<:!InThaana>$/ ), q{Don't match negated } );
ok(!( "\c[THAANA LETTER HAA]" ~~ m/^<-:InThaana>$/ ), q{Don't match inverted } );
ok(!( "\x[BB8F]"  ~~ m/^<:InThaana>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BB8F]"  ~~ m/^<:!InThaana>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BB8F]"  ~~ m/^<-:InThaana>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BB8F]\c[THAANA LETTER HAA]" ~~ m/<:InThaana>/, q{Match unanchored } );

# InThai


#?pugs todo
ok("\x[0E00]" ~~ m/^<:InThai>$/, q{Match <:InThai>} );
ok(!( "\x[0E00]" ~~ m/^<:!InThai>$/ ), q{Don't match negated } );
ok(!( "\x[0E00]" ~~ m/^<-:InThai>$/ ), q{Don't match inverted } );
ok(!( "\x[9395]"  ~~ m/^<:InThai>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9395]"  ~~ m/^<:!InThai>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9395]"  ~~ m/^<-:InThai>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9395]\x[0E00]" ~~ m/<:InThai>/, q{Match unanchored } );

# InTibetan


#?pugs todo
ok("\c[TIBETAN SYLLABLE OM]" ~~ m/^<:InTibetan>$/, q{Match <:InTibetan>} );
ok(!( "\c[TIBETAN SYLLABLE OM]" ~~ m/^<:!InTibetan>$/ ), q{Don't match negated } );
ok(!( "\c[TIBETAN SYLLABLE OM]" ~~ m/^<-:InTibetan>$/ ), q{Don't match inverted } );
ok(!( "\x[957A]"  ~~ m/^<:InTibetan>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[957A]"  ~~ m/^<:!InTibetan>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[957A]"  ~~ m/^<-:InTibetan>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[957A]\c[TIBETAN SYLLABLE OM]" ~~ m/<:InTibetan>/, q{Match unanchored } );

# InUnifiedCanadianAboriginalSyllabics


#?pugs todo
ok("\x[1400]" ~~ m/^<:InUnifiedCanadianAboriginalSyllabics>$/, q{Match <:InUnifiedCanadianAboriginalSyllabics>} );
ok(!( "\x[1400]" ~~ m/^<:!InUnifiedCanadianAboriginalSyllabics>$/ ), q{Don't match negated } );
ok(!( "\x[1400]" ~~ m/^<-:InUnifiedCanadianAboriginalSyllabics>$/ ), q{Don't match inverted } );
ok(!( "\x[9470]"  ~~ m/^<:InUnifiedCanadianAboriginalSyllabics>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9470]"  ~~ m/^<:!InUnifiedCanadianAboriginalSyllabics>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9470]"  ~~ m/^<-:InUnifiedCanadianAboriginalSyllabics>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9470]\x[1400]" ~~ m/<:InUnifiedCanadianAboriginalSyllabics>/, q{Match unanchored } );

# InVariationSelectors


ok(!( "\x[764D]"  ~~ m/^<:InVariationSelectors>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[764D]"  ~~ m/^<:!InVariationSelectors>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[764D]"  ~~ m/^<-:InVariationSelectors>$/, q{Match unrelated inverted } );

# InYiRadicals


#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<:InYiRadicals>$/, q{Match <:InYiRadicals>} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:!InYiRadicals>$/ ), q{Don't match negated } );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<-:InYiRadicals>$/ ), q{Don't match inverted } );
ok(!( "\x[3A4E]"  ~~ m/^<:InYiRadicals>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3A4E]"  ~~ m/^<:!InYiRadicals>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3A4E]"  ~~ m/^<-:InYiRadicals>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3A4E]\c[YI RADICAL QOT]" ~~ m/<:InYiRadicals>/, q{Match unanchored } );

# InYiSyllables


#?pugs todo
ok("\c[YI SYLLABLE IT]" ~~ m/^<:InYiSyllables>$/, q{Match <:InYiSyllables>} );
ok(!( "\c[YI SYLLABLE IT]" ~~ m/^<:!InYiSyllables>$/ ), q{Don't match negated } );
ok(!( "\c[YI SYLLABLE IT]" ~~ m/^<-:InYiSyllables>$/ ), q{Don't match inverted } );
ok(!( "\c[PARALLEL WITH HORIZONTAL STROKE]"  ~~ m/^<:InYiSyllables>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[PARALLEL WITH HORIZONTAL STROKE]"  ~~ m/^<:!InYiSyllables>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[PARALLEL WITH HORIZONTAL STROKE]"  ~~ m/^<-:InYiSyllables>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[PARALLEL WITH HORIZONTAL STROKE]\c[YI SYLLABLE IT]" ~~ m/<:InYiSyllables>/, q{Match unanchored } );



# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/properties-derived.t0000664000175000017500000007261012224265625021325 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/properties_slow_to_compile.t.

XXX needs more clarification on the case of the rules, 
ie letter vs. Letter vs isLetter

Some notes regarding specific unicode codepoints chosen below
(based on Unicode 5.1):

   U+9FC4 : just beyond the CJK Unified Ideographs block

=end pod

plan 256;

# ASCIIHexDigit

#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:ASCIIHexDigit>$/, q{Match <:ASCIIHexDigit>} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:!ASCIIHexDigit>$/ ), q{Don't match negated } );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<-:ASCIIHexDigit>$/ ), q{Don't match inverted } );
ok(!( "\x[53BA]"  ~~ m/^<:ASCIIHexDigit>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[53BA]"  ~~ m/^<:!ASCIIHexDigit>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[53BA]"  ~~ m/^<-:ASCIIHexDigit>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[53BA]\c[DIGIT ZERO]" ~~ m/<:ASCIIHexDigit>/, q{Match unanchored } );

# Dash


#?pugs todo
ok("\c[HYPHEN-MINUS]" ~~ m/^<:Dash>$/, q{Match <:Dash>} );
ok(!( "\c[HYPHEN-MINUS]" ~~ m/^<:!Dash>$/ ), q{Don't match negated } );
ok(!( "\c[HYPHEN-MINUS]" ~~ m/^<-:Dash>$/ ), q{Don't match inverted } );
ok(!( "\x[53F7]"  ~~ m/^<:Dash>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[53F7]"  ~~ m/^<:!Dash>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[53F7]"  ~~ m/^<-:Dash>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[53F7]\c[HYPHEN-MINUS]" ~~ m/<:Dash>/, q{Match unanchored } );

# Diacritic


#?pugs todo
ok("\c[MODIFIER LETTER CAPITAL A]" ~~ m/^<:Diacritic>$/, q{Match <:Diacritic>} );
ok(!( "\c[MODIFIER LETTER CAPITAL A]" ~~ m/^<:!Diacritic>$/ ), q{Don't match negated } );
ok(!( "\c[MODIFIER LETTER CAPITAL A]" ~~ m/^<-:Diacritic>$/ ), q{Don't match inverted } );
ok(!( "\x[1BCD]"  ~~ m/^<:Diacritic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[1BCD]"  ~~ m/^<:!Diacritic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[1BCD]"  ~~ m/^<-:Diacritic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[1BCD]\c[MODIFIER LETTER CAPITAL A]" ~~ m/<:Diacritic>/, q{Match unanchored } );

# Extender


#?pugs todo
ok("\c[MIDDLE DOT]" ~~ m/^<:Extender>$/, q{Match <:Extender>} );
ok(!( "\c[MIDDLE DOT]" ~~ m/^<:!Extender>$/ ), q{Don't match negated } );
ok(!( "\c[MIDDLE DOT]" ~~ m/^<-:Extender>$/ ), q{Don't match inverted } );
ok(!( "\x[3A18]"  ~~ m/^<:Extender>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3A18]"  ~~ m/^<:!Extender>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3A18]"  ~~ m/^<-:Extender>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3A18]\c[MIDDLE DOT]" ~~ m/<:Extender>/, q{Match unanchored } );

# GraphemeLink


#?niecza todo
#?pugs todo
#?rakudo.parrot 3 todo "isGraphemeLink"
#?rakudo.jvm    7 skip "isGraphemeLink"
ok("\c[COMBINING GRAPHEME JOINER]" ~~ m/^<:GraphemeLink>$/, q{Match <:GraphemeLink>} );
ok(!( "\c[COMBINING GRAPHEME JOINER]" ~~ m/^<:!GraphemeLink>$/ ), q{Don't match negated } );
#?niecza todo
ok(!( "\c[COMBINING GRAPHEME JOINER]" ~~ m/^<-:GraphemeLink>$/ ), q{Don't match inverted } );
ok(!( "\x[4989]"  ~~ m/^<:GraphemeLink>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4989]"  ~~ m/^<:!GraphemeLink>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4989]"  ~~ m/^<-:GraphemeLink>$/, q{Match unrelated inverted } );
#?niecza todo
#?pugs todo
#?rakudo.parrot todo "isGraphemeLink"
ok("\x[4989]\c[COMBINING GRAPHEME JOINER]" ~~ m/<:GraphemeLink>/, q{Match unanchored } );

# HexDigit


#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:HexDigit>$/, q{Match <:HexDigit>} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:!HexDigit>$/ ), q{Don't match negated } );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<-:HexDigit>$/ ), q{Don't match inverted } );
ok(!( "\x[6292]"  ~~ m/^<:HexDigit>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[6292]"  ~~ m/^<:!HexDigit>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[6292]"  ~~ m/^<-:HexDigit>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[6292]\c[DIGIT ZERO]" ~~ m/<:HexDigit>/, q{Match unanchored } );

# Hyphen

#?pugs todo
ok("\c[KATAKANA MIDDLE DOT]" ~~ m/^<:Hyphen>$/, q{Match <:Hyphen>} );
ok(!( "\c[KATAKANA MIDDLE DOT]" ~~ m/^<:!Hyphen>$/ ), q{Don't match negated } );
ok(!( "\c[KATAKANA MIDDLE DOT]" ~~ m/^<-:Hyphen>$/ ), q{Don't match inverted } );
ok(!( "\c[BOX DRAWINGS DOWN DOUBLE AND LEFT SINGLE]"  ~~ m/^<:Hyphen>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[BOX DRAWINGS DOWN DOUBLE AND LEFT SINGLE]"  ~~ m/^<:!Hyphen>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[BOX DRAWINGS DOWN DOUBLE AND LEFT SINGLE]"  ~~ m/^<-:Hyphen>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[BOX DRAWINGS DOWN DOUBLE AND LEFT SINGLE]\c[KATAKANA MIDDLE DOT]" ~~ m/<:Hyphen>/, q{Match unanchored } );

# Ideographic


#?pugs todo
ok("\x[8AB0]" ~~ m/^<:Ideographic>$/, q{Match <:Ideographic>} );
ok(!( "\x[8AB0]" ~~ m/^<:!Ideographic>$/ ), q{Don't match negated } );
ok(!( "\x[8AB0]" ~~ m/^<-:Ideographic>$/ ), q{Don't match inverted } );
#?rakudo 3 skip 'icu problems'
#?niecza 3 todo
ok(!( "\x[9FC4]"  ~~ m/^<:Ideographic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9FC4]"  ~~ m/^<:!Ideographic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9FC4]"  ~~ m/^<-:Ideographic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9FC4]\x[8AB0]" ~~ m/<:Ideographic>/, q{Match unanchored } );

# IDSBinaryOperator


#?pugs todo
ok("\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/^<:IDSBinaryOperator>$/, q{Match <:IDSBinaryOperator>} );
ok(!( "\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/^<:!IDSBinaryOperator>$/ ), q{Don't match negated } );
ok(!( "\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/^<-:IDSBinaryOperator>$/ ), q{Don't match inverted } );
ok(!( "\x[59E9]"  ~~ m/^<:IDSBinaryOperator>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[59E9]"  ~~ m/^<:!IDSBinaryOperator>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[59E9]"  ~~ m/^<-:IDSBinaryOperator>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[59E9]\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT]" ~~ m/<:IDSBinaryOperator>/, q{Match unanchored } );

# IDSTrinaryOperator

#?pugs todo
ok("\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO MIDDLE AND RIGHT]" ~~ m/^<:IDSTrinaryOperator>$/, q{Match <:IDSTrinaryOperator>} );
ok(!( "\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO MIDDLE AND RIGHT]" ~~ m/^<:!IDSTrinaryOperator>$/ ), q{Don't match negated } );
ok(!( "\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO MIDDLE AND RIGHT]" ~~ m/^<-:IDSTrinaryOperator>$/ ), q{Don't match inverted } );
ok(!( "\x[9224]"  ~~ m/^<:IDSTrinaryOperator>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9224]"  ~~ m/^<:!IDSTrinaryOperator>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9224]"  ~~ m/^<-:IDSTrinaryOperator>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9224]\c[IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO MIDDLE AND RIGHT]" ~~ m/<:IDSTrinaryOperator>/, q{Match unanchored } );

# JoinControl


#?pugs todo
ok("\c[ZERO WIDTH NON-JOINER]" ~~ m/^<:JoinControl>$/, q{Match <:JoinControl>} );
ok(!( "\c[ZERO WIDTH NON-JOINER]" ~~ m/^<:!JoinControl>$/ ), q{Don't match negated } );
ok(!( "\c[ZERO WIDTH NON-JOINER]" ~~ m/^<-:JoinControl>$/ ), q{Don't match inverted } );
ok(!( "\c[BENGALI LETTER DDHA]"  ~~ m/^<:JoinControl>$/ ), q{Don't match unrelated } );
#?niecza todo
#?pugs todo
ok("\c[BENGALI LETTER DDHA]"  ~~ m/^<:!JoinControl>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[BENGALI LETTER DDHA]"  ~~ m/^<-:JoinControl>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[BENGALI LETTER DDHA]\c[ZERO WIDTH NON-JOINER]" ~~ m/<:JoinControl>/, q{Match unanchored } );

# LogicalOrderException


#?pugs todo
ok("\c[THAI CHARACTER SARA E]" ~~ m/^<:LogicalOrderException>$/, q{Match <:LogicalOrderException>} );
ok(!( "\c[THAI CHARACTER SARA E]" ~~ m/^<:!LogicalOrderException>$/ ), q{Don't match negated } );
ok(!( "\c[THAI CHARACTER SARA E]" ~~ m/^<-:LogicalOrderException>$/ ), q{Don't match inverted } );
ok(!( "\x[857B]"  ~~ m/^<:LogicalOrderException>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[857B]"  ~~ m/^<:!LogicalOrderException>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[857B]"  ~~ m/^<-:LogicalOrderException>$/, q{Match unrelated inverted } );
ok(!( "\x[857B]" ~~ m/^<:LogicalOrderException>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[857B]" ~~ m/^<:!LogicalOrderException>$/, q{Match related negated } );
#?pugs todo
ok("\x[857B]" ~~ m/^<-:LogicalOrderException>$/, q{Match related inverted } );
#?pugs todo
ok("\x[857B]\x[857B]\c[THAI CHARACTER SARA E]" ~~ m/<:LogicalOrderException>/, q{Match unanchored } );

# NoncharacterCodePoint

ok(!( "\c[LATIN LETTER REVERSED GLOTTAL STOP WITH STROKE]"  ~~ m/^<:NoncharacterCodePoint>$/ ), q{Don't match unrelated } );
#?niecza todo
#?pugs todo
ok("\c[LATIN LETTER REVERSED GLOTTAL STOP WITH STROKE]"  ~~ m/^<:!NoncharacterCodePoint>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[LATIN LETTER REVERSED GLOTTAL STOP WITH STROKE]"  ~~ m/^<-:NoncharacterCodePoint>$/, q{Match unrelated inverted } );
ok(!( "\c[ARABIC-INDIC DIGIT ZERO]" ~~ m/^<:NoncharacterCodePoint>$/ ), q{Don't match related } );
#?niecza todo
#?pugs todo
ok("\c[ARABIC-INDIC DIGIT ZERO]" ~~ m/^<:!NoncharacterCodePoint>$/, q{Match related negated } );
#?pugs todo
ok("\c[ARABIC-INDIC DIGIT ZERO]" ~~ m/^<-:NoncharacterCodePoint>$/, q{Match related inverted } );

# OtherAlphabetic

#?rakudo 42 skip "isOther* not implemented"
#?pugs todo
ok("\c[COMBINING GREEK YPOGEGRAMMENI]" ~~ m/^<:OtherAlphabetic>$/, q{Match <:OtherAlphabetic>} );
ok(!( "\c[COMBINING GREEK YPOGEGRAMMENI]" ~~ m/^<:!OtherAlphabetic>$/ ), q{Don't match negated } );
ok(!( "\c[COMBINING GREEK YPOGEGRAMMENI]" ~~ m/^<-:OtherAlphabetic>$/ ), q{Don't match inverted } );
ok(!( "\x[413C]"  ~~ m/^<:OtherAlphabetic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[413C]"  ~~ m/^<:!OtherAlphabetic>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[413C]"  ~~ m/^<-:OtherAlphabetic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[413C]\c[COMBINING GREEK YPOGEGRAMMENI]" ~~ m/<:OtherAlphabetic>/, q{Match unanchored } );

# OtherDefaultIgnorableCodePoint


#?pugs todo
ok("\c[HANGUL FILLER]" ~~ m/^<:OtherDefaultIgnorableCodePoint>$/, q{Match <:OtherDefaultIgnorableCodePoint>} );
ok(!( "\c[HANGUL FILLER]" ~~ m/^<:!OtherDefaultIgnorableCodePoint>$/ ), q{Don't match negated } );
ok(!( "\c[HANGUL FILLER]" ~~ m/^<-:OtherDefaultIgnorableCodePoint>$/ ), q{Don't match inverted } );
ok(!( "\c[VERTICAL BAR DOUBLE LEFT TURNSTILE]"  ~~ m/^<:OtherDefaultIgnorableCodePoint>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[VERTICAL BAR DOUBLE LEFT TURNSTILE]"  ~~ m/^<:!OtherDefaultIgnorableCodePoint>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[VERTICAL BAR DOUBLE LEFT TURNSTILE]"  ~~ m/^<-:OtherDefaultIgnorableCodePoint>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[VERTICAL BAR DOUBLE LEFT TURNSTILE]\c[HANGUL FILLER]" ~~ m/<:OtherDefaultIgnorableCodePoint>/, q{Match unanchored } );

# OtherGraphemeExtend


#?pugs todo
ok("\c[BENGALI VOWEL SIGN AA]" ~~ m/^<:OtherGraphemeExtend>$/, q{Match <:OtherGraphemeExtend>} );
ok(!( "\c[BENGALI VOWEL SIGN AA]" ~~ m/^<:!OtherGraphemeExtend>$/ ), q{Don't match negated } );
ok(!( "\c[BENGALI VOWEL SIGN AA]" ~~ m/^<-:OtherGraphemeExtend>$/ ), q{Don't match inverted } );
ok(!( "\c[APL FUNCTIONAL SYMBOL EPSILON UNDERBAR]"  ~~ m/^<:OtherGraphemeExtend>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[APL FUNCTIONAL SYMBOL EPSILON UNDERBAR]"  ~~ m/^<:!OtherGraphemeExtend>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[APL FUNCTIONAL SYMBOL EPSILON UNDERBAR]"  ~~ m/^<-:OtherGraphemeExtend>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[APL FUNCTIONAL SYMBOL EPSILON UNDERBAR]\c[BENGALI VOWEL SIGN AA]" ~~ m/<:OtherGraphemeExtend>/, q{Match unanchored } );

# OtherLowercase


#?pugs todo
ok("\c[MODIFIER LETTER SMALL H]" ~~ m/^<:OtherLowercase>$/, q{Match <:OtherLowercase>} );
ok(!( "\c[MODIFIER LETTER SMALL H]" ~~ m/^<:!OtherLowercase>$/ ), q{Don't match negated } );
ok(!( "\c[MODIFIER LETTER SMALL H]" ~~ m/^<-:OtherLowercase>$/ ), q{Don't match inverted } );
ok(!( "\c[HANGUL LETTER NIEUN-CIEUC]"  ~~ m/^<:OtherLowercase>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[HANGUL LETTER NIEUN-CIEUC]"  ~~ m/^<:!OtherLowercase>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[HANGUL LETTER NIEUN-CIEUC]"  ~~ m/^<-:OtherLowercase>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[HANGUL LETTER NIEUN-CIEUC]\c[MODIFIER LETTER SMALL H]" ~~ m/<:OtherLowercase>/, q{Match unanchored } );

# OtherMath


#?niecza todo
#?pugs todo
ok("\c[LEFT PARENTHESIS]" ~~ m/^<:OtherMath>$/, q{Match <:OtherMath>} );
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<:!OtherMath>$/ ), q{Don't match negated } );
#?niecza todo
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<-:OtherMath>$/ ), q{Don't match inverted } );
ok(!( "\x[B43A]"  ~~ m/^<:OtherMath>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B43A]"  ~~ m/^<:!OtherMath>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B43A]"  ~~ m/^<-:OtherMath>$/, q{Match unrelated inverted } );
#?niecza todo
#?pugs todo
ok("\x[B43A]\c[LEFT PARENTHESIS]" ~~ m/<:OtherMath>/, q{Match unanchored } );

# OtherUppercase


#?pugs todo
ok("\c[ROMAN NUMERAL ONE]" ~~ m/^<:OtherUppercase>$/, q{Match <:OtherUppercase>} );
ok(!( "\c[ROMAN NUMERAL ONE]" ~~ m/^<:!OtherUppercase>$/ ), q{Don't match negated } );
ok(!( "\c[ROMAN NUMERAL ONE]" ~~ m/^<-:OtherUppercase>$/ ), q{Don't match inverted } );
ok(!( "\x[D246]"  ~~ m/^<:OtherUppercase>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D246]"  ~~ m/^<:!OtherUppercase>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D246]"  ~~ m/^<-:OtherUppercase>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D246]\c[ROMAN NUMERAL ONE]" ~~ m/<:OtherUppercase>/, q{Match unanchored } );

# QuotationMark


#?pugs todo
ok("\c[QUOTATION MARK]" ~~ m/^<:QuotationMark>$/, q{Match <:QuotationMark>} );
ok(!( "\c[QUOTATION MARK]" ~~ m/^<:!QuotationMark>$/ ), q{Don't match negated } );
ok(!( "\c[QUOTATION MARK]" ~~ m/^<-:QuotationMark>$/ ), q{Don't match inverted } );
ok(!( "\x[C890]"  ~~ m/^<:QuotationMark>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C890]"  ~~ m/^<:!QuotationMark>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C890]"  ~~ m/^<-:QuotationMark>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[C890]\c[QUOTATION MARK]" ~~ m/<:QuotationMark>/, q{Match unanchored } );

# Radical


#?pugs todo
ok("\c[CJK RADICAL REPEAT]" ~~ m/^<:Radical>$/, q{Match <:Radical>} );
ok(!( "\c[CJK RADICAL REPEAT]" ~~ m/^<:!Radical>$/ ), q{Don't match negated } );
ok(!( "\c[CJK RADICAL REPEAT]" ~~ m/^<-:Radical>$/ ), q{Don't match inverted } );
ok(!( "\c[HANGUL JONGSEONG CHIEUCH]"  ~~ m/^<:Radical>$/ ), q{Don't match unrelated } );
#?niecza todo
#?pugs todo
ok("\c[HANGUL JONGSEONG CHIEUCH]"  ~~ m/^<:!Radical>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[HANGUL JONGSEONG CHIEUCH]"  ~~ m/^<-:Radical>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[HANGUL JONGSEONG CHIEUCH]\c[CJK RADICAL REPEAT]" ~~ m/<:Radical>/, q{Match unanchored } );

# SoftDotted


#?pugs todo
ok("\c[LATIN SMALL LETTER I]" ~~ m/^<:SoftDotted>$/, q{Match <:SoftDotted>} );
ok(!( "\c[LATIN SMALL LETTER I]" ~~ m/^<:!SoftDotted>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN SMALL LETTER I]" ~~ m/^<-:SoftDotted>$/ ), q{Don't match inverted } );
ok(!( "\x[ADEF]"  ~~ m/^<:SoftDotted>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[ADEF]"  ~~ m/^<:!SoftDotted>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[ADEF]"  ~~ m/^<-:SoftDotted>$/, q{Match unrelated inverted } );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<:SoftDotted>$/ ), q{Don't match related } );
#?niecza todo
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<:!SoftDotted>$/, q{Match related negated } );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<-:SoftDotted>$/, q{Match related inverted } );
#?pugs todo
ok("\x[ADEF]\c[DOLLAR SIGN]\c[LATIN SMALL LETTER I]" ~~ m/<:SoftDotted>/, q{Match unanchored } );

# TerminalPunctuation


#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:TerminalPunctuation>$/, q{Match <:TerminalPunctuation>} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:!TerminalPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<-:TerminalPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[3C9D]"  ~~ m/^<:TerminalPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3C9D]"  ~~ m/^<:!TerminalPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3C9D]"  ~~ m/^<-:TerminalPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3C9D]\c[EXCLAMATION MARK]" ~~ m/<:TerminalPunctuation>/, q{Match unanchored } );

# UnifiedIdeograph


#?pugs todo
ok("\x[7896]" ~~ m/^<:UnifiedIdeograph>$/, q{Match <:UnifiedIdeograph>} );
ok(!( "\x[7896]" ~~ m/^<:!UnifiedIdeograph>$/ ), q{Don't match negated } );
ok(!( "\x[7896]" ~~ m/^<-:UnifiedIdeograph>$/ ), q{Don't match inverted } );
#?rakudo 3 skip 'icu'
#?niecza 3 todo
ok(!( "\x[9FC4]"  ~~ m/^<:UnifiedIdeograph>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9FC4]"  ~~ m/^<:!UnifiedIdeograph>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9FC4]"  ~~ m/^<-:UnifiedIdeograph>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9FC4]\x[7896]" ~~ m/<:UnifiedIdeograph>/, q{Match unanchored } );

# WhiteSpace


#?pugs todo
ok("\c[CHARACTER TABULATION]" ~~ m/^<:WhiteSpace>$/, q{Match <:WhiteSpace>} );
ok(!( "\c[CHARACTER TABULATION]" ~~ m/^<:!WhiteSpace>$/ ), q{Don't match negated } );
ok(!( "\c[CHARACTER TABULATION]" ~~ m/^<-:WhiteSpace>$/ ), q{Don't match inverted } );
ok(!( "\x[6358]"  ~~ m/^<:WhiteSpace>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[6358]"  ~~ m/^<:!WhiteSpace>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[6358]"  ~~ m/^<-:WhiteSpace>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[6358]\c[CHARACTER TABULATION]" ~~ m/<:WhiteSpace>/, q{Match unanchored } );

# Alphabetic      # Lu + Ll + Lt + Lm + Lo + OtherAlphabetic


#?pugs todo
ok("\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/^<:Alphabetic>$/, q{Match (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );
ok(!( "\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/^<:!Alphabetic>$/ ), q{Don't match negated (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );
ok(!( "\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/^<-:Alphabetic>$/ ), q{Don't match inverted (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );
ok(!( "\x[297C]"  ~~ m/^<:Alphabetic>$/ ), q{Don't match unrelated (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );
#?pugs todo
ok("\x[297C]"  ~~ m/^<:!Alphabetic>$/, q{Match unrelated negated (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );
#?pugs todo
ok("\x[297C]"  ~~ m/^<-:Alphabetic>$/, q{Match unrelated inverted (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );
#?pugs todo
ok("\x[297C]\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/<:Alphabetic>/, q{Match unanchored (Lu + Ll + Lt + Lm + Lo + OtherAlphabetic)} );

# Lowercase       # Ll + OtherLowercase


#?pugs todo
ok("\c[LATIN SMALL LETTER A]" ~~ m/^<:Lowercase>$/, q{Match (Ll + OtherLowercase)} );
ok(!( "\c[LATIN SMALL LETTER A]" ~~ m/^<:!Lowercase>$/ ), q{Don't match negated (Ll + OtherLowercase)} );
ok(!( "\c[LATIN SMALL LETTER A]" ~~ m/^<-:Lowercase>$/ ), q{Don't match inverted (Ll + OtherLowercase)} );
ok(!( "\x[6220]"  ~~ m/^<:Lowercase>$/ ), q{Don't match unrelated (Ll + OtherLowercase)} );
#?pugs todo
ok("\x[6220]"  ~~ m/^<:!Lowercase>$/, q{Match unrelated negated (Ll + OtherLowercase)} );
#?pugs todo
ok("\x[6220]"  ~~ m/^<-:Lowercase>$/, q{Match unrelated inverted (Ll + OtherLowercase)} );
ok(!( "\x[6220]" ~~ m/^<:Lowercase>$/ ), q{Don't match related (Ll + OtherLowercase)} );
#?pugs todo
ok("\x[6220]" ~~ m/^<:!Lowercase>$/, q{Match related negated (Ll + OtherLowercase)} );
#?pugs todo
ok("\x[6220]" ~~ m/^<-:Lowercase>$/, q{Match related inverted (Ll + OtherLowercase)} );
#?pugs todo
ok("\x[6220]\x[6220]\c[LATIN SMALL LETTER A]" ~~ m/<:Lowercase>/, q{Match unanchored (Ll + OtherLowercase)} );

# Uppercase       # Lu + OtherUppercase


#?pugs todo
ok("\c[LATIN CAPITAL LETTER A]" ~~ m/^<:Uppercase>$/, q{Match (Lu + OtherUppercase)} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<:!Uppercase>$/ ), q{Don't match negated (Lu + OtherUppercase)} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<-:Uppercase>$/ ), q{Don't match inverted (Lu + OtherUppercase)} );
ok(!( "\x[C080]"  ~~ m/^<:Uppercase>$/ ), q{Don't match unrelated (Lu + OtherUppercase)} );
#?pugs todo
ok("\x[C080]"  ~~ m/^<:!Uppercase>$/, q{Match unrelated negated (Lu + OtherUppercase)} );
#?pugs todo
ok("\x[C080]"  ~~ m/^<-:Uppercase>$/, q{Match unrelated inverted (Lu + OtherUppercase)} );
#?pugs todo
ok("\x[C080]\c[LATIN CAPITAL LETTER A]" ~~ m/<:Uppercase>/, q{Match unanchored (Lu + OtherUppercase)} );

# Math            # Sm + OtherMath


#?pugs todo
ok("\c[PLUS SIGN]" ~~ m/^<:Math>$/, q{Match (Sm + OtherMath)} );
ok(!( "\c[PLUS SIGN]" ~~ m/^<:!Math>$/ ), q{Don't match negated (Sm + OtherMath)} );
ok(!( "\c[PLUS SIGN]" ~~ m/^<-:Math>$/ ), q{Don't match inverted (Sm + OtherMath)} );
ok(!( "\x[D4D2]"  ~~ m/^<:Math>$/ ), q{Don't match unrelated (Sm + OtherMath)} );
#?pugs todo
ok("\x[D4D2]"  ~~ m/^<:!Math>$/, q{Match unrelated negated (Sm + OtherMath)} );
#?pugs todo
ok("\x[D4D2]"  ~~ m/^<-:Math>$/, q{Match unrelated inverted (Sm + OtherMath)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Math>$/ ), q{Don't match related (Sm + OtherMath)} );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!Math>$/, q{Match related negated (Sm + OtherMath)} );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Math>$/, q{Match related inverted (Sm + OtherMath)} );
#?pugs todo
ok("\x[D4D2]\c[COMBINING GRAVE ACCENT]\c[PLUS SIGN]" ~~ m/<:Math>/, q{Match unanchored (Sm + OtherMath)} );

# ID_Start        # Lu + Ll + Lt + Lm + Lo + Nl


#?pugs todo
ok("\x[C276]" ~~ m/^<:ID_Start>$/, q{Match (Lu + Ll + Lt + Lm + Lo + Nl)} );
ok(!( "\x[C276]" ~~ m/^<:!ID_Start>$/ ), q{Don't match negated (Lu + Ll + Lt + Lm + Lo + Nl)} );
ok(!( "\x[C276]" ~~ m/^<-:ID_Start>$/ ), q{Don't match inverted (Lu + Ll + Lt + Lm + Lo + Nl)} );
ok(!( "\x[D7A4]"  ~~ m/^<:ID_Start>$/ ), q{Don't match unrelated (Lu + Ll + Lt + Lm + Lo + Nl)} );
#?pugs todo
ok("\x[D7A4]"  ~~ m/^<:!ID_Start>$/, q{Match unrelated negated (Lu + Ll + Lt + Lm + Lo + Nl)} );
#?pugs todo
ok("\x[D7A4]"  ~~ m/^<-:ID_Start>$/, q{Match unrelated inverted (Lu + Ll + Lt + Lm + Lo + Nl)} );
#?pugs todo
ok("\x[D7A4]\x[C276]" ~~ m/<:ID_Start>/, q{Match unanchored (Lu + Ll + Lt + Lm + Lo + Nl)} );

# ID_Continue     # ID_Start + Mn + Mc + Nd + Pc


#?pugs todo
ok("\x[949B]" ~~ m/^<:ID_Continue>$/, q{Match (ID_Start + Mn + Mc + Nd + Pc)} );
ok(!( "\x[949B]" ~~ m/^<:!ID_Continue>$/ ), q{Don't match negated (ID_Start + Mn + Mc + Nd + Pc)} );
ok(!( "\x[949B]" ~~ m/^<-:ID_Continue>$/ ), q{Don't match inverted (ID_Start + Mn + Mc + Nd + Pc)} );
#?rakudo 3 skip 'icu'
#?niecza 3 todo
ok(!( "\x[9FC4]"  ~~ m/^<:ID_Continue>$/ ), q{Don't match unrelated (ID_Start + Mn + Mc + Nd + Pc)} );
#?pugs todo
ok("\x[9FC4]"  ~~ m/^<:!ID_Continue>$/, q{Match unrelated negated (ID_Start + Mn + Mc + Nd + Pc)} );
#?pugs todo
ok("\x[9FC4]"  ~~ m/^<-:ID_Continue>$/, q{Match unrelated inverted (ID_Start + Mn + Mc + Nd + Pc)} );
#?pugs todo
ok("\x[9FC4]\x[949B]" ~~ m/<:ID_Continue>/, q{Match unanchored (ID_Start + Mn + Mc + Nd + Pc)} );

# Any             # Any character

#?rakudo 4 skip 'isAny not implemented'
#?pugs todo
ok("\x[C709]" ~~ m/^<:Any>$/, q{Match (Any character)} );
ok(!( "\x[C709]" ~~ m/^<:!Any>$/ ), q{Don't match negated (Any character)} );
ok(!( "\x[C709]" ~~ m/^<-:Any>$/ ), q{Don't match inverted (Any character)} );
#?pugs todo
ok("\x[C709]" ~~ m/<:Any>/, q{Match unanchored (Any character)} );

# Assigned        # Any non-Cn character (i.e. synonym for \P{Cn})


#?rakudo 7 skip 'isAssigned not implemented'
#?pugs todo
ok("\x[C99D]" ~~ m/^<:Assigned>$/, q );
ok(!( "\x[C99D]" ~~ m/^<:!Assigned>$/ ), q );
ok(!( "\x[C99D]" ~~ m/^<-:Assigned>$/ ), q );
ok(!( "\x[D7A4]"  ~~ m/^<:Assigned>$/ ), q );
#?pugs todo
ok("\x[D7A4]"  ~~ m/^<:!Assigned>$/, q );
#?pugs todo
ok("\x[D7A4]"  ~~ m/^<-:Assigned>$/, q );
#?pugs todo
ok("\x[D7A4]\x[C99D]" ~~ m/<:Assigned>/, q );

# Unassigned      # Synonym for \p{Cn}


#?rakudo 7 skip 'isUnassigned not implemented'
#?niecza 3 todo
#?pugs todo
ok("\x[27EC]" ~~ m/^<:Unassigned>$/, q );
ok(!( "\x[27EC]" ~~ m/^<:!Unassigned>$/ ), q );
ok(!( "\x[27EC]" ~~ m/^<-:Unassigned>$/ ), q );
ok(!( "\c[RIGHT OUTER JOIN]"  ~~ m/^<:Unassigned>$/ ), q );
#?pugs todo
ok("\c[RIGHT OUTER JOIN]"  ~~ m/^<:!Unassigned>$/, q );
#?pugs todo
ok("\c[RIGHT OUTER JOIN]"  ~~ m/^<-:Unassigned>$/, q );
#?niecza todo
#?pugs todo
ok("\c[RIGHT OUTER JOIN]\x[27EC]" ~~ m/<:Unassigned>/, q );

# Common          # Codepoint not explicitly assigned to a script


#?rakudo 10 skip 'isCommon not implemented'
#?niecza 3 todo
#?pugs todo
ok("\x[0C7E]" ~~ m/^<:Common>$/, q{Match (Codepoint not explicitly assigned to a script)} );
ok(!( "\x[0C7E]" ~~ m/^<:!Common>$/ ), q{Don't match negated (Codepoint not explicitly assigned to a script)} );
ok(!( "\x[0C7E]" ~~ m/^<-:Common>$/ ), q{Don't match inverted (Codepoint not explicitly assigned to a script)} );
ok(!( "\c[KANNADA SIGN ANUSVARA]"  ~~ m/^<:Common>$/ ), q{Don't match unrelated (Codepoint not explicitly assigned to a script)} );
#?pugs todo
ok("\c[KANNADA SIGN ANUSVARA]"  ~~ m/^<:!Common>$/, q{Match unrelated negated (Codepoint not explicitly assigned to a script)} );
#?pugs todo
ok("\c[KANNADA SIGN ANUSVARA]"  ~~ m/^<-:Common>$/, q{Match unrelated inverted (Codepoint not explicitly assigned to a script)} );
ok(!( "\c[KHMER VOWEL INHERENT AQ]" ~~ m/^<:Common>$/ ), q{Don't match related (Codepoint not explicitly assigned to a script)} );
#?pugs todo
ok("\c[KHMER VOWEL INHERENT AQ]" ~~ m/^<:!Common>$/, q{Match related negated (Codepoint not explicitly assigned to a script)} );
#?pugs todo
ok("\c[KHMER VOWEL INHERENT AQ]" ~~ m/^<-:Common>$/, q{Match related inverted (Codepoint not explicitly assigned to a script)} );
#?niecza todo
#?pugs todo
ok("\c[KANNADA SIGN ANUSVARA]\c[KHMER VOWEL INHERENT AQ]\x[0C7E]" ~~ m/<:Common>/, q{Match unanchored (Codepoint not explicitly assigned to a script)} );

# TODO: missing properties which are broken up to Perl 5.10 e.g.
# Grapheme_Base
# Grapheme_Extend
# Grapheme_Cluster_Break=CN
# Grapheme_Cluster_Break=Control
# Grapheme_Cluster_Break=CR
# Grapheme_Cluster_Break=EX
# Grapheme_Cluster_Break=Extend
# Grapheme_Cluster_Break=L
# Grapheme_Cluster_Break=LF
# Grapheme_Cluster_Break=LV
# Grapheme_Cluster_Break=LVT
# Grapheme_Cluster_Break=Other
# Grapheme_Cluster_Break=PP
# Grapheme_Cluster_Break=Prepend
# Grapheme_Cluster_Break=SM
# Grapheme_Cluster_Break=SpacingMark
# Grapheme_Cluster_Break=T
# Grapheme_Cluster_Break=V
# Grapheme_Cluster_Break=XX

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/properties-general.t0000664000175000017500000017036312224265625021324 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/properties_slow_to_compile.t.

XXX needs more clarification on the case of the rules, 
ie letter vs. Letter vs isLetter

U+FFFE and U+FFFF are guaranteed noncharacters.  A previous version of
this test file used nonguaranteed noncharacters, which were assigned in
Unicode 5.2.

=end pod

plan 596;

# L           Letter

#?pugs todo
ok 'a' ~~ /<:L>/, 'a is a letter';
# RT #117889
nok '' ~~ /<:L>/, 'empty string has no letter';
#?pugs todo
ok("\x[846D]" ~~ m/^<:L>$/, q{Match <:L> (Letter)} );
ok(!( "\x[846D]" ~~ m/^<:!L>$/ ), q{Don't match negated  (Letter)} );
ok(!( "\x[846D]" ~~ m/^<-:L>$/ ), q{Don't match inverted  (Letter)} );
#?rakudo 4 skip 'ICU version dependent :('
ok(!( "\x[FFFE]"  ~~ m/^<:L>$/ ), q{Don't match unrelated  (Letter)} );
#?pugs todo
ok("\x[FFFE]"  ~~ m/^<:!L>$/, q{Match unrelated negated  (Letter)} );
#?pugs todo
ok("\x[FFFE]"  ~~ m/^<-:L>$/, q{Match unrelated inverted  (Letter)} );
#?pugs todo
ok("\x[FFFE]\x[846D]" ~~ m/<:L>/, q{Match unanchored <:L> (Letter)} );

#?pugs todo
ok("\x[6DF7]" ~~ m/^<:Letter>$/, q{Match <:Letter>} );
ok(!( "\x[6DF7]" ~~ m/^<:!Letter>$/ ), q{Don't match negated } );
ok(!( "\x[6DF7]" ~~ m/^<-:Letter>$/ ), q{Don't match inverted } );
#?rakudo 4 skip 'ICU version dependent :('
ok(!( "\x[FFFE]"  ~~ m/^<:Letter>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[FFFE]"  ~~ m/^<:!Letter>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[FFFE]"  ~~ m/^<-:Letter>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[FFFE]\x[6DF7]" ~~ m/<:Letter>/, q{Match unanchored } );

# Lu          UppercaseLetter


#?pugs todo
ok("\c[LATIN CAPITAL LETTER A]" ~~ m/^<:Lu>$/, q{Match <:Lu> (UppercaseLetter)} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<:!Lu>$/ ), q{Don't match negated  (UppercaseLetter)} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<-:Lu>$/ ), q{Don't match inverted  (UppercaseLetter)} );
ok(!( "\x[C767]"  ~~ m/^<:Lu>$/ ), q{Don't match unrelated  (UppercaseLetter)} );
#?pugs todo
ok("\x[C767]"  ~~ m/^<:!Lu>$/, q{Match unrelated negated  (UppercaseLetter)} );
#?pugs todo
ok("\x[C767]"  ~~ m/^<-:Lu>$/, q{Match unrelated inverted  (UppercaseLetter)} );
ok(!( "\x[C767]" ~~ m/^<:Lu>$/ ), q{Don't match related  (UppercaseLetter)} );
#?pugs todo
ok("\x[C767]" ~~ m/^<:!Lu>$/, q{Match related negated  (UppercaseLetter)} );
#?pugs todo
ok("\x[C767]" ~~ m/^<-:Lu>$/, q{Match related inverted  (UppercaseLetter)} );
#?pugs todo
ok("\x[C767]\x[C767]\c[LATIN CAPITAL LETTER A]" ~~ m/<:Lu>/, q{Match unanchored  (UppercaseLetter)} );

#?pugs todo
ok("\c[LATIN CAPITAL LETTER A]" ~~ m/^<:UppercaseLetter>$/, q{Match <:UppercaseLetter>} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<:!UppercaseLetter>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<-:UppercaseLetter>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE NBA]"  ~~ m/^<:UppercaseLetter>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE NBA]"  ~~ m/^<:!UppercaseLetter>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE NBA]"  ~~ m/^<-:UppercaseLetter>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE NBA]\c[LATIN CAPITAL LETTER A]" ~~ m/<:UppercaseLetter>/, q{Match unanchored } );

# Ll          LowercaseLetter


#?pugs todo
ok("\c[LATIN SMALL LETTER A]" ~~ m/^<:Ll>$/, q{Match <:Ll> (LowercaseLetter)} );
ok(!( "\c[LATIN SMALL LETTER A]" ~~ m/^<:!Ll>$/ ), q{Don't match negated  (LowercaseLetter)} );
ok(!( "\c[LATIN SMALL LETTER A]" ~~ m/^<-:Ll>$/ ), q{Don't match inverted  (LowercaseLetter)} );
ok(!( "\c[BOPOMOFO FINAL LETTER H]"  ~~ m/^<:Ll>$/ ), q{Don't match unrelated  (LowercaseLetter)} );
#?pugs todo
ok("\c[BOPOMOFO FINAL LETTER H]"  ~~ m/^<:!Ll>$/, q{Match unrelated negated  (LowercaseLetter)} );
#?pugs todo
ok("\c[BOPOMOFO FINAL LETTER H]"  ~~ m/^<-:Ll>$/, q{Match unrelated inverted  (LowercaseLetter)} );
ok(!( "\c[BOPOMOFO FINAL LETTER H]" ~~ m/^<:Ll>$/ ), q{Don't match related  (LowercaseLetter)} );
#?pugs todo
ok("\c[BOPOMOFO FINAL LETTER H]" ~~ m/^<:!Ll>$/, q{Match related negated  (LowercaseLetter)} );
#?pugs todo
ok("\c[BOPOMOFO FINAL LETTER H]" ~~ m/^<-:Ll>$/, q{Match related inverted  (LowercaseLetter)} );
#?pugs todo
ok("\c[BOPOMOFO FINAL LETTER H]\c[BOPOMOFO FINAL LETTER H]\c[LATIN SMALL LETTER A]" ~~ m/<:Ll>/, q{Match unanchored  (LowercaseLetter)} );

#?pugs todo
ok("\c[LATIN SMALL LETTER A]" ~~ m/^<:LowercaseLetter>$/, q{Match <:LowercaseLetter>} );
ok(!( "\c[LATIN SMALL LETTER A]" ~~ m/^<:!LowercaseLetter>$/ ), q{Don't match negated } );
ok(!( "\c[LATIN SMALL LETTER A]" ~~ m/^<-:LowercaseLetter>$/ ), q{Don't match inverted } );
ok(!( "\x[86CA]"  ~~ m/^<:LowercaseLetter>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[86CA]"  ~~ m/^<:!LowercaseLetter>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[86CA]"  ~~ m/^<-:LowercaseLetter>$/, q{Match unrelated inverted } );
ok(!( "\x[86CA]" ~~ m/^<:LowercaseLetter>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[86CA]" ~~ m/^<:!LowercaseLetter>$/, q{Match related negated } );
#?pugs todo
ok("\x[86CA]" ~~ m/^<-:LowercaseLetter>$/, q{Match related inverted } );
#?pugs todo
ok("\x[86CA]\x[86CA]\c[LATIN SMALL LETTER A]" ~~ m/<:LowercaseLetter>/, q{Match unanchored } );

# Lt          TitlecaseLetter


#?pugs todo
ok("\c[LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON]" ~~ m/^<:Lt>$/, q{Match <:Lt> (TitlecaseLetter)} );
ok(!( "\c[LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON]" ~~ m/^<:!Lt>$/ ), q{Don't match negated  (TitlecaseLetter)} );
ok(!( "\c[LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON]" ~~ m/^<-:Lt>$/ ), q{Don't match inverted  (TitlecaseLetter)} );
ok(!( "\x[6DC8]"  ~~ m/^<:Lt>$/ ), q{Don't match unrelated  (TitlecaseLetter)} );
#?pugs todo
ok("\x[6DC8]"  ~~ m/^<:!Lt>$/, q{Match unrelated negated  (TitlecaseLetter)} );
#?pugs todo
ok("\x[6DC8]"  ~~ m/^<-:Lt>$/, q{Match unrelated inverted  (TitlecaseLetter)} );
ok(!( "\x[6DC8]" ~~ m/^<:Lt>$/ ), q{Don't match related  (TitlecaseLetter)} );
#?pugs todo
ok("\x[6DC8]" ~~ m/^<:!Lt>$/, q{Match related negated  (TitlecaseLetter)} );
#?pugs todo
ok("\x[6DC8]" ~~ m/^<-:Lt>$/, q{Match related inverted  (TitlecaseLetter)} );
#?pugs todo
ok("\x[6DC8]\x[6DC8]\c[LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON]" ~~ m/<:Lt>/, q{Match unanchored  (TitlecaseLetter)} );

#?pugs todo
ok("\c[GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI]" ~~ m/^<:TitlecaseLetter>$/, q{Match <:TitlecaseLetter>} );
ok(!( "\c[GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI]" ~~ m/^<:!TitlecaseLetter>$/ ), q{Don't match negated } );
ok(!( "\c[GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI]" ~~ m/^<-:TitlecaseLetter>$/ ), q{Don't match inverted } );
ok(!( "\x[0C4E]"  ~~ m/^<:TitlecaseLetter>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[0C4E]"  ~~ m/^<:!TitlecaseLetter>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[0C4E]"  ~~ m/^<-:TitlecaseLetter>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[0C4E]\c[GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI]" ~~ m/<:TitlecaseLetter>/, q{Match unanchored } );

# Lm          ModifierLetter


#?pugs todo
ok("\c[IDEOGRAPHIC ITERATION MARK]" ~~ m/^<:Lm>$/, q{Match <:Lm> (ModifierLetter)} );
ok(!( "\c[IDEOGRAPHIC ITERATION MARK]" ~~ m/^<:!Lm>$/ ), q{Don't match negated  (ModifierLetter)} );
ok(!( "\c[IDEOGRAPHIC ITERATION MARK]" ~~ m/^<-:Lm>$/ ), q{Don't match inverted  (ModifierLetter)} );
ok(!( "\x[2B61]"  ~~ m/^<:Lm>$/ ), q{Don't match unrelated  (ModifierLetter)} );
#?pugs todo
ok("\x[2B61]"  ~~ m/^<:!Lm>$/, q{Match unrelated negated  (ModifierLetter)} );
#?pugs todo
ok("\x[2B61]"  ~~ m/^<-:Lm>$/, q{Match unrelated inverted  (ModifierLetter)} );
ok(!( "\c[IDEOGRAPHIC CLOSING MARK]" ~~ m/^<:Lm>$/ ), q{Don't match related  (ModifierLetter)} );
#?pugs todo
ok("\c[IDEOGRAPHIC CLOSING MARK]" ~~ m/^<:!Lm>$/, q{Match related negated  (ModifierLetter)} );
#?pugs todo
ok("\c[IDEOGRAPHIC CLOSING MARK]" ~~ m/^<-:Lm>$/, q{Match related inverted  (ModifierLetter)} );
#?pugs todo
ok("\x[2B61]\c[IDEOGRAPHIC CLOSING MARK]\c[IDEOGRAPHIC ITERATION MARK]" ~~ m/<:Lm>/, q{Match unanchored  (ModifierLetter)} );

#?pugs todo
ok("\c[MODIFIER LETTER SMALL H]" ~~ m/^<:ModifierLetter>$/, q{Match <:ModifierLetter>} );
ok(!( "\c[MODIFIER LETTER SMALL H]" ~~ m/^<:!ModifierLetter>$/ ), q{Don't match negated } );
ok(!( "\c[MODIFIER LETTER SMALL H]" ~~ m/^<-:ModifierLetter>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE HA]"  ~~ m/^<:ModifierLetter>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE HA]"  ~~ m/^<:!ModifierLetter>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE HA]"  ~~ m/^<-:ModifierLetter>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE HA]\c[MODIFIER LETTER SMALL H]" ~~ m/<:ModifierLetter>/, q{Match unanchored } );

# Lo          OtherLetter


#?pugs todo
ok("\c[LATIN LETTER TWO WITH STROKE]" ~~ m/^<:Lo>$/, q{Match <:Lo> (OtherLetter)} );
ok(!( "\c[LATIN LETTER TWO WITH STROKE]" ~~ m/^<:!Lo>$/ ), q{Don't match negated  (OtherLetter)} );
ok(!( "\c[LATIN LETTER TWO WITH STROKE]" ~~ m/^<-:Lo>$/ ), q{Don't match inverted  (OtherLetter)} );
ok(!( "\c[LATIN SMALL LETTER TURNED DELTA]"  ~~ m/^<:Lo>$/ ), q{Don't match unrelated  (OtherLetter)} );
#?pugs todo
ok("\c[LATIN SMALL LETTER TURNED DELTA]"  ~~ m/^<:!Lo>$/, q{Match unrelated negated  (OtherLetter)} );
#?pugs todo
ok("\c[LATIN SMALL LETTER TURNED DELTA]"  ~~ m/^<-:Lo>$/, q{Match unrelated inverted  (OtherLetter)} );
ok(!( "\c[LATIN SMALL LETTER TURNED DELTA]" ~~ m/^<:Lo>$/ ), q{Don't match related  (OtherLetter)} );
#?pugs todo
ok("\c[LATIN SMALL LETTER TURNED DELTA]" ~~ m/^<:!Lo>$/, q{Match related negated  (OtherLetter)} );
#?pugs todo
ok("\c[LATIN SMALL LETTER TURNED DELTA]" ~~ m/^<-:Lo>$/, q{Match related inverted  (OtherLetter)} );
#?pugs todo
ok("\c[LATIN SMALL LETTER TURNED DELTA]\c[LATIN SMALL LETTER TURNED DELTA]\c[LATIN LETTER TWO WITH STROKE]" ~~ m/<:Lo>/, q{Match unanchored  (OtherLetter)} );

#?pugs todo
ok("\c[ETHIOPIC SYLLABLE GLOTTAL A]" ~~ m/^<:OtherLetter>$/, q{Match <:OtherLetter>} );
ok(!( "\c[ETHIOPIC SYLLABLE GLOTTAL A]" ~~ m/^<:!OtherLetter>$/ ), q{Don't match negated } );
ok(!( "\c[ETHIOPIC SYLLABLE GLOTTAL A]" ~~ m/^<-:OtherLetter>$/ ), q{Don't match inverted } );
#?rakudo 4 skip '\x[FFFF]'
ok(!( "\x[FFFF]"  ~~ m/^<:OtherLetter>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[FFFF]"  ~~ m/^<:!OtherLetter>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[FFFF]"  ~~ m/^<-:OtherLetter>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[FFFF]\c[ETHIOPIC SYLLABLE GLOTTAL A]" ~~ m/<:OtherLetter>/, q{Match unanchored } );

# Lr             # Alias for "Ll", "Lu", and "Lt".


#?rakudo 10 skip "No [Lr] property defined"
#?niecza 10 skip "No [Lr] property defined"
#?pugs todo
ok("\c[LATIN CAPITAL LETTER A]" ~~ m/^<:Lr>$/, q{Match (Alias for "Ll", "Lu", and "Lt".)} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<:!Lr>$/ ), q{Don't match negated (Alias for "Ll", "Lu", and "Lt".)} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<-:Lr>$/ ), q{Don't match inverted (Alias for "Ll", "Lu", and "Lt".)} );
ok(!( "\x[87B5]"  ~~ m/^<:Lr>$/ ), q{Don't match unrelated (Alias for "Ll", "Lu", and "Lt".)} );
#?pugs todo
ok("\x[87B5]"  ~~ m/^<:!Lr>$/, q{Match unrelated negated (Alias for "Ll", "Lu", and "Lt".)} );
#?pugs todo
ok("\x[87B5]"  ~~ m/^<-:Lr>$/, q{Match unrelated inverted (Alias for "Ll", "Lu", and "Lt".)} );
ok(!( "\x[87B5]" ~~ m/^<:Lr>$/ ), q{Don't match related (Alias for "Ll", "Lu", and "Lt".)} );
#?pugs todo
ok("\x[87B5]" ~~ m/^<:!Lr>$/, q{Match related negated (Alias for "Ll", "Lu", and "Lt".)} );
#?pugs todo
ok("\x[87B5]" ~~ m/^<-:Lr>$/, q{Match related inverted (Alias for "Ll", "Lu", and "Lt".)} );
#?pugs todo
ok("\x[87B5]\x[87B5]\c[LATIN CAPITAL LETTER A]" ~~ m/<:Lr>/, q{Match unanchored (Alias for "Ll", "Lu", and "Lt".)} );


# M           Mark


#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:M>$/, q{Match  (Mark)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!M>$/ ), q{Don't match negated  (Mark)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:M>$/ ), q{Don't match inverted  (Mark)} );
ok(!( "\x[D0AA]"  ~~ m/^<:M>$/ ), q{Don't match unrelated  (Mark)} );
#?pugs todo
ok("\x[D0AA]"  ~~ m/^<:!M>$/, q{Match unrelated negated  (Mark)} );
#?pugs todo
ok("\x[D0AA]"  ~~ m/^<-:M>$/, q{Match unrelated inverted  (Mark)} );
#?pugs todo
ok("\x[D0AA]\c[COMBINING GRAVE ACCENT]" ~~ m/<:M>/, q{Match unanchored  (Mark)} );

#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Mark>$/, q{Match <:Mark>} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!Mark>$/ ), q{Don't match negated } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Mark>$/ ), q{Don't match inverted } );
ok(!( "\x[BE64]"  ~~ m/^<:Mark>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BE64]"  ~~ m/^<:!Mark>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BE64]"  ~~ m/^<-:Mark>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BE64]\c[COMBINING GRAVE ACCENT]" ~~ m/<:Mark>/, q{Match unanchored } );

# Mn          NonspacingMark


#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Mn>$/, q{Match <:Mn> (NonspacingMark)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!Mn>$/ ), q{Don't match negated  (NonspacingMark)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Mn>$/ ), q{Don't match inverted  (NonspacingMark)} );
ok(!( "\x[47A5]"  ~~ m/^<:Mn>$/ ), q{Don't match unrelated  (NonspacingMark)} );
#?pugs todo
ok("\x[47A5]"  ~~ m/^<:!Mn>$/, q{Match unrelated negated  (NonspacingMark)} );
#?pugs todo
ok("\x[47A5]"  ~~ m/^<-:Mn>$/, q{Match unrelated inverted  (NonspacingMark)} );
ok(!( "\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<:Mn>$/ ), q{Don't match related  (NonspacingMark)} );
#?pugs todo
ok("\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<:!Mn>$/, q{Match related negated  (NonspacingMark)} );
#?pugs todo
ok("\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<-:Mn>$/, q{Match related inverted  (NonspacingMark)} );
#?pugs todo
ok("\x[47A5]\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]\c[COMBINING GRAVE ACCENT]" ~~ m/<:Mn>/, q{Match unanchored  (NonspacingMark)} );

#?pugs todo
ok("\c[TAGALOG VOWEL SIGN I]" ~~ m/^<:NonspacingMark>$/, q{Match <:NonspacingMark>} );
ok(!( "\c[TAGALOG VOWEL SIGN I]" ~~ m/^<:!NonspacingMark>$/ ), q{Don't match negated } );
ok(!( "\c[TAGALOG VOWEL SIGN I]" ~~ m/^<-:NonspacingMark>$/ ), q{Don't match inverted } );
ok(!( "\c[CANADIAN SYLLABICS TYA]"  ~~ m/^<:NonspacingMark>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS TYA]"  ~~ m/^<:!NonspacingMark>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS TYA]"  ~~ m/^<-:NonspacingMark>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS TYA]\c[TAGALOG VOWEL SIGN I]" ~~ m/<:NonspacingMark>/, q{Match unanchored } );

# Mc          SpacingMark


#?pugs todo
ok("\c[DEVANAGARI SIGN VISARGA]" ~~ m/^<:Mc>$/, q{Match <:Mc> (SpacingMark)} );
ok(!( "\c[DEVANAGARI SIGN VISARGA]" ~~ m/^<:!Mc>$/ ), q{Don't match negated  (SpacingMark)} );
ok(!( "\c[DEVANAGARI SIGN VISARGA]" ~~ m/^<-:Mc>$/ ), q{Don't match inverted  (SpacingMark)} );
ok(!( "\x[9981]"  ~~ m/^<:Mc>$/ ), q{Don't match unrelated  (SpacingMark)} );
#?pugs todo
ok("\x[9981]"  ~~ m/^<:!Mc>$/, q{Match unrelated negated  (SpacingMark)} );
#?pugs todo
ok("\x[9981]"  ~~ m/^<-:Mc>$/, q{Match unrelated inverted  (SpacingMark)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Mc>$/ ), q{Don't match related  (SpacingMark)} );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!Mc>$/, q{Match related negated  (SpacingMark)} );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Mc>$/, q{Match related inverted  (SpacingMark)} );
#?pugs todo
ok("\x[9981]\c[COMBINING GRAVE ACCENT]\c[DEVANAGARI SIGN VISARGA]" ~~ m/<:Mc>/, q{Match unanchored  (SpacingMark)} );

#?pugs todo
ok("\c[DEVANAGARI SIGN VISARGA]" ~~ m/^<:SpacingMark>$/, q{Match <:SpacingMark>} );
ok(!( "\c[DEVANAGARI SIGN VISARGA]" ~~ m/^<:!SpacingMark>$/ ), q{Don't match negated } );
ok(!( "\c[DEVANAGARI SIGN VISARGA]" ~~ m/^<-:SpacingMark>$/ ), q{Don't match inverted } );
ok(!( "\x[35E3]"  ~~ m/^<:SpacingMark>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[35E3]"  ~~ m/^<:!SpacingMark>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[35E3]"  ~~ m/^<-:SpacingMark>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[35E3]\c[DEVANAGARI SIGN VISARGA]" ~~ m/<:SpacingMark>/, q{Match unanchored } );

# Me          EnclosingMark


#?pugs todo
ok("\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<:Me>$/, q{Match <:Me> (EnclosingMark)} );
ok(!( "\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<:!Me>$/ ), q{Don't match negated  (EnclosingMark)} );
ok(!( "\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<-:Me>$/ ), q{Don't match inverted  (EnclosingMark)} );
ok(!( "\x[9400]"  ~~ m/^<:Me>$/ ), q{Don't match unrelated  (EnclosingMark)} );
#?pugs todo
ok("\x[9400]"  ~~ m/^<:!Me>$/, q{Match unrelated negated  (EnclosingMark)} );
#?pugs todo
ok("\x[9400]"  ~~ m/^<-:Me>$/, q{Match unrelated inverted  (EnclosingMark)} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Me>$/ ), q{Don't match related  (EnclosingMark)} );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!Me>$/, q{Match related negated  (EnclosingMark)} );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Me>$/, q{Match related inverted  (EnclosingMark)} );
#?pugs todo
ok("\x[9400]\c[COMBINING GRAVE ACCENT]\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/<:Me>/, q{Match unanchored  (EnclosingMark)} );

#?pugs todo
ok("\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<:EnclosingMark>$/, q{Match <:EnclosingMark>} );
ok(!( "\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<:!EnclosingMark>$/ ), q{Don't match negated } );
ok(!( "\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/^<-:EnclosingMark>$/ ), q{Don't match inverted } );
ok(!( "\x[7C68]"  ~~ m/^<:EnclosingMark>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7C68]"  ~~ m/^<:!EnclosingMark>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7C68]"  ~~ m/^<-:EnclosingMark>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7C68]\c[COMBINING CYRILLIC HUNDRED THOUSANDS SIGN]" ~~ m/<:EnclosingMark>/, q{Match unanchored } );


# N           Number


#?pugs todo
ok("\c[SUPERSCRIPT ZERO]" ~~ m/^<:N>$/, q{Match  (Number)} );
ok(!( "\c[SUPERSCRIPT ZERO]" ~~ m/^<:!N>$/ ), q{Don't match negated  (Number)} );
ok(!( "\c[SUPERSCRIPT ZERO]" ~~ m/^<-:N>$/ ), q{Don't match inverted  (Number)} );
ok(!( "\c[LATIN LETTER SMALL CAPITAL E]"  ~~ m/^<:N>$/ ), q{Don't match unrelated  (Number)} );
#?pugs todo
ok("\c[LATIN LETTER SMALL CAPITAL E]"  ~~ m/^<:!N>$/, q{Match unrelated negated  (Number)} );
#?pugs todo
ok("\c[LATIN LETTER SMALL CAPITAL E]"  ~~ m/^<-:N>$/, q{Match unrelated inverted  (Number)} );
#?pugs todo
ok("\c[LATIN LETTER SMALL CAPITAL E]\c[SUPERSCRIPT ZERO]" ~~ m/<:N>/, q{Match unanchored  (Number)} );

#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:Number>$/, q{Match <:Number>} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:!Number>$/ ), q{Don't match negated } );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<-:Number>$/ ), q{Don't match inverted } );
ok(!( "\x[A994]"  ~~ m/^<:Number>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[A994]"  ~~ m/^<:!Number>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[A994]"  ~~ m/^<-:Number>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[A994]\c[DIGIT ZERO]" ~~ m/<:Number>/, q{Match unanchored } );

# Nd          DecimalNumber


#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:Nd>$/, q{Match <:Nd> (DecimalNumber)} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:!Nd>$/ ), q{Don't match negated  (DecimalNumber)} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<-:Nd>$/ ), q{Don't match inverted  (DecimalNumber)} );
ok(!( "\x[4E2C]"  ~~ m/^<:Nd>$/ ), q{Don't match unrelated  (DecimalNumber)} );
#?pugs todo
ok("\x[4E2C]"  ~~ m/^<:!Nd>$/, q{Match unrelated negated  (DecimalNumber)} );
#?pugs todo
ok("\x[4E2C]"  ~~ m/^<-:Nd>$/, q{Match unrelated inverted  (DecimalNumber)} );
ok(!( "\c[SUPERSCRIPT TWO]" ~~ m/^<:Nd>$/ ), q{Don't match related  (DecimalNumber)} );
#?pugs todo
ok("\c[SUPERSCRIPT TWO]" ~~ m/^<:!Nd>$/, q{Match related negated  (DecimalNumber)} );
#?pugs todo
ok("\c[SUPERSCRIPT TWO]" ~~ m/^<-:Nd>$/, q{Match related inverted  (DecimalNumber)} );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[4E2C]\c[SUPERSCRIPT TWO]\c[DIGIT ZERO]" ~~ m/<:Nd>/, q{Match unanchored  (DecimalNumber)} );
#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:DecimalNumber>$/, q{Match <:DecimalNumber>} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:!DecimalNumber>$/ ), q{Don't match negated } );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<-:DecimalNumber>$/ ), q{Don't match inverted } );
ok(!( "\x[A652]"  ~~ m/^<:DecimalNumber>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[A652]"  ~~ m/^<:!DecimalNumber>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[A652]"  ~~ m/^<-:DecimalNumber>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[A652]\c[DIGIT ZERO]" ~~ m/<:DecimalNumber>/, q{Match unanchored } );


# Nl          LetterNumber


#?pugs todo
ok("\c[RUNIC ARLAUG SYMBOL]" ~~ m/^<:Nl>$/, q{Match <:Nl> (LetterNumber)} );
ok(!( "\c[RUNIC ARLAUG SYMBOL]" ~~ m/^<:!Nl>$/ ), q{Don't match negated  (LetterNumber)} );
ok(!( "\c[RUNIC ARLAUG SYMBOL]" ~~ m/^<-:Nl>$/ ), q{Don't match inverted  (LetterNumber)} );
ok(!( "\x[6C2F]"  ~~ m/^<:Nl>$/ ), q{Don't match unrelated  (LetterNumber)} );
#?pugs todo
ok("\x[6C2F]"  ~~ m/^<:!Nl>$/, q{Match unrelated negated  (LetterNumber)} );
#?pugs todo
ok("\x[6C2F]"  ~~ m/^<-:Nl>$/, q{Match unrelated inverted  (LetterNumber)} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:Nl>$/ ), q{Don't match related  (LetterNumber)} );
#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:!Nl>$/, q{Match related negated  (LetterNumber)} );
#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<-:Nl>$/, q{Match related inverted  (LetterNumber)} );
#?pugs todo
ok("\x[6C2F]\c[DIGIT ZERO]\c[RUNIC ARLAUG SYMBOL]" ~~ m/<:Nl>/, q{Match unanchored  (LetterNumber)} );

#?pugs todo
ok("\c[RUNIC ARLAUG SYMBOL]" ~~ m/^<:LetterNumber>$/, q{Match <:LetterNumber>} );
ok(!( "\c[RUNIC ARLAUG SYMBOL]" ~~ m/^<:!LetterNumber>$/ ), q{Don't match negated } );
ok(!( "\c[RUNIC ARLAUG SYMBOL]" ~~ m/^<-:LetterNumber>$/ ), q{Don't match inverted } );
ok(!( "\x[80A5]"  ~~ m/^<:LetterNumber>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[80A5]"  ~~ m/^<:!LetterNumber>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[80A5]"  ~~ m/^<-:LetterNumber>$/, q{Match unrelated inverted } );
ok(!( "\x[80A5]" ~~ m/^<:LetterNumber>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[80A5]" ~~ m/^<:!LetterNumber>$/, q{Match related negated } );
#?pugs todo
ok("\x[80A5]" ~~ m/^<-:LetterNumber>$/, q{Match related inverted } );
#?pugs todo
ok("\x[80A5]\x[80A5]\c[RUNIC ARLAUG SYMBOL]" ~~ m/<:LetterNumber>/, q{Match unanchored } );

# No          OtherNumber


#?pugs todo
ok("\c[SUPERSCRIPT TWO]" ~~ m/^<:No>$/, q{Match <:No> (OtherNumber)} );
ok(!( "\c[SUPERSCRIPT TWO]" ~~ m/^<:!No>$/ ), q{Don't match negated  (OtherNumber)} );
ok(!( "\c[SUPERSCRIPT TWO]" ~~ m/^<-:No>$/ ), q{Don't match inverted  (OtherNumber)} );
ok(!( "\x[92F3]"  ~~ m/^<:No>$/ ), q{Don't match unrelated  (OtherNumber)} );
#?pugs todo
ok("\x[92F3]"  ~~ m/^<:!No>$/, q{Match unrelated negated  (OtherNumber)} );
#?pugs todo
ok("\x[92F3]"  ~~ m/^<-:No>$/, q{Match unrelated inverted  (OtherNumber)} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<:No>$/ ), q{Don't match related  (OtherNumber)} );
#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:!No>$/, q{Match related negated  (OtherNumber)} );
#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<-:No>$/, q{Match related inverted  (OtherNumber)} );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[92F3]\c[DIGIT ZERO]\c[SUPERSCRIPT TWO]" ~~ m/<:No>/, q{Match unanchored  (OtherNumber)} );

#?pugs todo
ok("\c[SUPERSCRIPT TWO]" ~~ m/^<:OtherNumber>$/, q{Match <:OtherNumber>} );
ok(!( "\c[SUPERSCRIPT TWO]" ~~ m/^<:!OtherNumber>$/ ), q{Don't match negated } );
ok(!( "\c[SUPERSCRIPT TWO]" ~~ m/^<-:OtherNumber>$/ ), q{Don't match inverted } );
ok(!( "\x[5363]"  ~~ m/^<:OtherNumber>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5363]"  ~~ m/^<:!OtherNumber>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5363]"  ~~ m/^<-:OtherNumber>$/, q{Match unrelated inverted } );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[5363]\c[SUPERSCRIPT TWO]" ~~ m/<:OtherNumber>/, q{Match unanchored } );

# P           Punctuation


#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:P>$/, q{Match 
 (Punctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:!P>$/ ), q{Don't match negated 
 (Punctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<-:P>$/ ), q{Don't match inverted 
 (Punctuation)} );
ok(!( "\x[A918]"  ~~ m/^<:P>$/ ), q{Don't match unrelated 
 (Punctuation)} );
#?pugs todo
ok("\x[A918]"  ~~ m/^<:!P>$/, q{Match unrelated negated 
 (Punctuation)} );
#?pugs todo
ok("\x[A918]"  ~~ m/^<-:P>$/, q{Match unrelated inverted 
 (Punctuation)} );
#?pugs todo
ok("\x[A918]\c[EXCLAMATION MARK]" ~~ m/<:P>/, q{Match unanchored 
 (Punctuation)} );

#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:Punctuation>$/, q{Match <:Punctuation>} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:!Punctuation>$/ ), q{Don't match negated } );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<-:Punctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[CE60]"  ~~ m/^<:Punctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[CE60]"  ~~ m/^<:!Punctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[CE60]"  ~~ m/^<-:Punctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[CE60]\c[EXCLAMATION MARK]" ~~ m/<:Punctuation>/, q{Match unanchored } );

# Pc          ConnectorPunctuation


#?pugs todo
ok("\c[LOW LINE]" ~~ m/^<:Pc>$/, q{Match <:Pc> (ConnectorPunctuation)} );
ok(!( "\c[LOW LINE]" ~~ m/^<:!Pc>$/ ), q{Don't match negated  (ConnectorPunctuation)} );
ok(!( "\c[LOW LINE]" ~~ m/^<-:Pc>$/ ), q{Don't match inverted  (ConnectorPunctuation)} );
ok(!( "\x[5F19]"  ~~ m/^<:Pc>$/ ), q{Don't match unrelated  (ConnectorPunctuation)} );
#?pugs todo
ok("\x[5F19]"  ~~ m/^<:!Pc>$/, q{Match unrelated negated  (ConnectorPunctuation)} );
#?pugs todo
ok("\x[5F19]"  ~~ m/^<-:Pc>$/, q{Match unrelated inverted  (ConnectorPunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:Pc>$/ ), q{Don't match related  (ConnectorPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:!Pc>$/, q{Match related negated  (ConnectorPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<-:Pc>$/, q{Match related inverted  (ConnectorPunctuation)} );
#?pugs todo
ok("\x[5F19]\c[EXCLAMATION MARK]\c[LOW LINE]" ~~ m/<:Pc>/, q{Match unanchored  (ConnectorPunctuation)} );

#?pugs todo
ok("\c[LOW LINE]" ~~ m/^<:ConnectorPunctuation>$/, q{Match <:ConnectorPunctuation>} );
ok(!( "\c[LOW LINE]" ~~ m/^<:!ConnectorPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[LOW LINE]" ~~ m/^<-:ConnectorPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE MGOX]"  ~~ m/^<:ConnectorPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE MGOX]"  ~~ m/^<:!ConnectorPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE MGOX]"  ~~ m/^<-:ConnectorPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE MGOX]\c[LOW LINE]" ~~ m/<:ConnectorPunctuation>/, q{Match unanchored } );

# Pd          DashPunctuation


#?pugs todo
ok("\c[HYPHEN-MINUS]" ~~ m/^<:Pd>$/, q{Match <:Pd> (DashPunctuation)} );
ok(!( "\c[HYPHEN-MINUS]" ~~ m/^<:!Pd>$/ ), q{Don't match negated  (DashPunctuation)} );
ok(!( "\c[HYPHEN-MINUS]" ~~ m/^<-:Pd>$/ ), q{Don't match inverted  (DashPunctuation)} );
ok(!( "\x[49A1]"  ~~ m/^<:Pd>$/ ), q{Don't match unrelated  (DashPunctuation)} );
#?pugs todo
ok("\x[49A1]"  ~~ m/^<:!Pd>$/, q{Match unrelated negated  (DashPunctuation)} );
#?pugs todo
ok("\x[49A1]"  ~~ m/^<-:Pd>$/, q{Match unrelated inverted  (DashPunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:Pd>$/ ), q{Don't match related  (DashPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:!Pd>$/, q{Match related negated  (DashPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<-:Pd>$/, q{Match related inverted  (DashPunctuation)} );
#?pugs todo
ok("\x[49A1]\c[EXCLAMATION MARK]\c[HYPHEN-MINUS]" ~~ m/<:Pd>/, q{Match unanchored  (DashPunctuation)} );

#?pugs todo
ok("\c[HYPHEN-MINUS]" ~~ m/^<:DashPunctuation>$/, q{Match <:DashPunctuation>} );
ok(!( "\c[HYPHEN-MINUS]" ~~ m/^<:!DashPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[HYPHEN-MINUS]" ~~ m/^<-:DashPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[3C6E]"  ~~ m/^<:DashPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3C6E]"  ~~ m/^<:!DashPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3C6E]"  ~~ m/^<-:DashPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3C6E]\c[HYPHEN-MINUS]" ~~ m/<:DashPunctuation>/, q{Match unanchored } );

# Ps          OpenPunctuation


#?pugs todo
ok("\c[LEFT PARENTHESIS]" ~~ m/^<:Ps>$/, q{Match <:Ps> (OpenPunctuation)} );
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<:!Ps>$/ ), q{Don't match negated  (OpenPunctuation)} );
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<-:Ps>$/ ), q{Don't match inverted  (OpenPunctuation)} );
ok(!( "\x[C8A5]"  ~~ m/^<:Ps>$/ ), q{Don't match unrelated  (OpenPunctuation)} );
#?pugs todo
ok("\x[C8A5]"  ~~ m/^<:!Ps>$/, q{Match unrelated negated  (OpenPunctuation)} );
#?pugs todo
ok("\x[C8A5]"  ~~ m/^<-:Ps>$/, q{Match unrelated inverted  (OpenPunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:Ps>$/ ), q{Don't match related  (OpenPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:!Ps>$/, q{Match related negated  (OpenPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<-:Ps>$/, q{Match related inverted  (OpenPunctuation)} );
#?pugs todo
ok("\x[C8A5]\c[EXCLAMATION MARK]\c[LEFT PARENTHESIS]" ~~ m/<:Ps>/, q{Match unanchored  (OpenPunctuation)} );

#?pugs todo
ok("\c[LEFT PARENTHESIS]" ~~ m/^<:OpenPunctuation>$/, q{Match <:OpenPunctuation>} );
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<:!OpenPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<-:OpenPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[84B8]"  ~~ m/^<:OpenPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[84B8]"  ~~ m/^<:!OpenPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[84B8]"  ~~ m/^<-:OpenPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[84B8]\c[LEFT PARENTHESIS]" ~~ m/<:OpenPunctuation>/, q{Match unanchored } );

# Pe          ClosePunctuation


#?pugs todo
ok("\c[RIGHT PARENTHESIS]" ~~ m/^<:Pe>$/, q{Match <:Pe> (ClosePunctuation)} );
ok(!( "\c[RIGHT PARENTHESIS]" ~~ m/^<:!Pe>$/ ), q{Don't match negated  (ClosePunctuation)} );
ok(!( "\c[RIGHT PARENTHESIS]" ~~ m/^<-:Pe>$/ ), q{Don't match inverted  (ClosePunctuation)} );
ok(!( "\x[BB92]"  ~~ m/^<:Pe>$/ ), q{Don't match unrelated  (ClosePunctuation)} );
#?pugs todo
ok("\x[BB92]"  ~~ m/^<:!Pe>$/, q{Match unrelated negated  (ClosePunctuation)} );
#?pugs todo
ok("\x[BB92]"  ~~ m/^<-:Pe>$/, q{Match unrelated inverted  (ClosePunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:Pe>$/ ), q{Don't match related  (ClosePunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:!Pe>$/, q{Match related negated  (ClosePunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<-:Pe>$/, q{Match related inverted  (ClosePunctuation)} );
#?pugs todo
ok("\x[BB92]\c[EXCLAMATION MARK]\c[RIGHT PARENTHESIS]" ~~ m/<:Pe>/, q{Match unanchored  (ClosePunctuation)} );

#?pugs todo
ok("\c[RIGHT PARENTHESIS]" ~~ m/^<:ClosePunctuation>$/, q{Match <:ClosePunctuation>} );
ok(!( "\c[RIGHT PARENTHESIS]" ~~ m/^<:!ClosePunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[RIGHT PARENTHESIS]" ~~ m/^<-:ClosePunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[D55D]"  ~~ m/^<:ClosePunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D55D]"  ~~ m/^<:!ClosePunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D55D]"  ~~ m/^<-:ClosePunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D55D]\c[RIGHT PARENTHESIS]" ~~ m/<:ClosePunctuation>/, q{Match unanchored } );

# Pi          InitialPunctuation


#?pugs todo
ok("\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:Pi>$/, q{Match <:Pi> (InitialPunctuation)} );
ok(!( "\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:!Pi>$/ ), q{Don't match negated  (InitialPunctuation)} );
ok(!( "\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<-:Pi>$/ ), q{Don't match inverted  (InitialPunctuation)} );
ok(!( "\x[3A35]"  ~~ m/^<:Pi>$/ ), q{Don't match unrelated  (InitialPunctuation)} );
#?pugs todo
ok("\x[3A35]"  ~~ m/^<:!Pi>$/, q{Match unrelated negated  (InitialPunctuation)} );
#?pugs todo
ok("\x[3A35]"  ~~ m/^<-:Pi>$/, q{Match unrelated inverted  (InitialPunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:Pi>$/ ), q{Don't match related  (InitialPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:!Pi>$/, q{Match related negated  (InitialPunctuation)} );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<-:Pi>$/, q{Match related inverted  (InitialPunctuation)} );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[3A35]\c[EXCLAMATION MARK]\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/<:Pi>/, q{Match unanchored  (InitialPunctuation)} );

#?pugs todo
ok("\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:InitialPunctuation>$/, q{Match <:InitialPunctuation>} );
ok(!( "\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:!InitialPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<-:InitialPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[B84F]"  ~~ m/^<:InitialPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B84F]"  ~~ m/^<:!InitialPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B84F]"  ~~ m/^<-:InitialPunctuation>$/, q{Match unrelated inverted } );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[B84F]\c[LEFT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/<:InitialPunctuation>/, q{Match unanchored } );

# Pf          FinalPunctuation


#?pugs todo
ok("\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:Pf>$/, q{Match <:Pf> (FinalPunctuation)} );
ok(!( "\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:!Pf>$/ ), q{Don't match negated  (FinalPunctuation)} );
ok(!( "\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<-:Pf>$/ ), q{Don't match inverted  (FinalPunctuation)} );
ok(!( "\x[27CF]"  ~~ m/^<:Pf>$/ ), q{Don't match unrelated  (FinalPunctuation)} );
#?pugs todo
ok("\x[27CF]"  ~~ m/^<:!Pf>$/, q{Match unrelated negated  (FinalPunctuation)} );
#?pugs todo
ok("\x[27CF]"  ~~ m/^<-:Pf>$/, q{Match unrelated inverted  (FinalPunctuation)} );
ok(!( "\c[MATHEMATICAL LEFT WHITE SQUARE BRACKET]" ~~ m/^<:Pf>$/ ), q{Don't match related  (FinalPunctuation)} );
#?pugs todo
ok("\c[MATHEMATICAL LEFT WHITE SQUARE BRACKET]" ~~ m/^<:!Pf>$/, q{Match related negated  (FinalPunctuation)} );
#?pugs todo
ok("\c[MATHEMATICAL LEFT WHITE SQUARE BRACKET]" ~~ m/^<-:Pf>$/, q{Match related inverted  (FinalPunctuation)} );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[27CF]\c[MATHEMATICAL LEFT WHITE SQUARE BRACKET]\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/<:Pf>/, q{Match unanchored  (FinalPunctuation)} );

#?pugs todo
ok("\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:FinalPunctuation>$/, q{Match <:FinalPunctuation>} );
ok(!( "\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<:!FinalPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/^<-:FinalPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[4F65]"  ~~ m/^<:FinalPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4F65]"  ~~ m/^<:!FinalPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4F65]"  ~~ m/^<-:FinalPunctuation>$/, q{Match unrelated inverted } );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[4F65]\c[RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK]" ~~ m/<:FinalPunctuation>/, q{Match unanchored } );

# Po          OtherPunctuation


#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:Po>$/, q{Match <:Po> (OtherPunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:!Po>$/ ), q{Don't match negated  (OtherPunctuation)} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<-:Po>$/ ), q{Don't match inverted  (OtherPunctuation)} );
ok(!( "\x[AA74]"  ~~ m/^<:Po>$/ ), q{Don't match unrelated  (OtherPunctuation)} );
#?pugs todo
ok("\x[AA74]"  ~~ m/^<:!Po>$/, q{Match unrelated negated  (OtherPunctuation)} );
#?pugs todo
ok("\x[AA74]"  ~~ m/^<-:Po>$/, q{Match unrelated inverted  (OtherPunctuation)} );
ok(!( "\c[LEFT PARENTHESIS]" ~~ m/^<:Po>$/ ), q{Don't match related  (OtherPunctuation)} );
#?pugs todo
ok("\c[LEFT PARENTHESIS]" ~~ m/^<:!Po>$/, q{Match related negated  (OtherPunctuation)} );
#?pugs todo
ok("\c[LEFT PARENTHESIS]" ~~ m/^<-:Po>$/, q{Match related inverted  (OtherPunctuation)} );
#?pugs todo
ok("\x[AA74]\c[LEFT PARENTHESIS]\c[EXCLAMATION MARK]" ~~ m/<:Po>/, q{Match unanchored  (OtherPunctuation)} );

#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:OtherPunctuation>$/, q{Match <:OtherPunctuation>} );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:!OtherPunctuation>$/ ), q{Don't match negated } );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<-:OtherPunctuation>$/ ), q{Don't match inverted } );
ok(!( "\x[7DD2]"  ~~ m/^<:OtherPunctuation>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7DD2]"  ~~ m/^<:!OtherPunctuation>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7DD2]"  ~~ m/^<-:OtherPunctuation>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7DD2]\c[EXCLAMATION MARK]" ~~ m/<:OtherPunctuation>/, q{Match unanchored } );

# S           Symbol


#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<:S>$/, q{Match  (Symbol)} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:!S>$/ ), q{Don't match negated  (Symbol)} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<-:S>$/ ), q{Don't match inverted  (Symbol)} );
ok(!( "\x[8839]"  ~~ m/^<:S>$/ ), q{Don't match unrelated  (Symbol)} );
#?pugs todo
ok("\x[8839]"  ~~ m/^<:!S>$/, q{Match unrelated negated  (Symbol)} );
#?pugs todo
ok("\x[8839]"  ~~ m/^<-:S>$/, q{Match unrelated inverted  (Symbol)} );
#?pugs todo
ok("\x[8839]\c[YI RADICAL QOT]" ~~ m/<:S>/, q{Match unanchored  (Symbol)} );

#?pugs todo
ok("\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/^<:Symbol>$/, q{Match <:Symbol>} );
ok(!( "\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/^<:!Symbol>$/ ), q{Don't match negated } );
ok(!( "\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/^<-:Symbol>$/ ), q{Don't match inverted } );
ok(!( "\x[4A1C]"  ~~ m/^<:Symbol>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4A1C]"  ~~ m/^<:!Symbol>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4A1C]"  ~~ m/^<-:Symbol>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[4A1C]\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/<:Symbol>/, q{Match unanchored } );

# Sm          MathSymbol


#?pugs todo
ok("\c[PLUS SIGN]" ~~ m/^<:Sm>$/, q{Match <:Sm> (MathSymbol)} );
ok(!( "\c[PLUS SIGN]" ~~ m/^<:!Sm>$/ ), q{Don't match negated  (MathSymbol)} );
ok(!( "\c[PLUS SIGN]" ~~ m/^<-:Sm>$/ ), q{Don't match inverted  (MathSymbol)} );
ok(!( "\x[B258]"  ~~ m/^<:Sm>$/ ), q{Don't match unrelated  (MathSymbol)} );
#?pugs todo
ok("\x[B258]"  ~~ m/^<:!Sm>$/, q{Match unrelated negated  (MathSymbol)} );
#?pugs todo
ok("\x[B258]"  ~~ m/^<-:Sm>$/, q{Match unrelated inverted  (MathSymbol)} );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<:Sm>$/ ), q{Don't match related  (MathSymbol)} );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<:!Sm>$/, q{Match related negated  (MathSymbol)} );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<-:Sm>$/, q{Match related inverted  (MathSymbol)} );
#?pugs todo
ok("\x[B258]\c[DOLLAR SIGN]\c[PLUS SIGN]" ~~ m/<:Sm>/, q{Match unanchored  (MathSymbol)} );

#?pugs todo
ok("\c[PLUS SIGN]" ~~ m/^<:MathSymbol>$/, q{Match <:MathSymbol>} );
ok(!( "\c[PLUS SIGN]" ~~ m/^<:!MathSymbol>$/ ), q{Don't match negated } );
ok(!( "\c[PLUS SIGN]" ~~ m/^<-:MathSymbol>$/ ), q{Don't match inverted } );
ok(!( "\x[98FF]"  ~~ m/^<:MathSymbol>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[98FF]"  ~~ m/^<:!MathSymbol>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[98FF]"  ~~ m/^<-:MathSymbol>$/, q{Match unrelated inverted } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:MathSymbol>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!MathSymbol>$/, q{Match related negated } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:MathSymbol>$/, q{Match related inverted } );
#?pugs todo
ok("\x[98FF]\c[COMBINING GRAVE ACCENT]\c[PLUS SIGN]" ~~ m/<:MathSymbol>/, q{Match unanchored } );

# Sc          CurrencySymbol

#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<:Sc>$/, q{Match <:Sc> (CurrencySymbol)} );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<:!Sc>$/ ), q{Don't match negated  (CurrencySymbol)} );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<-:Sc>$/ ), q{Don't match inverted  (CurrencySymbol)} );
ok(!( "\x[994C]"  ~~ m/^<:Sc>$/ ), q{Don't match unrelated  (CurrencySymbol)} );
#?pugs todo
ok("\x[994C]"  ~~ m/^<:!Sc>$/, q{Match unrelated negated  (CurrencySymbol)} );
#?pugs todo
ok("\x[994C]"  ~~ m/^<-:Sc>$/, q{Match unrelated inverted  (CurrencySymbol)} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:Sc>$/ ), q{Don't match related  (CurrencySymbol)} );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<:!Sc>$/, q{Match related negated  (CurrencySymbol)} );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<-:Sc>$/, q{Match related inverted  (CurrencySymbol)} );
#?pugs todo
ok("\x[994C]\c[YI RADICAL QOT]\c[DOLLAR SIGN]" ~~ m/<:Sc>/, q{Match unanchored  (CurrencySymbol)} );

#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<:CurrencySymbol>$/, q{Match <:CurrencySymbol>} );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<:!CurrencySymbol>$/ ), q{Don't match negated } );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<-:CurrencySymbol>$/ ), q{Don't match inverted } );
ok(!( "\x[37C0]"  ~~ m/^<:CurrencySymbol>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[37C0]"  ~~ m/^<:!CurrencySymbol>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[37C0]"  ~~ m/^<-:CurrencySymbol>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[37C0]\c[DOLLAR SIGN]" ~~ m/<:CurrencySymbol>/, q{Match unanchored } );

# Sk          ModifierSymbol


#?pugs todo
ok("\c[CIRCUMFLEX ACCENT]" ~~ m/^<:Sk>$/, q{Match <:Sk> (ModifierSymbol)} );
ok(!( "\c[CIRCUMFLEX ACCENT]" ~~ m/^<:!Sk>$/ ), q{Don't match negated  (ModifierSymbol)} );
ok(!( "\c[CIRCUMFLEX ACCENT]" ~~ m/^<-:Sk>$/ ), q{Don't match inverted  (ModifierSymbol)} );
ok(!( "\x[4578]"  ~~ m/^<:Sk>$/ ), q{Don't match unrelated  (ModifierSymbol)} );
#?pugs todo
ok("\x[4578]"  ~~ m/^<:!Sk>$/, q{Match unrelated negated  (ModifierSymbol)} );
#?pugs todo
ok("\x[4578]"  ~~ m/^<-:Sk>$/, q{Match unrelated inverted  (ModifierSymbol)} );
ok(!( "\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/^<:Sk>$/ ), q{Don't match related  (ModifierSymbol)} );
#?pugs todo
ok("\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/^<:!Sk>$/, q{Match related negated  (ModifierSymbol)} );
#?pugs todo
ok("\c[HEXAGRAM FOR THE CREATIVE HEAVEN]" ~~ m/^<-:Sk>$/, q{Match related inverted  (ModifierSymbol)} );
#?pugs todo
ok("\x[4578]\c[HEXAGRAM FOR THE CREATIVE HEAVEN]\c[CIRCUMFLEX ACCENT]" ~~ m/<:Sk>/, q{Match unanchored  (ModifierSymbol)} );

#?pugs todo
ok("\c[CIRCUMFLEX ACCENT]" ~~ m/^<:ModifierSymbol>$/, q{Match <:ModifierSymbol>} );
ok(!( "\c[CIRCUMFLEX ACCENT]" ~~ m/^<:!ModifierSymbol>$/ ), q{Don't match negated } );
ok(!( "\c[CIRCUMFLEX ACCENT]" ~~ m/^<-:ModifierSymbol>$/ ), q{Don't match inverted } );
ok(!( "\x[42F1]"  ~~ m/^<:ModifierSymbol>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[42F1]"  ~~ m/^<:!ModifierSymbol>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[42F1]"  ~~ m/^<-:ModifierSymbol>$/, q{Match unrelated inverted } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:ModifierSymbol>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:!ModifierSymbol>$/, q{Match related negated } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:ModifierSymbol>$/, q{Match related inverted } );
#?pugs todo
ok("\x[42F1]\c[COMBINING GRAVE ACCENT]\c[CIRCUMFLEX ACCENT]" ~~ m/<:ModifierSymbol>/, q{Match unanchored } );

# So          OtherSymbol


#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<:So>$/, q{Match <:So> (OtherSymbol)} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:!So>$/ ), q{Don't match negated  (OtherSymbol)} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<-:So>$/ ), q{Don't match inverted  (OtherSymbol)} );
ok(!( "\x[83DE]"  ~~ m/^<:So>$/ ), q{Don't match unrelated  (OtherSymbol)} );
#?pugs todo
ok("\x[83DE]"  ~~ m/^<:!So>$/, q{Match unrelated negated  (OtherSymbol)} );
#?pugs todo
ok("\x[83DE]"  ~~ m/^<-:So>$/, q{Match unrelated inverted  (OtherSymbol)} );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<:So>$/ ), q{Don't match related  (OtherSymbol)} );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<:!So>$/, q{Match related negated  (OtherSymbol)} );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<-:So>$/, q{Match related inverted  (OtherSymbol)} );
#?pugs todo
ok("\x[83DE]\c[DOLLAR SIGN]\c[YI RADICAL QOT]" ~~ m/<:So>/, q{Match unanchored  (OtherSymbol)} );

#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<:OtherSymbol>$/, q{Match <:OtherSymbol>} );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:!OtherSymbol>$/ ), q{Don't match negated } );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<-:OtherSymbol>$/ ), q{Don't match inverted } );
ok(!( "\x[9B2C]"  ~~ m/^<:OtherSymbol>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9B2C]"  ~~ m/^<:!OtherSymbol>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9B2C]"  ~~ m/^<-:OtherSymbol>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9B2C]\c[YI RADICAL QOT]" ~~ m/<:OtherSymbol>/, q{Match unanchored } );

# Z           Separator


#?pugs todo
ok("\c[IDEOGRAPHIC SPACE]" ~~ m/^<:Z>$/, q{Match  (Separator)} );
ok(!( "\c[IDEOGRAPHIC SPACE]" ~~ m/^<:!Z>$/ ), q{Don't match negated  (Separator)} );
ok(!( "\c[IDEOGRAPHIC SPACE]" ~~ m/^<-:Z>$/ ), q{Don't match inverted  (Separator)} );
ok(!( "\x[2C08]"  ~~ m/^<:Z>$/ ), q{Don't match unrelated  (Separator)} );
#?pugs todo
ok("\x[2C08]"  ~~ m/^<:!Z>$/, q{Match unrelated negated  (Separator)} );
#?pugs todo
ok("\x[2C08]"  ~~ m/^<-:Z>$/, q{Match unrelated inverted  (Separator)} );
#?pugs todo
ok("\x[2C08]\c[IDEOGRAPHIC SPACE]" ~~ m/<:Z>/, q{Match unanchored  (Separator)} );

#?pugs todo
ok("\c[SPACE]" ~~ m/^<:Separator>$/, q{Match <:Separator>} );
ok(!( "\c[SPACE]" ~~ m/^<:!Separator>$/ ), q{Don't match negated } );
ok(!( "\c[SPACE]" ~~ m/^<-:Separator>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE SOX]"  ~~ m/^<:Separator>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE SOX]"  ~~ m/^<:!Separator>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE SOX]"  ~~ m/^<-:Separator>$/, q{Match unrelated inverted } );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:Separator>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<:!Separator>$/, q{Match related negated } );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<-:Separator>$/, q{Match related inverted } );
#?pugs todo
ok("\c[YI SYLLABLE SOX]\c[YI RADICAL QOT]\c[SPACE]" ~~ m/<:Separator>/, q{Match unanchored } );

# Zs          SpaceSeparator


#?pugs todo
ok("\c[SPACE]" ~~ m/^<:Zs>$/, q{Match <:Zs> (SpaceSeparator)} );
ok(!( "\c[SPACE]" ~~ m/^<:!Zs>$/ ), q{Don't match negated  (SpaceSeparator)} );
ok(!( "\c[SPACE]" ~~ m/^<-:Zs>$/ ), q{Don't match inverted  (SpaceSeparator)} );
ok(!( "\x[88DD]"  ~~ m/^<:Zs>$/ ), q{Don't match unrelated  (SpaceSeparator)} );
#?pugs todo
ok("\x[88DD]"  ~~ m/^<:!Zs>$/, q{Match unrelated negated  (SpaceSeparator)} );
#?pugs todo
ok("\x[88DD]"  ~~ m/^<-:Zs>$/, q{Match unrelated inverted  (SpaceSeparator)} );
ok(!( "\c[LINE SEPARATOR]" ~~ m/^<:Zs>$/ ), q{Don't match related  (SpaceSeparator)} );
#?pugs todo
ok("\c[LINE SEPARATOR]" ~~ m/^<:!Zs>$/, q{Match related negated  (SpaceSeparator)} );
#?pugs todo
ok("\c[LINE SEPARATOR]" ~~ m/^<-:Zs>$/, q{Match related inverted  (SpaceSeparator)} );
#?pugs todo
ok("\x[88DD]\c[LINE SEPARATOR]\c[SPACE]" ~~ m/<:Zs>/, q{Match unanchored  (SpaceSeparator)} );

#?pugs todo
ok("\c[SPACE]" ~~ m/^<:SpaceSeparator>$/, q{Match <:SpaceSeparator>} );
ok(!( "\c[SPACE]" ~~ m/^<:!SpaceSeparator>$/ ), q{Don't match negated } );
ok(!( "\c[SPACE]" ~~ m/^<-:SpaceSeparator>$/ ), q{Don't match inverted } );
ok(!( "\x[C808]"  ~~ m/^<:SpaceSeparator>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C808]"  ~~ m/^<:!SpaceSeparator>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C808]"  ~~ m/^<-:SpaceSeparator>$/, q{Match unrelated inverted } );
ok(!( "\c[DOLLAR SIGN]" ~~ m/^<:SpaceSeparator>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<:!SpaceSeparator>$/, q{Match related negated } );
#?pugs todo
ok("\c[DOLLAR SIGN]" ~~ m/^<-:SpaceSeparator>$/, q{Match related inverted } );
#?pugs todo
ok("\x[C808]\c[DOLLAR SIGN]\c[SPACE]" ~~ m/<:SpaceSeparator>/, q{Match unanchored } );

# Zl          LineSeparator


#?pugs todo
ok("\c[LINE SEPARATOR]" ~~ m/^<:Zl>$/, q{Match <:Zl> (LineSeparator)} );
ok(!( "\c[LINE SEPARATOR]" ~~ m/^<:!Zl>$/ ), q{Don't match negated  (LineSeparator)} );
ok(!( "\c[LINE SEPARATOR]" ~~ m/^<-:Zl>$/ ), q{Don't match inverted  (LineSeparator)} );
ok(!( "\x[B822]"  ~~ m/^<:Zl>$/ ), q{Don't match unrelated  (LineSeparator)} );
#?pugs todo
ok("\x[B822]"  ~~ m/^<:!Zl>$/, q{Match unrelated negated  (LineSeparator)} );
#?pugs todo
ok("\x[B822]"  ~~ m/^<-:Zl>$/, q{Match unrelated inverted  (LineSeparator)} );
ok(!( "\c[SPACE]" ~~ m/^<:Zl>$/ ), q{Don't match related  (LineSeparator)} );
#?pugs todo
ok("\c[SPACE]" ~~ m/^<:!Zl>$/, q{Match related negated  (LineSeparator)} );
#?pugs todo
ok("\c[SPACE]" ~~ m/^<-:Zl>$/, q{Match related inverted  (LineSeparator)} );
#?pugs todo
ok("\x[B822]\c[SPACE]\c[LINE SEPARATOR]" ~~ m/<:Zl>/, q{Match unanchored  (LineSeparator)} );

#?pugs todo
ok("\c[LINE SEPARATOR]" ~~ m/^<:LineSeparator>$/, q{Match <:LineSeparator>} );
ok(!( "\c[LINE SEPARATOR]" ~~ m/^<:!LineSeparator>$/ ), q{Don't match negated } );
ok(!( "\c[LINE SEPARATOR]" ~~ m/^<-:LineSeparator>$/ ), q{Don't match inverted } );
ok(!( "\x[1390]"  ~~ m/^<:LineSeparator>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[1390]"  ~~ m/^<:!LineSeparator>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[1390]"  ~~ m/^<-:LineSeparator>$/, q{Match unrelated inverted } );
ok(!( "\c[CHEROKEE LETTER A]" ~~ m/^<:LineSeparator>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[CHEROKEE LETTER A]" ~~ m/^<:!LineSeparator>$/, q{Match related negated } );
#?pugs todo
ok("\c[CHEROKEE LETTER A]" ~~ m/^<-:LineSeparator>$/, q{Match related inverted } );
#?pugs todo
ok("\x[1390]\c[CHEROKEE LETTER A]\c[LINE SEPARATOR]" ~~ m/<:LineSeparator>/, q{Match unanchored } );

# Zp          ParagraphSeparator


#?pugs todo
ok("\c[PARAGRAPH SEPARATOR]" ~~ m/^<:Zp>$/, q{Match <:Zp> (ParagraphSeparator)} );
ok(!( "\c[PARAGRAPH SEPARATOR]" ~~ m/^<:!Zp>$/ ), q{Don't match negated  (ParagraphSeparator)} );
ok(!( "\c[PARAGRAPH SEPARATOR]" ~~ m/^<-:Zp>$/ ), q{Don't match inverted  (ParagraphSeparator)} );
ok(!( "\x[5FDE]"  ~~ m/^<:Zp>$/ ), q{Don't match unrelated  (ParagraphSeparator)} );
#?pugs todo
ok("\x[5FDE]"  ~~ m/^<:!Zp>$/, q{Match unrelated negated  (ParagraphSeparator)} );
#?pugs todo
ok("\x[5FDE]"  ~~ m/^<-:Zp>$/, q{Match unrelated inverted  (ParagraphSeparator)} );
ok(!( "\c[SPACE]" ~~ m/^<:Zp>$/ ), q{Don't match related  (ParagraphSeparator)} );
#?pugs todo
ok("\c[SPACE]" ~~ m/^<:!Zp>$/, q{Match related negated  (ParagraphSeparator)} );
#?pugs todo
ok("\c[SPACE]" ~~ m/^<-:Zp>$/, q{Match related inverted  (ParagraphSeparator)} );
#?pugs todo
ok("\x[5FDE]\c[SPACE]\c[PARAGRAPH SEPARATOR]" ~~ m/<:Zp>/, q{Match unanchored  (ParagraphSeparator)} );

#?pugs todo
ok("\c[PARAGRAPH SEPARATOR]" ~~ m/^<:ParagraphSeparator>$/, q{Match <:ParagraphSeparator>} );
ok(!( "\c[PARAGRAPH SEPARATOR]" ~~ m/^<:!ParagraphSeparator>$/ ), q{Don't match negated } );
ok(!( "\c[PARAGRAPH SEPARATOR]" ~~ m/^<-:ParagraphSeparator>$/ ), q{Don't match inverted } );
ok(!( "\x[345B]"  ~~ m/^<:ParagraphSeparator>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[345B]"  ~~ m/^<:!ParagraphSeparator>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[345B]"  ~~ m/^<-:ParagraphSeparator>$/, q{Match unrelated inverted } );
ok(!( "\c[EXCLAMATION MARK]" ~~ m/^<:ParagraphSeparator>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<:!ParagraphSeparator>$/, q{Match related negated } );
#?pugs todo
ok("\c[EXCLAMATION MARK]" ~~ m/^<-:ParagraphSeparator>$/, q{Match related inverted } );
#?pugs todo
ok("\x[345B]\c[EXCLAMATION MARK]\c[PARAGRAPH SEPARATOR]" ~~ m/<:ParagraphSeparator>/, q{Match unanchored } );

# C           Other


#?rakudo 3 skip "Uninvestigated nqp-rx regression"
#?pugs todo
ok("\x[FFFE]" ~~ m/^<:C>$/, q{Match  (Other)} );
ok(!( "\x[FFFE]" ~~ m/^<:!C>$/ ), q{Don't match negated  (Other)} );
ok(!( "\x[FFFE]" ~~ m/^<-:C>$/ ), q{Don't match inverted  (Other)} );
ok(!( "\x[6A3F]"  ~~ m/^<:C>$/ ), q{Don't match unrelated  (Other)} );
#?pugs todo
ok("\x[6A3F]"  ~~ m/^<:!C>$/, q{Match unrelated negated  (Other)} );
#?pugs todo
ok("\x[6A3F]"  ~~ m/^<-:C>$/, q{Match unrelated inverted  (Other)} );
#?rakudo skip "Uninvestigated nqp-rx regression"
#?pugs todo
ok("\x[6A3F]\x[FFFE]" ~~ m/<:C>/, q{Match unanchored  (Other)} );

#?pugs todo
#?niecza 3 todo "Tests are wrong by latest Unicode standard"
#?rakudo.jvm 3 todo "nigh"
ok("\x[A679]" ~~ m/^<:Other>$/, q{Match <:Other>} );
ok(!( "\x[A679]" ~~ m/^<:!Other>$/ ), q{Don't match negated } );
ok(!( "\x[A679]" ~~ m/^<-:Other>$/ ), q{Don't match inverted } );
ok(!( "\x[AC00]"  ~~ m/^<:Other>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[AC00]"  ~~ m/^<:!Other>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[AC00]"  ~~ m/^<-:Other>$/, q{Match unrelated inverted } );
#?pugs todo
#?niecza todo "Test is wrong by latest Unicode standard"
#?rakudo.jvm todo "nigh"
ok("\x[AC00]\x[A679]" ~~ m/<:Other>/, q{Match unanchored } );

# Cc          Control


#?pugs todo
ok("\c[NULL]" ~~ m/^<:Cc>$/, q{Match <:Cc> (Control)} );
ok(!( "\c[NULL]" ~~ m/^<:!Cc>$/ ), q{Don't match negated  (Control)} );
ok(!( "\c[NULL]" ~~ m/^<-:Cc>$/ ), q{Don't match inverted  (Control)} );
ok(!( "\x[0A7A]"  ~~ m/^<:Cc>$/ ), q{Don't match unrelated  (Control)} );
#?pugs todo
ok("\x[0A7A]"  ~~ m/^<:!Cc>$/, q{Match unrelated negated  (Control)} );
#?pugs todo
ok("\x[0A7A]"  ~~ m/^<-:Cc>$/, q{Match unrelated inverted  (Control)} );
ok(!( "\x[0A7A]" ~~ m/^<:Cc>$/ ), q{Don't match related  (Control)} );
#?pugs todo
ok("\x[0A7A]" ~~ m/^<:!Cc>$/, q{Match related negated  (Control)} );
#?pugs todo
ok("\x[0A7A]" ~~ m/^<-:Cc>$/, q{Match related inverted  (Control)} );
#?pugs todo
ok("\x[0A7A]\x[0A7A]\c[NULL]" ~~ m/<:Cc>/, q{Match unanchored  (Control)} );

#?pugs todo
ok("\c[NULL]" ~~ m/^<:Control>$/, q{Match <:Control>} );
ok(!( "\c[NULL]" ~~ m/^<:!Control>$/ ), q{Don't match negated } );
ok(!( "\c[NULL]" ~~ m/^<-:Control>$/ ), q{Don't match inverted } );
ok(!( "\x[4886]"  ~~ m/^<:Control>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4886]"  ~~ m/^<:!Control>$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4886]"  ~~ m/^<-:Control>$/, q{Match unrelated inverted } );
ok(!( "\x[4DB6]" ~~ m/^<:Control>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[4DB6]" ~~ m/^<:!Control>$/, q{Match related negated } );
#?pugs todo
ok("\x[4DB6]" ~~ m/^<-:Control>$/, q{Match related inverted } );
#?pugs todo
ok("\x[4886]\x[4DB6]\c[NULL]" ~~ m/<:Control>/, q{Match unanchored } );

# Cf          Format


#?pugs todo
ok("\c[SOFT HYPHEN]" ~~ m/^<:Cf>$/, q{Match <:Cf> (Format)} );
ok(!( "\c[SOFT HYPHEN]" ~~ m/^<:!Cf>$/ ), q{Don't match negated  (Format)} );
ok(!( "\c[SOFT HYPHEN]" ~~ m/^<-:Cf>$/ ), q{Don't match inverted  (Format)} );
ok(!( "\x[77B8]"  ~~ m/^<:Cf>$/ ), q{Don't match unrelated  (Format)} );
#?pugs todo
ok("\x[77B8]"  ~~ m/^<:!Cf>$/, q{Match unrelated negated  (Format)} );
#?pugs todo
ok("\x[77B8]"  ~~ m/^<-:Cf>$/, q{Match unrelated inverted  (Format)} );
#?rakudo 3 skip '\x[FFFE]'
ok(!( "\x[FFFE]" ~~ m/^<:Cf>$/ ), q{Don't match related  (Format)} );
#?pugs todo
ok("\x[FFFE]" ~~ m/^<:!Cf>$/, q{Match related negated  (Format)} );
#?pugs todo
ok("\x[FFFE]" ~~ m/^<-:Cf>$/, q{Match related inverted  (Format)} );
#?rakudo skip "Malformed UTF-8 string"
#?pugs todo
ok("\x[77B8]\x[FFFE]\c[SOFT HYPHEN]" ~~ m/<:Cf>/, q{Match unanchored  (Format)} );

#?pugs todo
#?niecza 3 todo "Tests are wrong by latest Unicode standard"
ok("\c[KHMER VOWEL INHERENT AQ]" ~~ m/^<:Format>$/, q{Match <:Format>} );
ok(!( "\c[KHMER VOWEL INHERENT AQ]" ~~ m/^<:!Format>$/ ), q{Don't match negated } );
ok(!( "\c[KHMER VOWEL INHERENT AQ]" ~~ m/^<-:Format>$/ ), q{Don't match inverted } );
ok(!( "\c[DEVANAGARI VOWEL SIGN AU]"  ~~ m/^<:Format>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[DEVANAGARI VOWEL SIGN AU]"  ~~ m/^<:!Format>$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[DEVANAGARI VOWEL SIGN AU]"  ~~ m/^<-:Format>$/, q{Match unrelated inverted } );
#?pugs todo
#?niecza todo "Test is wrong by latest Unicode standard"
ok("\c[DEVANAGARI VOWEL SIGN AU]\c[KHMER VOWEL INHERENT AQ]" ~~ m/<:Format>/, q{Match unanchored } );


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/properties-script.t0000664000175000017500000010271312224265625021205 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/properties_slow_to_compile.t.

XXX needs more clarification on the case of the rules, 
ie letter vs. Letter vs isLetter

=end pod

plan 361;

# BidiL       # Left-to-Right

#?rakudo 35 skip 'Unicode properties with arguments'
#?pugs todo
ok("\c[YI SYLLABLE IT]" ~~ m/^<:bc>$/, q{Match (Left-to-Right)} );
ok(!( "\c[YI SYLLABLE IT]" ~~ m/^>.$/ ), q{Don't match negated (Left-to-Right)} );
ok(!( "\c[YI SYLLABLE IT]" ~~ m/^<-:bc>$/ ), q{Don't match inverted (Left-to-Right)} );
ok(!( "\x[05D0]"  ~~ m/^<:bc>$/ ), q{Don't match unrelated (Left-to-Right)} );
#?pugs todo
ok("\x[05D0]"  ~~ m/^>.$/, q{Match unrelated negated (Left-to-Right)} );
#?pugs todo
ok("\x[05D0]"  ~~ m/^<-:bc>$/, q{Match unrelated inverted (Left-to-Right)} );
#?pugs todo
ok("\x[05D0]\c[YI SYLLABLE IT]" ~~ m/<:bc>/, q{Match unanchored (Left-to-Right)} );

# bc      # European Number


#?pugs todo
ok("\c[DIGIT ZERO]" ~~ m/^<:bc>$/, q{Match (European Number)} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^>.$/ ), q{Don't match negated (European Number)} );
ok(!( "\c[DIGIT ZERO]" ~~ m/^<-:bc>$/ ), q{Don't match inverted (European Number)} );
ok(!( "\x[AFFB]"  ~~ m/^<:bc>$/ ), q{Don't match unrelated (European Number)} );
#?pugs todo
ok("\x[AFFB]"  ~~ m/^>.$/, q{Match unrelated negated (European Number)} );
#?pugs todo
ok("\x[AFFB]"  ~~ m/^<-:bc>$/, q{Match unrelated inverted (European Number)} );
#?pugs todo
ok("\x[AFFB]\c[DIGIT ZERO]" ~~ m/<:bc>/, q{Match unanchored (European Number)} );

# bc      # European Number Separator


#?pugs todo
ok("\c[PLUS SIGN]" ~~ m/^<:bc>$/, q{Match (European Number Separator)} );
ok(!( "\c[PLUS SIGN]" ~~ m/^>.$/ ), q{Don't match negated (European Number Separator)} );
ok(!( "\c[PLUS SIGN]" ~~ m/^<-:bc>$/ ), q{Don't match inverted (European Number Separator)} );
ok(!( "\x[7B89]"  ~~ m/^<:bc>$/ ), q{Don't match unrelated (European Number Separator)} );
#?pugs todo
ok("\x[7B89]"  ~~ m/^>.$/, q{Match unrelated negated (European Number Separator)} );
#?pugs todo
ok("\x[7B89]"  ~~ m/^<-:bc>$/, q{Match unrelated inverted (European Number Separator)} );
#?pugs todo
ok("\x[7B89]\c[PLUS SIGN]" ~~ m/<:bc>/, q{Match unanchored (European Number Separator)} );

# bc      # European Number Terminator


#?pugs todo
ok("\c[NUMBER SIGN]" ~~ m/^<:bc>$/, q{Match (European Number Terminator)} );
ok(!( "\c[NUMBER SIGN]" ~~ m/^>.$/ ), q{Don't match negated (European Number Terminator)} );
ok(!( "\c[NUMBER SIGN]" ~~ m/^<-:bc>$/ ), q{Don't match inverted (European Number Terminator)} );
ok(!( "\x[6780]"  ~~ m/^<:bc>$/ ), q{Don't match unrelated (European Number Terminator)} );
#?pugs todo
ok("\x[6780]"  ~~ m/^>.$/, q{Match unrelated negated (European Number Terminator)} );
#?pugs todo
ok("\x[6780]"  ~~ m/^<-:bc>$/, q{Match unrelated inverted (European Number Terminator)} );
#?pugs todo
ok("\x[6780]\c[NUMBER SIGN]" ~~ m/<:bc>/, q{Match unanchored (European Number Terminator)} );

# bc      # Whitespace


#?pugs todo
ok("\c[FORM FEED (FF)]" ~~ m/^<:bc>$/, q{Match (Whitespace)} );
ok(!( "\c[FORM FEED (FF)]" ~~ m/^>.$/ ), q{Don't match negated (Whitespace)} );
ok(!( "\c[FORM FEED (FF)]" ~~ m/^<-:bc>$/ ), q{Don't match inverted (Whitespace)} );
ok(!( "\x[6CF9]"  ~~ m/^<:bc>$/ ), q{Don't match unrelated (Whitespace)} );
#?pugs todo
ok("\x[6CF9]"  ~~ m/^>.$/, q{Match unrelated negated (Whitespace)} );
#?pugs todo
ok("\x[6CF9]"  ~~ m/^<-:bc>$/, q{Match unrelated inverted (Whitespace)} );
#?pugs todo
ok("\x[6CF9]\c[FORM FEED (FF)]" ~~ m/<:bc>/, q{Match unanchored (Whitespace)} );


# Arabic


#?pugs todo
ok("\c[ARABIC LETTER HAMZA]" ~~ m/^<:Arabic>$/, q{Match <:Arabic>} );
ok(!( "\c[ARABIC LETTER HAMZA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[ARABIC LETTER HAMZA]" ~~ m/^<-:Arabic>$/ ), q{Don't match inverted } );
ok(!( "\x[A649]"  ~~ m/^<:Arabic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[A649]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[A649]"  ~~ m/^<-:Arabic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[A649]\c[ARABIC LETTER HAMZA]" ~~ m/<:Arabic>/, q{Match unanchored } );

# Armenian


#?pugs todo
ok("\c[ARMENIAN CAPITAL LETTER AYB]" ~~ m/^<:Armenian>$/, q{Match <:Armenian>} );
ok(!( "\c[ARMENIAN CAPITAL LETTER AYB]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[ARMENIAN CAPITAL LETTER AYB]" ~~ m/^<-:Armenian>$/ ), q{Don't match inverted } );
ok(!( "\x[CBFF]"  ~~ m/^<:Armenian>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[CBFF]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[CBFF]"  ~~ m/^<-:Armenian>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[CBFF]\c[ARMENIAN CAPITAL LETTER AYB]" ~~ m/<:Armenian>/, q{Match unanchored } );

# Bengali


#?pugs todo
ok("\c[BENGALI SIGN CANDRABINDU]" ~~ m/^<:Bengali>$/, q{Match <:Bengali>} );
ok(!( "\c[BENGALI SIGN CANDRABINDU]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[BENGALI SIGN CANDRABINDU]" ~~ m/^<-:Bengali>$/ ), q{Don't match inverted } );
ok(!( "\x[D1E8]"  ~~ m/^<:Bengali>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D1E8]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D1E8]"  ~~ m/^<-:Bengali>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D1E8]\c[BENGALI SIGN CANDRABINDU]" ~~ m/<:Bengali>/, q{Match unanchored } );

# Bopomofo


#?pugs todo
ok("\c[BOPOMOFO LETTER B]" ~~ m/^<:Bopomofo>$/, q{Match <:Bopomofo>} );
ok(!( "\c[BOPOMOFO LETTER B]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[BOPOMOFO LETTER B]" ~~ m/^<-:Bopomofo>$/ ), q{Don't match inverted } );
ok(!( "\x[B093]"  ~~ m/^<:Bopomofo>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B093]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B093]"  ~~ m/^<-:Bopomofo>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[B093]\c[BOPOMOFO LETTER B]" ~~ m/<:Bopomofo>/, q{Match unanchored } );

# Buhid


#?pugs todo
ok("\c[BUHID LETTER A]" ~~ m/^<:Buhid>$/, q{Match <:Buhid>} );
ok(!( "\c[BUHID LETTER A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[BUHID LETTER A]" ~~ m/^<-:Buhid>$/ ), q{Don't match inverted } );
ok(!( "\x[C682]"  ~~ m/^<:Buhid>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C682]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C682]"  ~~ m/^<-:Buhid>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[C682]\c[BUHID LETTER A]" ~~ m/<:Buhid>/, q{Match unanchored } );

# Canadian_Aboriginal


#?pugs todo
ok("\c[CANADIAN SYLLABICS E]" ~~ m/^<:Canadian_Aboriginal>$/, q{Match <:Canadian_Aboriginal>} );
ok(!( "\c[CANADIAN SYLLABICS E]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[CANADIAN SYLLABICS E]" ~~ m/^<-:Canadian_Aboriginal>$/ ), q{Don't match inverted } );
ok(!( "\x[888B]"  ~~ m/^<:Canadian_Aboriginal>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[888B]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[888B]"  ~~ m/^<-:Canadian_Aboriginal>$/, q{Match unrelated inverted } );
ok(!( "\x[9FA6]" ~~ m/^<:Canadian_Aboriginal>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[9FA6]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\x[9FA6]" ~~ m/^<-:Canadian_Aboriginal>$/, q{Match related inverted } );
#?pugs todo
ok("\x[888B]\x[9FA6]\c[CANADIAN SYLLABICS E]" ~~ m/<:Canadian_Aboriginal>/, q{Match unanchored } );

# Cherokee


#?pugs todo
ok("\c[CHEROKEE LETTER A]" ~~ m/^<:Cherokee>$/, q{Match <:Cherokee>} );
ok(!( "\c[CHEROKEE LETTER A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[CHEROKEE LETTER A]" ~~ m/^<-:Cherokee>$/ ), q{Don't match inverted } );
ok(!( "\x[8260]"  ~~ m/^<:Cherokee>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8260]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8260]"  ~~ m/^<-:Cherokee>$/, q{Match unrelated inverted } );
ok(!( "\x[9FA6]" ~~ m/^<:Cherokee>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[9FA6]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\x[9FA6]" ~~ m/^<-:Cherokee>$/, q{Match related inverted } );
#?pugs todo
ok("\x[8260]\x[9FA6]\c[CHEROKEE LETTER A]" ~~ m/<:Cherokee>/, q{Match unanchored } );

# Cyrillic


#?pugs todo
ok("\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/^<:Cyrillic>$/, q{Match <:Cyrillic>} );
ok(!( "\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/^<-:Cyrillic>$/ ), q{Don't match inverted } );
ok(!( "\x[B7DF]"  ~~ m/^<:Cyrillic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[B7DF]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[B7DF]"  ~~ m/^<-:Cyrillic>$/, q{Match unrelated inverted } );
ok(!( "\x[D7A4]" ~~ m/^<:Cyrillic>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[D7A4]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\x[D7A4]" ~~ m/^<-:Cyrillic>$/, q{Match related inverted } );
#?pugs todo
ok("\x[B7DF]\x[D7A4]\c[CYRILLIC CAPITAL LETTER IE WITH GRAVE]" ~~ m/<:Cyrillic>/, q{Match unanchored } );

# Deseret


ok(!( "\x[A8A0]"  ~~ m/^<:Deseret>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[A8A0]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[A8A0]"  ~~ m/^<-:Deseret>$/, q{Match unrelated inverted } );

# Devanagari


#?pugs todo
ok("\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/^<:Devanagari>$/, q{Match <:Devanagari>} );
ok(!( "\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/^<-:Devanagari>$/ ), q{Don't match inverted } );
ok(!( "\x[D291]"  ~~ m/^<:Devanagari>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D291]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D291]"  ~~ m/^<-:Devanagari>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D291]\c[DEVANAGARI SIGN CANDRABINDU]" ~~ m/<:Devanagari>/, q{Match unanchored } );

# Ethiopic


#?pugs todo
ok("\c[ETHIOPIC SYLLABLE HA]" ~~ m/^<:Ethiopic>$/, q{Match <:Ethiopic>} );
ok(!( "\c[ETHIOPIC SYLLABLE HA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[ETHIOPIC SYLLABLE HA]" ~~ m/^<-:Ethiopic>$/ ), q{Don't match inverted } );
ok(!( "\x[A9FA]"  ~~ m/^<:Ethiopic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[A9FA]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[A9FA]"  ~~ m/^<-:Ethiopic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[A9FA]\c[ETHIOPIC SYLLABLE HA]" ~~ m/<:Ethiopic>/, q{Match unanchored } );

# Georgian


#?pugs todo
ok("\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/^<:Georgian>$/, q{Match <:Georgian>} );
ok(!( "\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/^<-:Georgian>$/ ), q{Don't match inverted } );
ok(!( "\x[BBC9]"  ~~ m/^<:Georgian>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BBC9]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BBC9]"  ~~ m/^<-:Georgian>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BBC9]\c[GEORGIAN CAPITAL LETTER AN]" ~~ m/<:Georgian>/, q{Match unanchored } );

# Gothic


ok(!( "\x[5888]"  ~~ m/^<:Gothic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5888]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5888]"  ~~ m/^<-:Gothic>$/, q{Match unrelated inverted } );

# Greek


#?pugs todo
ok("\c[GREEK LETTER SMALL CAPITAL GAMMA]" ~~ m/^<:Greek>$/, q{Match <:Greek>} );
ok(!( "\c[GREEK LETTER SMALL CAPITAL GAMMA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[GREEK LETTER SMALL CAPITAL GAMMA]" ~~ m/^<-:Greek>$/ ), q{Don't match inverted } );
ok(!( "\c[ETHIOPIC SYLLABLE KEE]"  ~~ m/^<:Greek>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[ETHIOPIC SYLLABLE KEE]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[ETHIOPIC SYLLABLE KEE]"  ~~ m/^<-:Greek>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[ETHIOPIC SYLLABLE KEE]\c[GREEK LETTER SMALL CAPITAL GAMMA]" ~~ m/<:Greek>/, q{Match unanchored } );

# Gujarati


#?pugs todo
ok("\c[GUJARATI SIGN CANDRABINDU]" ~~ m/^<:Gujarati>$/, q{Match <:Gujarati>} );
ok(!( "\c[GUJARATI SIGN CANDRABINDU]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[GUJARATI SIGN CANDRABINDU]" ~~ m/^<-:Gujarati>$/ ), q{Don't match inverted } );
ok(!( "\x[D108]"  ~~ m/^<:Gujarati>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[D108]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[D108]"  ~~ m/^<-:Gujarati>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[D108]\c[GUJARATI SIGN CANDRABINDU]" ~~ m/<:Gujarati>/, q{Match unanchored } );

# Gurmukhi


#?pugs todo
ok("\c[GURMUKHI SIGN BINDI]" ~~ m/^<:Gurmukhi>$/, q{Match <:Gurmukhi>} );
ok(!( "\c[GURMUKHI SIGN BINDI]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[GURMUKHI SIGN BINDI]" ~~ m/^<-:Gurmukhi>$/ ), q{Don't match inverted } );
ok(!( "\x[5E05]"  ~~ m/^<:Gurmukhi>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5E05]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5E05]"  ~~ m/^<-:Gurmukhi>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[5E05]\c[GURMUKHI SIGN BINDI]" ~~ m/<:Gurmukhi>/, q{Match unanchored } );

# Han


#?pugs todo
ok("\c[CJK RADICAL REPEAT]" ~~ m/^<:Han>$/, q{Match <:Han>} );
ok(!( "\c[CJK RADICAL REPEAT]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[CJK RADICAL REPEAT]" ~~ m/^<-:Han>$/ ), q{Don't match inverted } );
ok(!( "\c[CANADIAN SYLLABICS KAA]"  ~~ m/^<:Han>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS KAA]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS KAA]"  ~~ m/^<-:Han>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS KAA]\c[CJK RADICAL REPEAT]" ~~ m/<:Han>/, q{Match unanchored } );

# Hangul


#?pugs todo
ok("\x[AC00]" ~~ m/^<:Hangul>$/, q{Match <:Hangul>} );
ok(!( "\x[AC00]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\x[AC00]" ~~ m/^<-:Hangul>$/ ), q{Don't match inverted } );
ok(!( "\x[9583]"  ~~ m/^<:Hangul>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9583]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9583]"  ~~ m/^<-:Hangul>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9583]\x[AC00]" ~~ m/<:Hangul>/, q{Match unanchored } );

# Hanunoo


#?pugs todo
ok("\c[HANUNOO LETTER A]" ~~ m/^<:Hanunoo>$/, q{Match <:Hanunoo>} );
ok(!( "\c[HANUNOO LETTER A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[HANUNOO LETTER A]" ~~ m/^<-:Hanunoo>$/ ), q{Don't match inverted } );
ok(!( "\x[7625]"  ~~ m/^<:Hanunoo>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[7625]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[7625]"  ~~ m/^<-:Hanunoo>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[7625]\c[HANUNOO LETTER A]" ~~ m/<:Hanunoo>/, q{Match unanchored } );

# Hebrew


#?pugs todo
ok("\c[HEBREW LETTER ALEF]" ~~ m/^<:Hebrew>$/, q{Match <:Hebrew>} );
ok(!( "\c[HEBREW LETTER ALEF]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[HEBREW LETTER ALEF]" ~~ m/^<-:Hebrew>$/ ), q{Don't match inverted } );
ok(!( "\c[YI SYLLABLE SSIT]"  ~~ m/^<:Hebrew>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[YI SYLLABLE SSIT]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[YI SYLLABLE SSIT]"  ~~ m/^<-:Hebrew>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[YI SYLLABLE SSIT]\c[HEBREW LETTER ALEF]" ~~ m/<:Hebrew>/, q{Match unanchored } );

# Hiragana


#?pugs todo
ok("\c[HIRAGANA LETTER SMALL A]" ~~ m/^<:Hiragana>$/, q{Match <:Hiragana>} );
ok(!( "\c[HIRAGANA LETTER SMALL A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[HIRAGANA LETTER SMALL A]" ~~ m/^<-:Hiragana>$/ ), q{Don't match inverted } );
ok(!( "\c[CANADIAN SYLLABICS Y]"  ~~ m/^<:Hiragana>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS Y]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS Y]"  ~~ m/^<-:Hiragana>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[CANADIAN SYLLABICS Y]\c[HIRAGANA LETTER SMALL A]" ~~ m/<:Hiragana>/, q{Match unanchored } );

# Inherited


#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Inherited>$/, q{Match <:Inherited>} );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Inherited>$/ ), q{Don't match inverted } );
ok(!( "\x[75FA]"  ~~ m/^<:Inherited>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[75FA]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[75FA]"  ~~ m/^<-:Inherited>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[75FA]\c[COMBINING GRAVE ACCENT]" ~~ m/<:Inherited>/, q{Match unanchored } );

# Kannada


#?pugs todo
ok("\c[KANNADA SIGN ANUSVARA]" ~~ m/^<:Kannada>$/, q{Match <:Kannada>} );
ok(!( "\c[KANNADA SIGN ANUSVARA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[KANNADA SIGN ANUSVARA]" ~~ m/^<-:Kannada>$/ ), q{Don't match inverted } );
ok(!( "\x[C1DF]"  ~~ m/^<:Kannada>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C1DF]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C1DF]"  ~~ m/^<-:Kannada>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[C1DF]\c[KANNADA SIGN ANUSVARA]" ~~ m/<:Kannada>/, q{Match unanchored } );

# Katakana


#?pugs todo
ok("\c[KATAKANA LETTER SMALL A]" ~~ m/^<:Katakana>$/, q{Match <:Katakana>} );
ok(!( "\c[KATAKANA LETTER SMALL A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[KATAKANA LETTER SMALL A]" ~~ m/^<-:Katakana>$/ ), q{Don't match inverted } );
ok(!( "\x[177A]"  ~~ m/^<:Katakana>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[177A]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[177A]"  ~~ m/^<-:Katakana>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[177A]\c[KATAKANA LETTER SMALL A]" ~~ m/<:Katakana>/, q{Match unanchored } );

# Khmer


#?pugs todo
ok("\c[KHMER LETTER KA]" ~~ m/^<:Khmer>$/, q{Match <:Khmer>} );
ok(!( "\c[KHMER LETTER KA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[KHMER LETTER KA]" ~~ m/^<-:Khmer>$/ ), q{Don't match inverted } );
ok(!( "\c[GEORGIAN LETTER QAR]"  ~~ m/^<:Khmer>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[GEORGIAN LETTER QAR]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[GEORGIAN LETTER QAR]"  ~~ m/^<-:Khmer>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[GEORGIAN LETTER QAR]\c[KHMER LETTER KA]" ~~ m/<:Khmer>/, q{Match unanchored } );

# Lao


#?pugs todo
ok("\c[LAO LETTER KO]" ~~ m/^<:Lao>$/, q{Match <:Lao>} );
ok(!( "\c[LAO LETTER KO]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[LAO LETTER KO]" ~~ m/^<-:Lao>$/ ), q{Don't match inverted } );
ok(!( "\x[3DA9]"  ~~ m/^<:Lao>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3DA9]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3DA9]"  ~~ m/^<-:Lao>$/, q{Match unrelated inverted } );
ok(!( "\x[3DA9]" ~~ m/^<:Lao>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[3DA9]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\x[3DA9]" ~~ m/^<-:Lao>$/, q{Match related inverted } );
#?pugs todo
ok("\x[3DA9]\x[3DA9]\c[LAO LETTER KO]" ~~ m/<:Lao>/, q{Match unanchored } );

# Latin


#?pugs todo
ok("\c[LATIN CAPITAL LETTER A]" ~~ m/^<:Latin>$/, q{Match <:Latin>} );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[LATIN CAPITAL LETTER A]" ~~ m/^<-:Latin>$/ ), q{Don't match inverted } );
ok(!( "\x[C549]"  ~~ m/^<:Latin>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[C549]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[C549]"  ~~ m/^<-:Latin>$/, q{Match unrelated inverted } );
ok(!( "\x[C549]" ~~ m/^<:Latin>$/ ), q{Don't match related } );
#?pugs todo
ok("\x[C549]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\x[C549]" ~~ m/^<-:Latin>$/, q{Match related inverted } );
#?pugs todo
ok("\x[C549]\x[C549]\c[LATIN CAPITAL LETTER A]" ~~ m/<:Latin>/, q{Match unanchored } );

# Malayalam


#?pugs todo
ok("\c[MALAYALAM SIGN ANUSVARA]" ~~ m/^<:Malayalam>$/, q{Match <:Malayalam>} );
ok(!( "\c[MALAYALAM SIGN ANUSVARA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[MALAYALAM SIGN ANUSVARA]" ~~ m/^<-:Malayalam>$/ ), q{Don't match inverted } );
ok(!( "\x[625C]"  ~~ m/^<:Malayalam>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[625C]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[625C]"  ~~ m/^<-:Malayalam>$/, q{Match unrelated inverted } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Malayalam>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Malayalam>$/, q{Match related inverted } );
#?pugs todo
ok("\x[625C]\c[COMBINING GRAVE ACCENT]\c[MALAYALAM SIGN ANUSVARA]" ~~ m/<:Malayalam>/, q{Match unanchored } );

# Mongolian


#?pugs todo
ok("\c[MONGOLIAN DIGIT ZERO]" ~~ m/^<:Mongolian>$/, q{Match <:Mongolian>} );
ok(!( "\c[MONGOLIAN DIGIT ZERO]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[MONGOLIAN DIGIT ZERO]" ~~ m/^<-:Mongolian>$/ ), q{Don't match inverted } );
ok(!( "\x[5F93]"  ~~ m/^<:Mongolian>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5F93]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5F93]"  ~~ m/^<-:Mongolian>$/, q{Match unrelated inverted } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Mongolian>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Mongolian>$/, q{Match related inverted } );
#?pugs todo
ok("\x[5F93]\c[COMBINING GRAVE ACCENT]\c[MONGOLIAN DIGIT ZERO]" ~~ m/<:Mongolian>/, q{Match unanchored } );

# Myanmar


#?pugs todo
ok("\c[MYANMAR LETTER KA]" ~~ m/^<:Myanmar>$/, q{Match <:Myanmar>} );
ok(!( "\c[MYANMAR LETTER KA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[MYANMAR LETTER KA]" ~~ m/^<-:Myanmar>$/ ), q{Don't match inverted } );
ok(!( "\x[649A]"  ~~ m/^<:Myanmar>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[649A]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[649A]"  ~~ m/^<-:Myanmar>$/, q{Match unrelated inverted } );
ok(!( "\c[COMBINING GRAVE ACCENT]" ~~ m/^<:Myanmar>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\c[COMBINING GRAVE ACCENT]" ~~ m/^<-:Myanmar>$/, q{Match related inverted } );
#?pugs todo
ok("\x[649A]\c[COMBINING GRAVE ACCENT]\c[MYANMAR LETTER KA]" ~~ m/<:Myanmar>/, q{Match unanchored } );

# Ogham


#?pugs todo
ok("\c[OGHAM LETTER BEITH]" ~~ m/^<:Ogham>$/, q{Match <:Ogham>} );
ok(!( "\c[OGHAM LETTER BEITH]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[OGHAM LETTER BEITH]" ~~ m/^<-:Ogham>$/ ), q{Don't match inverted } );
ok(!( "\c[KATAKANA LETTER KA]"  ~~ m/^<:Ogham>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[KATAKANA LETTER KA]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[KATAKANA LETTER KA]"  ~~ m/^<-:Ogham>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[KATAKANA LETTER KA]\c[OGHAM LETTER BEITH]" ~~ m/<:Ogham>/, q{Match unanchored } );

# Old_Italic


ok(!( "\x[8BB7]"  ~~ m/^<:Old_Italic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8BB7]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8BB7]"  ~~ m/^<-:Old_Italic>$/, q{Match unrelated inverted } );

# Oriya


#?pugs todo
ok("\c[ORIYA SIGN CANDRABINDU]" ~~ m/^<:Oriya>$/, q{Match <:Oriya>} );
ok(!( "\c[ORIYA SIGN CANDRABINDU]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[ORIYA SIGN CANDRABINDU]" ~~ m/^<-:Oriya>$/ ), q{Don't match inverted } );
ok(!( "\x[4292]"  ~~ m/^<:Oriya>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[4292]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[4292]"  ~~ m/^<-:Oriya>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[4292]\c[ORIYA SIGN CANDRABINDU]" ~~ m/<:Oriya>/, q{Match unanchored } );

# Runic


#?pugs todo
ok("\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/^<:Runic>$/, q{Match <:Runic>} );
ok(!( "\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/^<-:Runic>$/ ), q{Don't match inverted } );
ok(!( "\x[9857]"  ~~ m/^<:Runic>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[9857]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[9857]"  ~~ m/^<-:Runic>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[9857]\c[RUNIC LETTER FEHU FEOH FE F]" ~~ m/<:Runic>/, q{Match unanchored } );

# Sinhala


#?pugs todo
ok("\c[SINHALA SIGN ANUSVARAYA]" ~~ m/^<:Sinhala>$/, q{Match <:Sinhala>} );
ok(!( "\c[SINHALA SIGN ANUSVARAYA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[SINHALA SIGN ANUSVARAYA]" ~~ m/^<-:Sinhala>$/ ), q{Don't match inverted } );
ok(!( "\x[5DF5]"  ~~ m/^<:Sinhala>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5DF5]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5DF5]"  ~~ m/^<-:Sinhala>$/, q{Match unrelated inverted } );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:Sinhala>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<-:Sinhala>$/, q{Match related inverted } );
#?pugs todo
ok("\x[5DF5]\c[YI RADICAL QOT]\c[SINHALA SIGN ANUSVARAYA]" ~~ m/<:Sinhala>/, q{Match unanchored } );

# Syriac


#?pugs todo
ok("\c[SYRIAC LETTER ALAPH]" ~~ m/^<:Syriac>$/, q{Match <:Syriac>} );
ok(!( "\c[SYRIAC LETTER ALAPH]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[SYRIAC LETTER ALAPH]" ~~ m/^<-:Syriac>$/ ), q{Don't match inverted } );
ok(!( "\x[57F0]"  ~~ m/^<:Syriac>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[57F0]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[57F0]"  ~~ m/^<-:Syriac>$/, q{Match unrelated inverted } );
ok(!( "\c[YI RADICAL QOT]" ~~ m/^<:Syriac>$/ ), q{Don't match related } );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^.$/, q{Match related negated } );
#?pugs todo
ok("\c[YI RADICAL QOT]" ~~ m/^<-:Syriac>$/, q{Match related inverted } );
#?pugs todo
ok("\x[57F0]\c[YI RADICAL QOT]\c[SYRIAC LETTER ALAPH]" ~~ m/<:Syriac>/, q{Match unanchored } );

# Tagalog


#?pugs todo
ok("\c[TAGALOG LETTER A]" ~~ m/^<:Tagalog>$/, q{Match <:Tagalog>} );
ok(!( "\c[TAGALOG LETTER A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[TAGALOG LETTER A]" ~~ m/^<-:Tagalog>$/ ), q{Don't match inverted } );
ok(!( "\x[3DE8]"  ~~ m/^<:Tagalog>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[3DE8]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[3DE8]"  ~~ m/^<-:Tagalog>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[3DE8]\c[TAGALOG LETTER A]" ~~ m/<:Tagalog>/, q{Match unanchored } );

# Tagbanwa


#?pugs todo
ok("\c[TAGBANWA LETTER A]" ~~ m/^<:Tagbanwa>$/, q{Match <:Tagbanwa>} );
ok(!( "\c[TAGBANWA LETTER A]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[TAGBANWA LETTER A]" ~~ m/^<-:Tagbanwa>$/ ), q{Don't match inverted } );
ok(!( "\c[CHEROKEE LETTER TLV]"  ~~ m/^<:Tagbanwa>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\c[CHEROKEE LETTER TLV]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\c[CHEROKEE LETTER TLV]"  ~~ m/^<-:Tagbanwa>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\c[CHEROKEE LETTER TLV]\c[TAGBANWA LETTER A]" ~~ m/<:Tagbanwa>/, q{Match unanchored } );

# Tamil


#?pugs todo
ok("\c[TAMIL SIGN ANUSVARA]" ~~ m/^<:Tamil>$/, q{Match <:Tamil>} );
ok(!( "\c[TAMIL SIGN ANUSVARA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[TAMIL SIGN ANUSVARA]" ~~ m/^<-:Tamil>$/ ), q{Don't match inverted } );
ok(!( "\x[8DF2]"  ~~ m/^<:Tamil>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8DF2]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8DF2]"  ~~ m/^<-:Tamil>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[8DF2]\c[TAMIL SIGN ANUSVARA]" ~~ m/<:Tamil>/, q{Match unanchored } );

# Telugu


#?pugs todo
ok("\c[TELUGU SIGN CANDRABINDU]" ~~ m/^<:Telugu>$/, q{Match <:Telugu>} );
ok(!( "\c[TELUGU SIGN CANDRABINDU]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[TELUGU SIGN CANDRABINDU]" ~~ m/^<-:Telugu>$/ ), q{Don't match inverted } );
ok(!( "\x[8088]"  ~~ m/^<:Telugu>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8088]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8088]"  ~~ m/^<-:Telugu>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[8088]\c[TELUGU SIGN CANDRABINDU]" ~~ m/<:Telugu>/, q{Match unanchored } );

# Thaana


#?pugs todo
ok("\c[THAANA LETTER HAA]" ~~ m/^<:Thaana>$/, q{Match <:Thaana>} );
ok(!( "\c[THAANA LETTER HAA]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[THAANA LETTER HAA]" ~~ m/^<-:Thaana>$/ ), q{Don't match inverted } );
ok(!( "\x[5240]"  ~~ m/^<:Thaana>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[5240]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[5240]"  ~~ m/^<-:Thaana>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[5240]\c[THAANA LETTER HAA]" ~~ m/<:Thaana>/, q{Match unanchored } );

# Thai


#?pugs todo
ok("\c[THAI CHARACTER KO KAI]" ~~ m/^<:Thai>$/, q{Match <:Thai>} );
ok(!( "\c[THAI CHARACTER KO KAI]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[THAI CHARACTER KO KAI]" ~~ m/^<-:Thai>$/ ), q{Don't match inverted } );
ok(!( "\x[CAD3]"  ~~ m/^<:Thai>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[CAD3]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[CAD3]"  ~~ m/^<-:Thai>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[CAD3]\c[THAI CHARACTER KO KAI]" ~~ m/<:Thai>/, q{Match unanchored } );

# Tibetan


#?pugs todo
ok("\c[TIBETAN SYLLABLE OM]" ~~ m/^<:Tibetan>$/, q{Match <:Tibetan>} );
ok(!( "\c[TIBETAN SYLLABLE OM]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[TIBETAN SYLLABLE OM]" ~~ m/^<-:Tibetan>$/ ), q{Don't match inverted } );
ok(!( "\x[8557]"  ~~ m/^<:Tibetan>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[8557]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[8557]"  ~~ m/^<-:Tibetan>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[8557]\c[TIBETAN SYLLABLE OM]" ~~ m/<:Tibetan>/, q{Match unanchored } );

# Yi


#?pugs todo
ok("\c[YI SYLLABLE IT]" ~~ m/^<:Yi>$/, q{Match <:Yi>} );
ok(!( "\c[YI SYLLABLE IT]" ~~ m/^.$/ ), q{Don't match negated } );
ok(!( "\c[YI SYLLABLE IT]" ~~ m/^<-:Yi>$/ ), q{Don't match inverted } );
ok(!( "\x[BCD0]"  ~~ m/^<:Yi>$/ ), q{Don't match unrelated } );
#?pugs todo
ok("\x[BCD0]"  ~~ m/^.$/, q{Match unrelated negated } );
#?pugs todo
ok("\x[BCD0]"  ~~ m/^<-:Yi>$/, q{Match unrelated inverted } );
#?pugs todo
ok("\x[BCD0]\c[YI SYLLABLE IT]" ~~ m/<:Yi>/, q{Match unanchored } );


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/recursive.t0000664000175000017500000000166012224265625017515 0ustar  moritzmoritzuse v6;
use Test;

=begin kwid

  regex r {  | x  }

  "x" ~~ /$/  should match "x", not "".

=end kwid

plan 20;

# L >>)>

my regex r {  || x <&r> }

ok "" ~~ /<&r>/, '"" ~~ // matched';
is $/, "", 'with ""';
is $/.from, 0, 'from 0';
is $/.to, 0, 'to 0';

ok "x" ~~ /<&r>/, '"x" ~~ // matched';
is $/, "", 'with ""';
is $/.from, 0, 'from 0';
is $/.to, 0, 'to 0';

#?pugs emit skip_rest 'infinite loop in PCR - XXX fix this before release!';
#?pugs emit exit;

ok "x" ~~ /<&r>$/, '"x" ~~ /$/ matched';
is $/, "x", 'with "x"';
is $/.from, 0, 'from 0';
is $/.to, 1, 'to 1';

ok "xx" ~~ /<&r>$/, '"xx" ~~ /$/ matched';
is $/, "xx", 'with "xx"';
is $/.from, 0, 'from 0';
is $/.to, 2, 'to 2';


# rule r2 {  |  x }
my regex r2 {  | <&r2> x }

ok "x" ~~ /<&r2>$/, '"x" ~~ /$/ matched';
is $/, "x", 'with "x"';
is $/.from, 0, 'from 0';
is $/.to, 1, 'to 1';


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-mass/rx.t0000775000175000017500000031507212237474612016151 0ustar  moritzmoritzuse Test;

plan 739;

### for now
#?pugs emit #
sub matchcheck(*@) { 1 }

# L

##   Backtracking control tests
#### a* a			bazaar		y	control
#?pugs todo 
ok 'bazaar' ~~ /a* a/, 'control';

#### a*: a			bazaar		n	basic
ok !('bazaar' ~~ /a*: a/), 'basic';

#### ^[a|b]*  aba		abbabbababba	y	control
#?pugs todo 
ok 'abbabbababba' ~~ /^[a|b]*  aba/, 'control';

#### ^[a|b]*: aba		abbabbababba	n	outside a group
ok !('abbabbababba' ~~ /^[a|b]*: aba/), 'outside a group';

#### \d+:			123abc		y	cut on character class shortcut
#?pugs todo 
ok '123abc' ~~ /\d+:/, 'cut on character class shortcut';

#### \d+:			abc		n	cut on character class shortcut
ok 'abc' !~~ /\d+:/, 'cut on character class shortcut';

#### [ if    not | ify ]	verify		y	control
#?pugs todo 
ok 'verify' ~~ /[ if    not | ify ]/, 'control';

# L

#### [ if :: not | ify ]	verify		n	inside a group
#?rakudo skip ':: NYI'
#?niecza todo ':: issues'
ok 'verify' !~~ /[ if :: not | ify ]/, 'inside a group';

####   if :: not | ify	verify		n	the default all group
#?rakudo skip ':: NYI'
#?niecza todo ':: issues'
ok 'verify' !~~ /  if :: not | ify/, 'the default all group';

#### [ if :  not | ify ]	verify		y	simple backtrack still works
#?pugs todo 
ok 'verify' ~~ /[ if :  not | ify ]/, 'simple backtrack still works';

#### [ if :: not | ify ] | verify	verify	y	rule continues
#?rakudo skip ':: NYI'
#?pugs todo 
ok 'verify' ~~ /[ if :: not | ify ] | verify/, 'rule continues';

# L
#### [ when     ever ] | whence	whence	y	full backtrack failure
#?pugs todo 
ok 'whence' ~~ /[ when     ever ] | whence/, 'full backtrack failure';

#### [ when ::: ever ] | whence	whence	n	full backtrack failure
#?rakudo skip '::: NYI'
#?niecza todo '::: issue'
ok 'whence' !~~ /[ when ::: ever ] | whence/, 'full backtrack failure';

#### ab::cd | gh::ij		xyabghij	y	group cut at top
#?rakudo skip ':: NYI'
#?pugs todo 
ok 'xyabghij' ~~ /ab::cd | gh::ij/, 'group cut at top';

#### ab:::cd | gh:::ij	xyabghij	n	rule cut at top
#?rakudo skip ':: NYI'
#?niecza todo '::: issue'
ok 'xyabghij' !~~ /ab:::cd | gh:::ij/, 'rule cut at top';

#### [ab::cd | gh::ij]	xyabghij	y	group cut in group
#?rakudo skip ':: NYI'
#?pugs todo 
ok 'xyabghij' ~~ /[ab::cd | gh::ij]/, 'group cut in group';

#### [ab:::cd | gh:::ij]	xyabghij	n	rule cut in group
#?rakudo skip '::: NYI'
#?niecza todo '::: issue'
ok 'xyabghij' !~~ /[ab:::cd | gh:::ij]/, 'rule cut in group';

#### [ ab | abc ]: de	xyzabcde	n	no backtrack into group
#?rakudo todo 'nom regression'
#?niecza todo ''
ok 'xyzabcde' !~~ /[ ab | abc ]: de/, 'no backtrack into group';

#### ( ab | abc ): de	xyzabcde	n	no backtrack into subpattern
ok 'xyzabcde' !~~ /( ab || abc ): de/, 'no backtrack into subpattern';

#### [ when  ever ] | whence	whence	n	full backtrack failure
#?rakudo skip ' not implemented'
#?niecza todo ''
ok 'whence' !~~ /[ when  ever ] | whence/, 'full backtrack failure';

#L

#### :ratchet a* a		bazaar		n	ratchet modifier
ok 'bazaar' !~~ /:ratchet a* a/, 'ratchet modifier';

#### :ratchet a*! a		bazaar		y	force backtracking !
#?pugs todo 
ok 'bazaar' ~~ /:ratchet a*! a/, 'force backtracking !';

#L

##   captures
#### (a.)..(..)		zzzabcdefzzz	y			basic match
#?pugs todo 
ok 'zzzabcdefzzz' ~~ /(a.)..(..)/, 'basic match';

#### (a.)..(..)		zzzabcdefzzz	/mob: /	basic $/
#?pugs todo 
ok ('zzzabcdefzzz' ~~ /(a.)..(..)/) && matchcheck($/, q/mob: /), 'basic $/';

#### (a.)..(..)		zzzabcdefzzz	/mob 0: /	basic $0
#?pugs todo 
ok ('zzzabcdefzzz' ~~ /(a.)..(..)/) && matchcheck($/, q/mob 0: /), 'basic $0';

#### (a.)..(..)		zzzabcdefzzz	/mob 1: /	basic $1
#?pugs todo 
ok ('zzzabcdefzzz' ~~ /(a.)..(..)/) && matchcheck($/, q/mob 1: /), 'basic $1';

#### (a(b(c))(d))		abcd		y			nested match
#?pugs todo 
ok 'abcd' ~~ /(a(b(c))(d))/, 'nested match';

#### (a(b(c))(d))		abcd		/mob: /	nested match
#?pugs todo 
ok ('abcd' ~~ /(a(b(c))(d))/) && matchcheck($/, q/mob: /), 'nested match';

#### (a(b(c))(d))		abcd		/mob 0: /	nested match
#?pugs todo 
ok ('abcd' ~~ /(a(b(c))(d))/) && matchcheck($/, q/mob 0: /), 'nested match';

#### (a(b(c))(d))		abcd		/mob 0 0: /	nested match
#?pugs todo 
ok ('abcd' ~~ /(a(b(c))(d))/) && matchcheck($/, q/mob 0 0: /), 'nested match';

#### (a(b(c))(d))		abcd		/mob 0 0 0: /	nested match
#?pugs todo 
ok ('abcd' ~~ /(a(b(c))(d))/) && matchcheck($/, q/mob 0 0 0: /), 'nested match';

#### (a(b(c))(d))		abcd		/mob 0 1: /	nested match
#?pugs todo 
ok ('abcd' ~~ /(a(b(c))(d))/) && matchcheck($/, q/mob 0 1: /), 'nested match';

#### ((\w+)+)		abcd		/mob: /	nested match
#?pugs todo 
ok ('abcd' ~~ /((\w+)+)/) && matchcheck($/, q/mob: /), 'nested match';

#### ((\w+)+)		abcd		/mob 0: /	nested match
#?pugs todo 
ok ('abcd' ~~ /((\w+)+)/) && matchcheck($/, q/mob 0: /), 'nested match';

#### ((\w+)+)		abcd		/mob 0 0 0: /	nested match
#?pugs todo 
ok ('abcd' ~~ /((\w+)+)/) && matchcheck($/, q/mob 0 0 0: /), 'nested match';

#### ((\w+)+)	ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz	/mob: /	alt subpattern before group
#?pugs todo 
ok ('abcdefg' ~~ /(a) [ (bc) (d) | .* (ef) ] .* (g)/) && matchcheck($/, q/mob 0: /), 'alt subpattern before group';

#### (a) [ (bc) (d) | .* (ef) ] .* (g)	abcdefg	/mob 1: /	alt subpattern in group
#?pugs todo 
ok ('abcdefg' ~~ /(a) [ (bc) (d) | .* (ef) ] .* (g)/) && matchcheck($/, q/mob 1: /), 'alt subpattern in group';

#### (a) [ (bc) (d) | .* (ef) ] .* (g)	abcdefg	/mob 2: /	alt subpattern in group
#?pugs todo 
ok ('abcdefg' ~~ /(a) [ (bc) (d) | .* (ef) ] .* (g)/) && matchcheck($/, q/mob 2: /), 'alt subpattern in group';

#### (a) [ (bc) (d) | .* (ef) ] .* (g)	abcdefg	/mob 3: /	alt subpattern after group
#?pugs todo 
ok ('abcdefg' ~~ /(a) [ (bc) (d) | .* (ef) ] .* (g)/) && matchcheck($/, q/mob 3: /), 'alt subpattern after group';

#### (a) [ (bc) (x) | .* (ef) ] .* (g)	abcdefg	/mob 1: /	2nd alt subpattern in group
#?pugs todo 
ok ('abcdefg' ~~ /(a) [ (bc) (x) | .* (ef) ] .* (g)/) && matchcheck($/, q/mob 1: /), '2nd alt subpattern in group';

#### (a) [ (bc) (x) | .* (ef) ] .* (g)	abcdefg	/mob 3: /	2nd alt subpattern after group
#?pugs todo 
ok ('abcdefg' ~~ /(a) [ (bc) (x) | .* (ef) ] .* (g)/) && matchcheck($/, q/mob 3: /), '2nd alt subpattern after group';

#### ( (.) )*				abc	/mob 0 1 0: /	nested repeated captures
#?pugs todo 
ok ('abc' ~~ /( (.) )*/) && matchcheck($/, q/mob 0 1 0: /), 'nested repeated captures';

#### [ (.) ]*				abc	/mob 0 1: /	nested repeated captures
#?pugs todo 
ok ('abc' ~~ /[ (.) ]*/) && matchcheck($/, q/mob 0 1: /), 'nested repeated captures';

#### ( [.] )*				abc	/mob 0 1: /	nested repeated captures
#?pugs todo 
ok ('abc' ~~ /( [ . ] )*/) && matchcheck($/, q/mob 0 1: /), 'nested repeated captures';

#### (.) (.) $7=(.) (.) $4=(.)		abcdefg	/mob 0: /	numbered aliases $0
#?pugs todo 
ok ('abcdefg' ~~ /(.) (.) $7=(.) (.) $4=(.)/) && matchcheck($/, q/mob 0: /), 'numbered aliases $0';

#### (.) (.) $7=(.) (.) $4=(.)		abcdefg	/mob 1: /	numbered aliases $1
#?pugs todo 
ok ('abcdefg' ~~ /(.) (.) $7=(.) (.) $4=(.)/) && matchcheck($/, q/mob 1: /), 'numbered aliases $1';

#### (.) (.) $7=(.) (.) $4=(.)		abcdefg	/mob 7: /	numbered aliases $7
#?pugs todo 
ok ('abcdefg' ~~ /(.) (.) $7=(.) (.) $4=(.)/) && matchcheck($/, q/mob 7: /), 'numbered aliases $7';

#### (.) (.) $7=(.) (.) $4=(.)		abcdefg	/mob 8: /	numbered aliases $8
#?pugs todo 
ok ('abcdefg' ~~ /(.) (.) $7=(.) (.) $4=(.)/) && matchcheck($/, q/mob 8: /), 'numbered aliases $8';

#### (.) (.) $7=(.) (.) $4=(.)		abcdefg	/mob 4: /	numbered aliases $4
#?pugs todo 
ok ('abcdefg' ~~ /(.) (.) $7=(.) (.) $4=(.)/) && matchcheck($/, q/mob 4: /), 'numbered aliases $4';

#### $1=[ (.) (.) (.) ] (.)			abcdefg	/mob 1: /	perl5 numbered captures $1
#?pugs todo 
ok ('abcdefg' ~~ /$1=[ (.) (.) (.) ] (.)/) && matchcheck($/, q/mob 1: /), 'perl5 numbered captures $1';

#### $1=[ (.) (.) (.) ] (.)			abcdefg	/mob 2: /	perl5 numbered captures $1
#?pugs todo 
ok ('abcdefg' ~~ /$1=[ (.) (.) (.) ] (.)/) && matchcheck($/, q/mob 2: /), 'perl5 numbered captures $1';

#### $1=[ (.) (.) (.) ] (.)			abcdefg	/mob 3: /	perl5 numbered captures $1
#?pugs todo 
ok ('abcdefg' ~~ /$1=[ (.) (.) (.) ] (.)/) && matchcheck($/, q/mob 3: /), 'perl5 numbered captures $1';

#### $1=[ (.) (.) (.) ] (.)			abcdefg	/mob 4: /	perl5 numbered captures $1
#?pugs todo 
ok ('abcdefg' ~~ /$1=[ (.) (.) (.) ] (.)/) && matchcheck($/, q/mob 4: /), 'perl5 numbered captures $1';

#### $1=[ (.) (.) (.) ] (.)			abcdefg	/mob 5: /	perl5 numbered captures $1
#?pugs todo 
ok ('abcdefg' ~~ /$1=[ (.) (.) (.) ] (.)/) && matchcheck($/, q/mob 5: /), 'perl5 numbered captures $1';

#### :s $=[\w+] \= $=[\S+]	 abc = 123	/mob: /	named capture
#?pugs todo 
ok (' abc = 123' ~~ /:s $=[\w+] \= $=[\S+]/) && matchcheck($/, q/mob: /), 'named capture';

#### :s $=[\w+] \= $=[\S+]	 abc = 123	/mob: <123 @ 7>/	named capture
#?pugs todo 
ok (' abc = 123' ~~ /:s $=[\w+] \= $=[\S+]/) && matchcheck($/, q/mob: <123 @ 7>/), 'named capture';

#### :s (\w+) $=(\w+) (\w+)		abc def ghi	/mob: /	mixing named and unnamed capture
#?pugs todo 
ok ('abc def ghi' ~~ /:s (\w+) $=(\w+) (\w+)/) && matchcheck($/, q/mob: /), 'mixing named and unnamed capture';

#### :s (\w+) $=(\w+) (\w+)		abc def ghi	/mob 1: /	mixing named and unnamed capture
#?pugs todo 
ok ('abc def ghi' ~~ /:s (\w+) $=(\w+) (\w+)/) && matchcheck($/, q/mob 1: /), 'mixing named and unnamed capture';

####  [ \-  ]?			abc def ghi	/mob 0: /	multiple subrule captures in same scope
#?pugs todo 
ok ('abc def ghi' ~~ / [ \-  ]?/) && matchcheck($/, q/mob 0: /), 'multiple subrule captures in same scope';

#### [(.)$0]+				bookkeeper	y			backreference
#?pugs todo 
ok 'bookkeeper' ~~ /[ (.) $0 ]+/, 'backreference';

#### (\w+) <+ws> $0				hello hello	y			backreference at end of string
#?pugs todo 
ok 'hello hello' ~~ /(\w+) <+ws> $0/, 'backreference at end of string';

#### [(.)$0]+				bookkeeper	/mob 0 0: /	backref $0
#?pugs todo 
ok ('bookkeeper' ~~ /[ (.) $0 ]+/) && matchcheck($/, q/mob 0 0: /), 'backref $0';

#### [(.)$0]+				bookkeeper	/mob 0 1: /	backref $0
#?pugs todo 
ok ('bookkeeper' ~~ /[ (.) $0 ]+/) && matchcheck($/, q/mob 0 1: /), 'backref $0';

#### [(.)$0]+				bookkeeper	/mob 0 2: /	backref $0
#?pugs todo 
ok ('bookkeeper' ~~ /[ (.) $0 ]+/) && matchcheck($/, q/mob 0 2: /), 'backref $0';

#### (.)*x					123x		/mob: <123x @ 0>/	repeated dot capture
#?pugs todo 
ok ('123x' ~~ /(.)*x/) && matchcheck($/, q/mob: <123x @ 0>/), 'repeated dot capture';


#### $=				12ab34		/mob: /	alias capture
#?pugs todo 
ok ('12ab34' ~~ /$=/) && matchcheck($/, q/mob: /), 'alias capture';

#### 				12ab34		/mob: /	alias capture
#?pugs todo 
ok ('12ab34' ~~ //) && matchcheck($/, q/mob: /), 'alias capture';

# L >>)/"A leading [ indicates">

##   Enumerated character lists
#### <[c]>			abcdef		y	character class
#?pugs todo 
ok 'abcdef' ~~ /<[c]>/, 'character class';

#### <[ z ]>			abc def		n	character class ignores ws
ok 'abc def' !~~ /<[ z ]>/, 'character class ignores ws';

#### <[dcb]>**{3}		abcdef		y	repeated character class
#?pugs todo 
#?rakudo skip 'closure repetition'
ok 'abcdef' ~~ /<[dcb]>**{3}/, 'repeated character class';

#### ^<[a]>			abcdef		y	anchored character class
#?pugs todo 
ok 'abcdef' ~~ /^<[a]>/, 'anchored character class';

# L >>)/"A leading - indicates">

#### <-[e]>			abcdef		y	negated character class
#?pugs todo 
ok 'abcdef' ~~ /<-[e]>/, 'negated character class';

#### ^<[a]>?			abcdef		y	anchored optional character class
#?pugs todo 
ok 'abcdef' ~~ /^<[a]>?/, 'anchored optional character class';

#### <-[e]>?			abcdef		y	negated optional character class
#?pugs todo 
ok 'abcdef' ~~ /<-[e]>?/, 'negated optional character class';

#### <-[dcb]>**{3}		abcdef		n	repeated negated character class
#?rakudo skip 'nom regression'
ok 'abcdef' !~~ /<-[dcb]>**{3}/, 'repeated negated character class';

#### ^<-[e]>			abcdef		y	anchored negated character class
#?pugs todo 
ok 'abcdef' ~~ /^<-[e]>/, 'anchored negated character class';

#### ^<-[a]>			abcdef		n	anchored negated character class
ok 'abcdef' !~~ /^<-[a]>/, 'anchored negated character class';

# L >>)/"Ranges in enumerated character classes">
#### <[b..d]>		abcdef		y	character range
#?pugs todo 
ok 'abcdef' ~~ /<[b..d]>/, 'character range';

#### <[b .. d]>		c		y	character range ignores ws
#?pugs todo 
ok 'c' ~~ /<[b .. d]>/, 'character range ignores ws';

#### <[b..d]>		abxxef		y	character range
#?pugs todo 
ok 'abxxef' ~~ /<[b..d]>/, 'character range';

#### <[b..d]>		axcxef		y	character range
#?pugs todo 
ok 'axcxef' ~~ /<[b..d]>/, 'character range';

#### <[b..d]>		axxdef		y	character range
#?pugs todo 
ok 'axxdef' ~~ /<[b..d]>/, 'character range';

#### <[b..d]>		axxxef		n	character range
ok 'axxxef' !~~ /<[b..d]>/, 'character range';

#### <-[b..d]>		abcdef		y	negated character range
#?pugs todo 
ok 'abcdef' ~~ /<-[b..d]>/, 'negated character range';

#### <- [b..d]>		abcdef		y	negated allows ws
#?niecza skip "space between - and [ ] is a problem?"
#?pugs todo 
ok 'abcdef' ~~ /<- [b..d]>/, 'negated allows ws';

#### <-[b..d]>		bbccdd		n	negated character range
ok 'bbccdd' !~~ /<-[b..d]>/, 'negated character range';

#### <-[d..b]>		dies
#?niecza todo ""
#?pugs todo 
eval_dies_ok '/<-[d..b]>/', 'illegal character range';

#?pugs todo 
ok '-' ~~ /<[-]>/, 'unescaped hyphen is fine on its own';

#### <[\-]>			ab-def		y	escaped hyphen
#?pugs todo 
ok 'ab-def' ~~ /<[\-]>/, 'escaped hyphen';

#### <[\-]>			abcdef		n	escaped hyphen
ok 'abcdef' !~~ /<[\-]>/, 'escaped hyphen';

#### <-[\-]>			---x--		y	negated escaped hyphen
#?pugs todo 
ok '---x--' ~~ /<-[\-]>/, 'negated escaped hyphen';

#### <-[\-]>			------		n	negated escaped hyphen
ok '------' !~~ /<-[\-]>/, 'negated escaped hyphen';

#### <[\-+]>			ab-def		y	escaped hyphen in range
#?pugs todo 
ok 'ab-def' ~~ /<[\-+]>/, 'escaped hyphen in range';

#### <[\-+]>			ab+def		y	escaped hyphen in range
#?pugs todo 
ok 'ab+def' ~~ /<[\-+]>/, 'escaped hyphen in range';

#### <[\-+]>			abcdef		n	escaped hyphen in range
ok 'abcdef' !~~ /<[\-+]>/, 'escaped hyphen in range';

#### <[+\-]>			ab-def		y	escaped hyphen in range
#?pugs todo 
ok 'ab-def' ~~ /<[+\-]>/, 'escaped hyphen in range';

#### <[+\-]>			ab+def		y	escaped hyphen in range
#?pugs todo 
ok 'ab+def' ~~ /<[+\-]>/, 'escaped hyphen in range';

#### <[+\-]>			abcdef		n	escaped hyphen in range
ok 'abcdef' !~~ /<[+\-]>/, 'escaped hyphen in range';

#### <-[\-+]>		---x--		y	negated escaped hyphen in range
#?pugs todo 
ok '---x--' ~~ /<-[\-+]>/, 'negated escaped hyphen in range';

#### <-[\-+]>		------		n	negated escaped hyphen in range
ok '------' !~~ /<-[\-+]>/, 'negated escaped hyphen in range';

#### <-[+\-]>		---x--		y	negated escaped hyphen in range
#?pugs todo 
ok '---x--' ~~ /<-[+\-]>/, 'negated escaped hyphen in range';

#### <-[+\-]>		------		n	negated escaped hyphen in range
ok '------' !~~ /<-[+\-]>/, 'negated escaped hyphen in range';

#### <["\\]>			\\			y	escaped backslash
#?pugs todo 
ok '\\' ~~ /<["\\]>/, 'escaped backslash';

#### <[\]]>			]			y	escaped close bracket
#?pugs todo 
ok ']' ~~ /<[\]]>/, 'escaped close bracket';

#### <[\]>			\\]]		/parse error/	unescaped backslash (or no closing brace)
#?pugs todo 
eval_dies_ok ' /<[\]>/ ', 'unescaped backslash (or no closing brace)';

#### ^\><[<]>		><		y	lt character class
#?pugs todo 
ok '><' ~~ /^\><[<]>/, 'lt character class';

#### ^<[>]>\<		><		y	gt character class
#?pugs todo 
ok '><' ~~ /^<[>]>\<]>**{2}		><		y	gt, lt character class
#?pugs todo 
#?rakudo skip '**{}'
ok '><' ~~ /^<[><]>**{2}/, 'gt, lt character class';

#### ^<[<>]>**{2}		><		y	lt, gt  character class
#?pugs todo 
#?rakudo skip '**{}'
ok '><' ~~ /^<[<>]>**{2}/, 'lt, gt  character class';

#### ^<-[><]>		><		n	not gt, lt character class
ok '><' !~~ /^<-[><]>/, 'not gt, lt character class';

#### ^<-[<>]>		><		n	not lt, gt  character class
ok '><' !~~ /^<-[<>]>/, 'not lt, gt  character class';

#### '... --- ...'		... --- ...	y	literal match (\\\')
#?pugs todo 
ok '... --- ...' ~~ /'... --- ...'/, 'literal match (\\\')';

#### '... --- ...'		...---...	n	literal match (\\\')
ok '...---...' !~~ /'... --- ...'/, 'literal match (\\\')';

#### 'ab\'>cd'		ab\'>cd		y	literal match with quote
#?pugs todo 
ok 'ab\'>cd' ~~ /'ab\'>cd'/, 'literal match with quote';

#### 'ab\\yz'		ab\x5cyz	y	literal match with backslash
#?pugs todo 
ok "ab\x5cyz" ~~ /'ab\\yz'/, 'literal match with backslash';

#### 'ab"cd'			ab"cd		y	literal match with quote
#?pugs todo 
ok 'ab"cd' ~~ /'ab"cd'/, 'literal match with quote';

#### 'ab\\yz'		ab\x5cyz	y	literal match with backslash
#?pugs todo 
ok "ab\x5cyz" ~~ /'ab\\yz'/, 'literal match with backslash';

#### "... --- ..."		... --- ...	y	literal match (\")
#?pugs todo 
ok '... --- ...' ~~ /"... --- ..."/, 'literal match (\")';

#### "... --- ..."		...---...	n	literal match (\")
# RT #64880
ok '...---...' !~~ /"... --- ..."/, 'literal match (\")';

#### "ab<\">cd"		ab<">cd		y	literal match with quote
# RT #64880
#?pugs todo 
ok 'ab<">cd' ~~ /"ab<\">cd"/, 'literal match with quote';

#### "ab<'>cd"		ab<\'>cd		y	literal match with quote
# RT #64880
#?pugs todo 
ok 'ab<\'>cd' ~~ /"ab<'>cd"/, 'literal match with quote';

#### "ab\\cd"		ab\x5ccd	y	literal match with backslash
#?pugs todo 
ok "ab\x[5c]cd" ~~ /"ab\\cd"/, 'literal match with backslash';

#### (ab)x"$0"		abxab		y	literal match with interpolation
#?pugs todo 
ok 'abxab' ~~ /(ab)x"$0"/, 'literal match with interpolation';

#### (ab)"x$0"		abxab		y	literal match with interpolation
#?pugs todo 
ok 'abxab' ~~ /(ab)"x$0"/, 'literal match with interpolation';

# L >>)/"A leading ? indicates">
#
#### '?'			ab		abcdef		n	two enumerated ranges
ok 'abcdef' !~~ /<[A..Z0..9]>/, 'two enumerated ranges';

#### <[A..Z0..9]>		abcDef		y	two enumerated ranges
#?pugs todo 
ok 'abcDef' ~~ /<[A..Z0..9]>/, 'two enumerated ranges';


# L >>)/"The special named assertions">
#
## lookarounds
####  a.		abacad		/mob: /			lookahead 
#?pugs todo 
ok ('abacad' ~~ / a./) && matchcheck($/, q/mob: /), 'lookahead ';

####  ....		abacad		n				lookahead 
ok 'abacad' !~~ / ..../, 'lookahead ';

####  .		abcd		n				null 
#?pugs todo 
eval_dies_ok "'abcd' !~~ / ./", 'null ';

####  aa	aabaaa		/mob: /			negated lookahead
#?pugs todo 
ok ('aabaaa' ~~ / aa/) && matchcheck($/, q/mob: /), 'negated lookahead';

#### b		ab		y				lookbehind 
#?pugs todo 
ok 'ab' ~~ /b/, 'lookbehind ';

#### b		cb		n				lookbehind 
ok 'cb' !~~ /b/, 'lookbehind ';

#### b		b		n				lookbehind 
ok 'b' !~~ /b/, 'lookbehind ';

#### b		ab		y				lookbehind 
#?pugs todo 
ok 'ab' ~~ /b/, 'lookbehind ';

#### b		cb		n				lookbehind 
ok 'cb' !~~ /b/, 'lookbehind ';

#### b		b		y				lookbehind 
#?pugs todo 
ok 'b' ~~ /b/, 'lookbehind ';

#### >b	dbcb		n				lookbehind 
ok 'dbcb' !~~ />b/, 'lookbehind ';

#### ><[ab]>	dbaacb		y				lookbehind 
#?pugs todo 
ok 'dbaacb' ~~ /><[ab]>/, 'lookbehind ';

#### b		dbcb		n				lookbehind 
#?niecza skip "Unsuppored elements in after list"
ok 'dbcb' !~~ /b/, 'lookbehind ';

#### <[ab]>	dbaacb		y				lookbehind 
#?niecza skip "Unsuppored elements in after list"
#?pugs todo 
ok 'dbaacb' ~~ /<[ab]>/, 'lookbehind ';

#### <[ab]>	cbaccb		y				lookbehind 
#?pugs todo 
ok 'cbaccb' ~~ /<[ab]>/, 'lookbehind ';

#### $ 		a		y				lookbehind 
#?rakudo todo 'anchors and after'
#?niecza skip "Unsuppored elements in after list"
#?pugs todo 
ok 'a' ~~ /$ /, 'lookbehind ';

#### y		axxbxxyc	y				lookbehind 
#?niecza skip "Unsuppored elements in after list"
#?pugs todo 
ok 'axxbxxyc' ~~ /y/, 'lookbehind ';

# L >>)/"A leading + may also">

#### <[a..z]>+		az		y				metasyntax with leading + (<+...>)
#?pugs todo 
ok 'az' ~~ /<[a..z]>+/, 'metasyntax with leading + (<+...>)';

#### <+[a..z]>+		az		y				metasyntax with leading + (<+...>)
#?pugs todo 
ok 'az' ~~ /<+[a..z]>+/, 'metasyntax with leading + (<+...>)';

#### <+alpha>+		az		y				metasyntax with leading + (<+...>)
#?pugs todo 
ok 'az' ~~ /<+alpha>+/, 'metasyntax with leading + (<+...>)';


#### a[b}		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/rule error/	mismatched close
#?pugs todo 
eval_dies_ok '/a[b}/', 'mismatched close';


#### c 		abacad		/mob: /				one character and lookahead 
#?pugs todo 
ok ('abacad' ~~ /c /) && matchcheck($/, q/mob: /), 'one character and lookahead ';

#### .* 		abacad		/mob: /			multiple characters and lookahead 
#?pugs todo 
ok ('abacad' ~~ /.* /) && matchcheck($/, q/mob: /), 'multiple characters and lookahead ';

#### .* 		abaca/			multiple characters and lookahead  with a \'<\'
#?pugs todo 
ok ('abaca/) && matchcheck($/, q/mob: /), 'multiple characters and lookahead  with a \'<\'';

#### .* 		aba/		greedy any character and lookahead  with a \'<\'
#?pugs todo 
ok ('aba/) && matchcheck($/, q/mob: /), 'greedy any character and lookahead  with a \'<\'';

#### .*? 		aba/		non-greedy any character and lookahead  with a \'<\'
#?pugs todo 
ok ('aba/) && matchcheck($/, q/mob: /), 'non-greedy any character and lookahead  with a \'<\'';


##   Metacharacter tests
#### .			a		y	dot (.)
#?pugs todo 
ok 'a' ~~ /./, 'dot (.)';

#### .			\n		y	dot (.)
#?pugs todo 
ok '\n' ~~ /./, 'dot (.)';

#### .			''		n	dot (.)
ok '' !~~ /./, 'dot (.)';

#### a\s+f			abcdef		n	whitespace (\s)
ok 'abcdef' !~~ /a\s+f/, 'whitespace (\s)';

#### ab\s+cdef		ab  cdef	y	whitespace (\s)
#?pugs todo 
ok 'ab  cdef' ~~ /ab\s+cdef/, 'whitespace (\s)';

#### a\S+f			abcdef		y	not whitespace (\S)
#?pugs todo 
ok 'abcdef' ~~ /a\S+f/, 'not whitespace (\S)';

#### a\S+f			ab cdef		n	not whitespace (\S)
ok 'ab cdef' !~~ /a\S+f/, 'not whitespace (\S)';

#### ^ abc			abcdef		y	start and end of string (^)
#?pugs todo 
ok 'abcdef' ~~ /^ abc/, 'start and end of string (^)';

#### ^ abc			abc\ndef	y	start and end of string (^)
#?pugs todo 
ok "abc\ndef" ~~ /^ abc/, 'start and end of string (^)';

#### ^ abc			def\nabc	n	start and end of string (^)
ok "def\nabc" !~~ /^ abc/, 'start and end of string (^)';

#### def \n ^ abc		def\nabc	n	start and end of string (^)
ok "def\nabc" !~~ /def \n ^ abc/, 'start and end of string (^)';

#### def $			abcdef		y	start and end of string ($)
#?pugs todo 
ok 'abcdef' ~~ /def $/, 'start and end of string ($)';

#### def $			abc\ndef	y	start and end of string ($)
#?pugs todo 
ok "abc\ndef" ~~ /def $/, 'start and end of string ($)';

#### def $			def\nabc	n	start and end of string ($)
ok "def\nabc" !~~ /def $/, 'start and end of string ($)';

#### def $ \n abc		def\nabc	n	start and end of string (^)
ok "def\nabc" !~~ /def $ \n abc/, 'start and end of string (^)';

#### abc \n $		abc\n		y	end of string ($)
#?pugs todo 
ok "abc\n" ~~ /abc \n $/, 'end of string ($)';

#### abc $			abc\n		n	end of string ($)
ok "abc\n" !~~ /abc $/, 'end of string ($)';

#### <>def			abc-def		n	right word boundary, beginning of word
ok 'abc-def' !~~ />>def/, 'right word boundary, beginning of word';

#### >>bc			abc-def		n	right word boundary, mid-word
ok 'abc-def' !~~ />>bc/, 'right word boundary, mid-word';

#### c>>			abc-def		y	right word boundary, end of word
#?pugs todo 
ok 'abc-def' ~~ /c>>/, 'right word boundary, end of word';

#### >>abc			abc-def		n	right word boundary, BOS
ok 'abc-def' !~~ />>abc/, 'right word boundary, BOS';

#### def>>			abc-def		y	right word boundary, EOS
#?pugs todo 
ok 'abc-def' ~~ /def>>/, 'right word boundary, EOS';

#### >>			-------		n	right word boundary, no word chars
ok '-------' !~~ />>/, 'right word boundary, no word chars';


#### c \n d			abc\ndef	y	logical newline (\n)
#?pugs todo 
ok "abc\ndef" ~~ /c \n d/, 'logical newline (\n)';

#### c \n d			abc\rdef	y	logical newline matches \r
#?pugs todo 
ok "abc\rdef" ~~ /c \n d/, 'logical newline matches \r';

#### c \n+ d			abc\n\ndef	y	logical newline quantified
#?pugs todo 
ok "abc\n\ndef" ~~ /c \n+ d/, 'logical newline quantified';

#### a\n+f			abcdef		n	logical newline (\n)
ok 'abcdef' !~~ /a\n+f/, 'logical newline (\n)';

#### c \n d			abc\n\rdef	n	logical newline matches \n\r
ok "abc\n\rdef" !~~ /c \n d/, 'logical newline matches \n\r';

#### c \n d			abc\r\ndef	y	logical newline matches \r\n
#?pugs todo 
ok "abc\r\ndef" ~~ /c \n d/, 'logical newline matches \r\n';

#### b \n c			abc\ndef	n	logical newline (\n)
ok "abc\ndef" !~~ /b \n c/, 'logical newline (\n)';

#### \N			a		y	not logical newline (\N)
#?pugs todo 
ok 'a' ~~ /\N/, 'not logical newline (\N)';

#### a \N c			abc		y	not logical newline (\N)
#?pugs todo 
ok 'abc' ~~ /a \N c/, 'not logical newline (\N)';

#### \N			''		n	not logical newline (\N)
ok '' !~~ /\N/, 'not logical newline (\N)';

#### c \N d			abc\ndef	n	not logical newline (\N)
ok "abc\ndef" !~~ /c \N d/, 'not logical newline (\N)';

#### c \N d			abc\rdef	n	not logical newline (\N)
ok "abc\rdef" !~~ /c \N d/, 'not logical newline (\N)';

#### c \N+ d			abc\n\ndef	n	not logical newline (\N)
ok "abc\n\ndef" !~~ /c \N+ d/, 'not logical newline (\N)';

#### a\N+f			abcdef		y	not logical newline (\N)
#?pugs todo 
ok 'abcdef' ~~ /a\N+f/, 'not logical newline (\N)';

#### c \N d			abc\n\rdef	n	not logical newline (\N)
ok "abc\n\rdef" !~~ /c \N d/, 'not logical newline (\N)';

#### c \N d			abc\r\ndef	n	not logical newline (\N)
ok "abc\r\ndef" !~~ /c \N d/, 'not logical newline (\N)';

#### b \N \n			abc\ndef	y	not logical newline (\N)
#?pugs todo 
ok "abc\ndef" ~~ /b \N \n/, 'not logical newline (\N)';

#### \Aabc			Aabc		/reserved/	retired metachars (\A)
#?pugs todo 
eval_dies_ok '/\Aabc/', 'retired metachars (\A)';

#### \Aabc			abc\ndef	/reserved/	retired metachars (\A)
#?pugs todo 
eval_dies_ok '/\Aabc/', 'retired metachars (\A)';

#### abc\Z			abcZ		/reserved/	retired metachars (\Z)
#?pugs todo 
eval_dies_ok '/abc\Z/', 'retired metachars (\Z)';

#### abc\Z			abc\ndef	/reserved/	retired metachars (\Z)
#?pugs todo 
eval_dies_ok '/abc\Z/', 'retired metachars (\Z)';

#### abc\z			abcz		/reserved/	retired metachars (\z)
#?pugs todo 
eval_dies_ok '/abc\z/', 'retired metachars (\z)';

#### def\z			abc\ndef	/reserved|Obsolete|Unsupported/	retired metachars (\z)
#?pugs todo 
eval_dies_ok '/def\z/', 'retired metachars (\z)';

#### abc # def		abc#def		y	comments (#)
#?pugs todo 
ok 'abc#def' ~~ /abc # def
/, 'comments (#)';

#### abc # xyz		abc#def		y	comments (#)
#?pugs todo 
ok 'abc#def' ~~ /abc # xyz
/, 'comments (#)';

#### abc # def \n \$		abc#def		y	comments (#)
#?pugs todo 
ok 'abc#def' ~~ /abc # def \n \$
/, 'comments (#)';

#### abc '#' def		abc#def		y	comments (#)
#?pugs todo 
ok 'abc#def' ~~ /abc '#' def
/, 'comments (#)';

#### abc '#' xyz		abc#def		n	comments (#)
ok 'abc#def' !~~ /abc '#' xyz
/, 'comments (#)';

#### ^ abc '#' def $		abc#def		y	comments (#)
#?pugs todo 
ok 'abc#def' ~~ /^ abc '#' def $
/, 'comments (#)';

#### ^^ abc \n ^^ def	abc\ndef	y	line beginnings and endings (^^)
#?pugs todo 
ok "abc\ndef" ~~ /^^ abc \n ^^ def/, 'line beginnings and endings (^^)';

#### ^^ abc \n ^^ def \n ^^	abc\ndef\n	n	line beginnings and endings (^^)
ok "abc\ndef\n" !~~ /^^ abc \n ^^ def \n ^^/, 'line beginnings and endings (^^)';

#### ^^ \n			\n		y	line beginnings and endings (^^)
#?pugs todo 
ok "\n" ~~ /^^ \n/, 'line beginnings and endings (^^)';

#### \n ^^			\n		n	line beginnings and endings (^^)
ok "\n" !~~ /\n ^^/, 'line beginnings and endings (^^)';

#### abc $$ \n def $$	abc\ndef	y	line beginnings and endings ($$)
#?pugs todo 
ok "abc\ndef" ~~ /abc $$ \n def $$/, 'line beginnings and endings ($$)';

#### abc $$ \n def $$ \n $$	abc\ndef\n	n	line beginnings and endings ($$)
ok "abc\ndef\n" !~~ /abc $$ \n def $$ \n $$/, 'line beginnings and endings ($$)';

#### $$ \n			\n		y	line beginnings and endings ($$)
#?pugs todo 
ok "\n" ~~ /$$ \n/, 'line beginnings and endings ($$)';

#### \n $$			\n		n	line beginnings and endings ($$)
ok "\n" !~~ /\n $$/, 'line beginnings and endings ($$)';

#### <[a..d]> | <[b..e]>	c		y	alternation (|)
#?pugs todo 
ok 'c' ~~ /<[a..d]> | <[b..e]>/, 'alternation (|)';

#### <[a..d]> | <[d..e]>	c		y	alternation (|)
#?pugs todo 
ok 'c' ~~ /<[a..d]> | <[d..e]>/, 'alternation (|)';

#### <[a..b]> | <[b..e]>	c		y	alternation (|)
#?pugs todo 
ok 'c' ~~ /<[a..b]> | <[b..e]>/, 'alternation (|)';

#### <[a..b]> | <[d..e]>	c		n	alternation (|)
ok 'c' !~~ /<[a..b]> | <[d..e]>/, 'alternation (|)';

#### <[a..d]>+ | <[b..e]>+	bcd		y	alternation (|)
#?pugs todo 
ok 'bcd' ~~ /<[a..d]>+ | <[b..e]>+/, 'alternation (|)';

#### ^ [ <[a..d]>+ | <[b..e]>+ ] $	bcd		y	alternation (|)
#?pugs todo 
ok 'bcd' ~~ /^ [ <[a..d]>+ | <[b..e]>+ ] $/, 'alternation (|)';

#### ^ [ <[a..c]>+ | <[b..e]>+ ] $	bcd		y	alternation (|)
#?pugs todo 
ok 'bcd' ~~ /^ [ <[a..c]>+ | <[b..e]>+ ] $/, 'alternation (|)';

#### ^ [ <[a..d]>+ | <[c..e]>+ ] $	bcd		y	alternation (|)
#?pugs todo 
ok 'bcd' ~~ /^ [ <[a..d]>+ | <[c..e]>+ ] $/, 'alternation (|)';

#### b|			bcd		/rule error/	alternation (|) - null right arg illegal
#?pugs todo 
eval_dies_ok '/b|/', 'alternation (|) - null right arg illegal';

#### |b			bcd		y	alternation (|) - null left arg ignored
#?pugs todo 
ok 'bcd' ~~ /|b/, 'alternation (|) - null left arg ignored';

#### |			bcd		/rule error/	alternation (|) - null both args illegal
#?pugs todo 
eval_dies_ok '/|/', 'alternation (|) - null both args illegal';

#### \|			|		y	alternation (|) - literal must be escaped
#?pugs todo 
ok '|' ~~ /\|/, 'alternation (|) - literal must be escaped';

#### |			|		/rule error/	alternation (|) - literal must be escaped
#?pugs todo 
eval_dies_ok '/|/', 'alternation (|) - literal must be escaped';

#### <[a..d]> & <[b..e]>	c		y	conjunction (&)
#?niecza todo ''
#?pugs todo 
ok 'c' ~~ /<[a..d]> & <[b..e]>/, 'conjunction (&)';

#### <[a..d]> & <[d..e]>	c		n	conjunction (&)
ok 'c' !~~ /<[a..d]> & <[d..e]>/, 'conjunction (&)';

#### <[a..b]> & <[b..e]>	c		n	conjunction (&)
ok 'c' !~~ /<[a..b]> & <[b..e]>/, 'conjunction (&)';

#### <[a..b]> & <[d..e]>	c		n	conjunction (&)
ok 'c' !~~ /<[a..b]> & <[d..e]>/, 'conjunction (&)';

#### <[a..d]>+ & <[b..e]>+	bcd		y	conjunction (&)
#?pugs todo 
ok 'bcd' ~~ /<[a..d]>+ & <[b..e]>+/, 'conjunction (&)';

#### ^ [ <[a..d]>+ & <[b..e]>+ ] $	bcd		y	conjunction (&)
#?pugs todo 
ok 'bcd' ~~ /^ [ <[a..d]>+ & <[b..e]>+ ] $/, 'conjunction (&)';

#### <[a..c]>+ & <[b..e]>+	bcd		y	conjunction (&)
#?pugs todo 
ok 'bcd' ~~ /<[a..c]>+ & <[b..e]>+/, 'conjunction (&)';

#### <[a..d]>+ & <[c..e]>+	bcd		y	conjunction (&)
#?pugs todo 
ok 'bcd' ~~ /<[a..d]>+ & <[c..e]>+/, 'conjunction (&)';

#### b&			bcd		/rule error/	conjunction (&) - null right arg illegal
#?pugs todo 
eval_dies_ok '/b&/', 'conjunction (&) - null right arg illegal';

#### &b			bcd		/rule error/	conjunction (&) - null left arg legal
#?niecza todo ''
#?pugs todo 
eval_lives_ok '/&b/', 'conjunction (&) - null left arg legal';

#### &			bcd		/rule error/	conjunction (&) - null both args illegal
#?pugs todo 
eval_dies_ok '/&/', 'conjunction (&) - null both args illegal';

#### \&			&		y	conjunction (&) - literal must be escaped
#?pugs todo 
ok '&' ~~ /\&/, 'conjunction (&) - literal must be escaped';

#### &			&		/rule error/	conjunction (&) - literal must be escaped
#?pugs todo 
eval_dies_ok '/&/', 'conjunction (&) - literal must be escaped';

# todo :pge
#### a&|b			a&|b		/rule error/	alternation and conjunction (&|) - parse error
#?pugs todo 
eval_dies_ok '/a&|b/', 'alternation and conjunction (&|) - parse error';

#### a|&b			a|&b		/rule error/	alternation and conjunction (|&) - parse error
#?pugs todo 
eval_dies_ok '/a|&b/', 'alternation and conjunction (|&) - parse error';

#### |d|b			abc		y	leading alternation ignored
#?pugs todo 
ok 'abc' ~~ /|d|b/, 'leading alternation ignored';

####  |d|b			abc		y	leading alternation ignored
#?pugs todo 
ok 'abc' ~~ / |d|b/, 'leading alternation ignored';

#### |d |b			abc		y	leading alternation ignored
#?pugs todo 
ok 'abc' ~~ /|d |b/, 'leading alternation ignored';

####  | d | b		abc		y	leading alternation ignored
#?pugs todo 
ok 'abc' ~~ / | d | b/, 'leading alternation ignored';

####  b |  | d		abc		n	null pattern invalid
#?pugs todo 
eval_dies_ok '/ b |  | d/', 'null pattern invalid';

#### \pabc			pabc		/reserved/	retired metachars (\p)
#?pugs todo 
eval_dies_ok '/\pabc/', 'retired metachars (\p)';

#### \p{InConsonant}		a		/reserved/	retired metachars (\p)
#?pugs todo 
eval_dies_ok '/\p{InConsonant}/', 'retired metachars (\p)';

#### \Pabc			Pabc		/reserved/	retired metachars (\P)
#?pugs todo 
eval_dies_ok '/\Pabc/', 'retired metachars (\P)';

#### \P{InConsonant}		a		/reserved/	retired metachars (\P)
#?pugs todo 
eval_dies_ok '/\P{InConsonant}/', 'retired metachars (\P)';

#### \Labc\E			LabcE		/reserved/	retired metachars (\L...\E)
#?pugs todo 
eval_dies_ok '/\Labc\E/', 'retired metachars (\L...\E)';

#### \LABC\E			abc		/reserved/	retired metachars (\L...\E)
#?pugs todo 
eval_dies_ok '/\LABC\E/', 'retired metachars (\L...\E)';

#### \Uabc\E			UabcE		/reserved/	retired metachars (\U...\E)
#?pugs todo 
eval_dies_ok '/\Uabc\E/', 'retired metachars (\U...\E)';

#### \Uabc\E			ABC		/reserved/	retired metachars (\U...\E)
#?pugs todo 
eval_dies_ok '/\Uabc\E/', 'retired metachars (\U...\E)';

#### \Qabc\E			QabcE		/reserved/	retired metachars (\Q...\E)
#?pugs todo 
eval_dies_ok '/\Qabc\E/', 'retired metachars (\Q...\E)';

#### \Qabc d?\E		abc d		/reserved/	retired metachars (\Q...\E)
#?pugs todo 
eval_dies_ok '/\Qabc d?\E/', 'retired metachars (\Q...\E)';

#### \Gabc			Gabc		/reserved/	retired metachars (\G)
#?pugs todo 
eval_dies_ok '/\Gabc/', 'retired metachars (\G)';

#### \1abc			1abc		/reserved/	retired metachars (\1)
#?pugs todo 
eval_dies_ok '/\1abc/', 'retired metachars (\1)';

#### ^ \s+ $			\x0009\x0020\x00a0\x000a\x000b\x000c\x000d\x0085	y	0-255 whitespace (\s)
#?pugs todo 
ok "\x0009\x0020\x00a0\x000a\x000b\x000c\x000d\x0085" ~~ /^ \s+ $/, '0-255 whitespace (\s)';

#### ^ \h+ $			\x0009\x0020\x00a0	y	0-255 horizontal whitespace (\h)
#?pugs todo 
ok "\x0009\x0020\x00a0" ~~ /^ \h+ $/, '0-255 horizontal whitespace (\h)';

#### ^ \V+ $			\x0009\x0020\x00a0	y	0-255 horizontal whitespace (\V)
#?pugs todo 
ok "\x0009\x0020\x00a0" ~~ /^ \V+ $/, '0-255 horizontal whitespace (\V)';

#### ^ \v+ $			\x000a\x000b\x000c\x000d\x0085	y	0-255 vertical whitespace (\v)
#?pugs todo 
ok "\x000a\x000b\x000c\x000d\x0085" ~~ /^ \v+ $/, '0-255 vertical whitespace (\v)';

#### ^ \h+ $			\x000a\x000b\x000c\x000d\x0085	n	0-255 horizontal whitespace (\h)
ok "\x000a\x000b\x000c\x000d\x0085" !~~ /^ \h+ $/, '0-255 horizontal whitespace (\h)';

#### ^ \v+ $			\x0009\x0020\x00a0	n	0-255 vertical whitespace (\v)
ok "\x0009\x0020\x00a0" !~~ /^ \v+ $/, '0-255 vertical whitespace (\v)';

#### ^ \s+ $			\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000	y	unicode whitespace (\s)
#?pugs todo 
ok "\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000" ~~ /^ \s+ $/, 'unicode whitespace (\s)';

#### ^ \h+ $			\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000	y	unicode whitespace (\h)
#?pugs todo 
ok "\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000" ~~ /^ \h+ $/, 'unicode whitespace (\h)';

#### ^ \V+ $			\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000	y	unicode whitespace (\V)
#?pugs todo 
ok "\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000" ~~ /^ \V+ $/, 'unicode whitespace (\V)';

#### ^ \v+ $			\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000	n	unicode whitespace (\v)
ok "\x1680\x180e\x2000\x2001\x2002\x2003\x2004\x2005\x2006\x2007\x2008\x2008\x2009\x200a\x202f\x205f\x3000" !~~ /^ \v+ $/, 'unicode whitespace (\v)';

#### c \t d			abc\tdef	y	horizontal tab (\t)
#?pugs todo 
ok "abc\tdef" ~~ /c \t d/, 'horizontal tab (\t)';

#### c \t+ d			abc\t\tdef	y	horizontal tab (\t)
#?pugs todo 
ok "abc\t\tdef" ~~ /c \t+ d/, 'horizontal tab (\t)';

#### a \t+ f			abcdef		n	horizontal tab (\t)
ok 'abcdef' !~~ /a \t+ f/, 'horizontal tab (\t)';

#### b \t c			abc\tdef	n	horizontal tab (\t)
ok "abc\tdef" !~~ /b \t c/, 'horizontal tab (\t)';

#### \T			a		y	not horizontal tab (\T)
#?pugs todo 
ok 'a' ~~ /\T/, 'not horizontal tab (\T)';

#### a \T c			abc		y	not horizontal tab (\T)
#?pugs todo 
ok 'abc' ~~ /a \T c/, 'not horizontal tab (\T)';

#### \T			''		n	not horizontal tab (\T)
ok '' !~~ /\T/, 'not horizontal tab (\T)';

#### c \T d			abc\tdef	n	not horizontal tab (\T)
ok "abc\tdef" !~~ /c \T d/, 'not horizontal tab (\T)';

#### c \T+ d			abc\t\tdef	n	not horizontal tab (\T)
ok "abc\t\tdef" !~~ /c \T+ d/, 'not horizontal tab (\T)';

#### a \T+ f			abcdef		y	not horizontal tab (\T)
#?pugs todo 
ok "abcdef" ~~ /a \T+ f/, 'not horizontal tab (\T)';

#### c \r d			abc\rdef	y	return (\r)
#?pugs todo 
ok "abc\rdef" ~~ /c \r d/, 'return (\r)';

#### c \r+ d			abc\r\rdef	y	return (\r)
#?pugs todo 
ok "abc\r\rdef" ~~ /c \r+ d/, 'return (\r)';

#### a \r+ f			abcdef		n	return (\r)
ok 'abcdef' !~~ /a \r+ f/, 'return (\r)';

#### b \r c			abc\rdef	n	return (\r)
ok "abc\rdef" !~~ /b \r c/, 'return (\r)';

#### \R			a		y	not return (\R)
#?pugs todo 
ok 'a' ~~ /\R/, 'not return (\R)';

#### a \R c			abc		y	not return (\R)
#?pugs todo 
ok 'abc' ~~ /a \R c/, 'not return (\R)';

#### \R			''		n	not return (\R)
ok '' !~~ /\R/, 'not return (\R)';

#### c \R d			abc\rdef	n	not return (\R)
ok "abc\rdef" !~~ /c \R d/, 'not return (\R)';

#### c \R+ d			abc\r\rdef	n	not return (\R)
ok "abc\r\rdef" !~~ /c \R+ d/, 'not return (\R)';

#### a \R+ f			abcdef		y	not return (\R)
#?pugs todo 
ok 'abcdef' ~~ /a \R+ f/, 'not return (\R)';

#### c \f d			abc\fdef	y	formfeed (\f)
#?pugs todo 
ok "abc\fdef" ~~ /c \f d/, 'formfeed (\f)';

#### c \f+ d			abc\f\fdef	y	formfeed (\f)
#?pugs todo 
ok "abc\f\fdef" ~~ /c \f+ d/, 'formfeed (\f)';

#### a \f+ f			abcdef		n	formfeed (\f)
ok 'abcdef' !~~ /a \f+ f/, 'formfeed (\f)';

#### b \f c			abc\fdef	n	formfeed (\f)
ok "abc\fdef" !~~ /b \f c/, 'formfeed (\f)';

#### \F			a		y	not formfeed (\F)
#?pugs todo 
ok 'a' ~~ /\F/, 'not formfeed (\F)';

#### a \F c			abc		y	not formfeed (\F)
#?pugs todo 
ok 'abc' ~~ /a \F c/, 'not formfeed (\F)';

#### \F			''		n	not formfeed (\F)
ok '' !~~ /\F/, 'not formfeed (\F)';

#### c \F d			abc\fdef	n	not formfeed (\F)
ok "abc\fdef" !~~ /c \F d/, 'not formfeed (\F)';

#### c \F+ d			abc\f\fdef	n	not formfeed (\F)
ok "abc\f\fdef" !~~ /c \F+ d/, 'not formfeed (\F)';

#### a \F+ f			abcdef		y	not formfeed (\F)
#?pugs todo 
ok 'abcdef' ~~ /a \F+ f/, 'not formfeed (\F)';

#### c \e d			abc\edef	y	escape (\e)
#?pugs todo 
ok "abc\edef" ~~ /c \e d/, 'escape (\e)';

#### c \e+ d			abc\e\edef	y	escape (\e)
#?pugs todo 
ok "abc\e\edef" ~~ /c \e+ d/, 'escape (\e)';

#### a \e+ f			abcdef		n	escape (\e)
ok 'abcdef' !~~ /a \e+ f/, 'escape (\e)';

#### b \e c			abc\edef	n	escape (\e)
ok "abc\edef" !~~ /b \e c/, 'escape (\e)';

#### \E			a		y	not escape (\E)
#?pugs todo 
ok 'a' ~~ /\E/, 'not escape (\E)';

#### a \E c			abc		y	not escape (\E)
#?pugs todo 
ok 'abc' ~~ /a \E c/, 'not escape (\E)';

#### \E			''		n	not escape (\E)
ok '' !~~ /\E/, 'not escape (\E)';

#### c \E d			abc\edef	n	not escape (\E)
ok "abc\edef" !~~ /c \E d/, 'not escape (\E)';

#### c \E+ d			abc\e\edef	n	not escape (\E)
ok "abc\e\edef" !~~ /c \E+ d/, 'not escape (\E)';

#### a \E+ f			abcdef		y	not escape (\E)
#?pugs todo 
ok 'abcdef' ~~ /a \E+ f/, 'not escape (\E)';

#### c \x0021 d		abc!def	y	hex (\x)
#?pugs todo 
ok 'abc!def' ~~ /c \x0021 d/, 'hex (\x)';

#### c \x0021+ d		abc!!def	y	hex (\x)
#?pugs todo 
ok 'abc!!def' ~~ /c \x0021+ d/, 'hex (\x)';

#### a \x0021+ f		abcdef		n	hex (\x)
ok 'abcdef' !~~ /a \x0021+ f/, 'hex (\x)';

#### b \x0021 c		abc!def		n	hex (\x)
ok 'abc!def' !~~ /b \x0021 c/, 'hex (\x)';

#### c \x[0021] d		abc!def		y	hex (\x[])
#?pugs todo 
ok 'abc!def' ~~ /c \x[0021] d/, 'hex (\x[])';

#### c \x[0021]+ d		abc!!def	y	hex (\x[])
#?pugs todo 
ok 'abc!!def' ~~ /c \x[0021]+ d/, 'hex (\x[])';

#### c \x[21,21] d		abc!!def	y	hex (\x[])
#?pugs todo 
ok 'abc!!def' ~~ /c \x[21,21] d/, 'hex (\x[])';

#### a \x[0021]+ f		abcdef		n	hex (\x[])
ok 'abcdef' !~~ /a \x[0021]+ f/, 'hex (\x[])';

#### b \x[0021] c		abc!def		n	hex (\x[])
ok 'abc!def' !~~ /b \x[0021] c/, 'hex (\x[])';

#### \X0021			a		y	not hex (\X)
#?pugs todo 
ok 'a' ~~ /\X0021/, 'not hex (\X)';

#### a \X0021 c		abc		y	not hex (\X)
#?pugs todo 
ok 'abc' ~~ /a \X0021 c/, 'not hex (\X)';

#### \X0021			''		n	not hex (\X)
ok '' !~~ /\X0021/, 'not hex (\X)';

#### c \X0021 d		abc!def		n	not hex (\X)
ok 'abc!def' !~~ /c \X0021 d/, 'not hex (\X)';

#### c \X0021+ d		abc!!def	n	not hex (\X)
ok 'abc!!def' !~~ /c \X0021+ d/, 'not hex (\X)';

#### a \X0021+ f		abcdef		y	not hex (\X)
#?pugs todo 
ok 'abcdef' ~~ /a \X0021+ f/, 'not hex (\X)';

#### \X[0021]		a		y	not hex (\X[])
#?pugs todo 
ok 'a' ~~ /\X[0021]/, 'not hex (\X[])';

#### a \X[0021] c		abc		y	not hex (\X[])
#?pugs todo 
ok 'abc' ~~ /a \X[0021] c/, 'not hex (\X[])';

#### \X[0021]		''		n	not hex (\X[])
ok '' !~~ /\X[0021]/, 'not hex (\X[])';

#### c \X[0021] d		abc!def		n	not hex (\X[])
ok 'abc!def' !~~ /c \X[0021] d/, 'not hex (\X[])';

#### c \X[0021]+ d		abc!!def	n	not hex (\X[])
ok 'abc!!def' !~~ /c \X[0021]+ d/, 'not hex (\X[])';

#### a \X[0021]+ f		abcdef		y	not hex (\X[])
#?pugs todo 
ok 'abcdef' ~~ /a \X[0021]+ f/, 'not hex (\X[])';

#### c \o041 d		abc!def		y	octal (\o)
#?pugs todo 
ok 'abc!def' ~~ /c \o041 d/, 'octal (\o)';

#### c \o41+ d		abc!!def	y	octal (\o)
#?pugs todo 
ok 'abc!!def' ~~ /c \o41+ d/, 'octal (\o)';

#### a \o41+ f		abcdef		n	octal (\o)
ok 'abcdef' !~~ /a \o41+ f/, 'octal (\o)';

#### b \o41 c		abc!def		n	octal (\o)
ok 'abc!def' !~~ /b \o41 c/, 'octal (\o)';

#### c \o[41] d		abc!def		y	octal (\o[])
#?pugs todo 
ok 'abc!def' ~~ /c \o[41] d/, 'octal (\o[])';

#### c \o[41]+ d		abc!!def	y	octal (\o[])
#?pugs todo 
ok 'abc!!def' ~~ /c \o[41]+ d/, 'octal (\o[])';

#### c \o[41,41] d		abc!!def	y	octal (\o[])
#?pugs todo 
ok 'abc!!def' ~~ /c \o[41,41] d/, 'octal (\o[])';

#### a \o[41]+ f		abcdef		n	octal (\o[])
ok 'abcdef' !~~ /a \o[41]+ f/, 'octal (\o[])';

#### b \o[41] c		abc!def		n	octal (\o[])
ok 'abc!def' !~~ /b \o[41] c/, 'octal (\o[])';

#### \O41			a		y	not octal (\O)
#?pugs todo 
ok 'a' ~~ /\O41/, 'not octal (\O)';

#### a \O41 c		abc		y	not octal (\O)
#?pugs todo 
ok 'abc' ~~ /a \O41 c/, 'not octal (\O)';

#### \O41			''		n	not octal (\O)
ok '' !~~ /\O41/, 'not octal (\O)';

#### c \O41 d		abc!def		n	not octal (\O)
ok 'abc!def' !~~ /c \O41 d/, 'not octal (\O)';

#### c \O41+ d		abc!!def	n	not octal (\O)
ok 'abc!!def' !~~ /c \O41+ d/, 'not octal (\O)';

#### a \O41+ f		abcdef		y	not octal (\O)
#?pugs todo 
ok 'abcdef' ~~ /a \O41+ f/, 'not octal (\O)';

#### \O[41]			a		y	not octal (\O[])
#?pugs todo 
ok 'a' ~~ /\O[41]/, 'not octal (\O[])';

#### a \O[41] c		abc		y	not octal (\O[])
#?pugs todo 
ok 'abc' ~~ /a \O[41] c/, 'not octal (\O[])';

#### \O[41]			''		n	not octal (\O[])
ok '' !~~ /\O[41]/, 'not octal (\O[])';

#### c \O[41] d		abc!def		n	not octal (\O[])
ok 'abc!def' !~~ /c \O[41] d/, 'not octal (\O[])';

#### c \O[41]+ d		abc!!def	n	not octal (\O[])
ok 'abc!!def' !~~ /c \O[41]+ d/, 'not octal (\O[])';

#### a \O[41]+ f		abcdef		y	not octal (\O[])
#?pugs todo 
ok 'abcdef' ~~ /a \O[41]+ f/, 'not octal (\O[])';

#### a\w+f			a=[ *f		n	word character
ok 'a=[ *f' !~~ /a\w+f/, 'word character';

#### a\w+f			abcdef		y	word character
#?pugs todo 
ok 'abcdef' ~~ /a\w+f/, 'word character';

#### a\W+f			a&%- f		y	not word character
#?pugs todo 
ok 'a&%- f' ~~ /a\W+f/, 'not word character';

#### a\W+f			abcdef		n	not word character
ok 'abcdef' !~~ /a\W+f/, 'not word character';

#### a\d+f			abcdef		n	digit
ok 'abcdef' !~~ /a\d+f/, 'digit';

#### ab\d+cdef		ab42cdef	y	digit
#?pugs todo 
ok 'ab42cdef' ~~ /ab\d+cdef/, 'digit';

#### a\D+f			abcdef		y	not digit
#?pugs todo 
ok 'abcdef' ~~ /a\D+f/, 'not digit';

#### a\D+f			ab0cdef		n	not digit
ok 'ab0cdef' !~~ /a\D+f/, 'not digit';


##  modifiers
#### :i bcd			abcdef	y	ignorecase (:i)
#?pugs todo 
ok 'abcdef' ~~ /:i bcd/, 'ignorecase (:i)';

#### :i bcd			aBcdef	y	ignorecase (:i)
#?pugs todo 
ok 'aBcdef' ~~ /:i bcd/, 'ignorecase (:i)';

#### :i bcd			abCdef	y	ignorecase (:i)
#?pugs todo 
ok 'abCdef' ~~ /:i bcd/, 'ignorecase (:i)';

#### :i bcd			abcDef	y	ignorecase (:i)
#?pugs todo 
ok 'abcDef' ~~ /:i bcd/, 'ignorecase (:i)';

#### :i bcd			abc-ef	n	ignorecase (:i)
ok 'abc-ef' !~~ /:i bcd/, 'ignorecase (:i)';

#### :ignorecase bcd		abcdef	y	ignorecase (:ignorecase)
#?pugs todo 
ok 'abcdef' ~~ /:ignorecase bcd/, 'ignorecase (:ignorecase)';

#### :ignorecase bcd		aBCDef	y	ignorecase (:ignorecase)
#?pugs todo 
ok 'aBCDef' ~~ /:ignorecase bcd/, 'ignorecase (:ignorecase)';

#### :ignorecase bcd		abc-ef	n	ignorecase (:ignorecase)
ok 'abc-ef' !~~ /:ignorecase bcd/, 'ignorecase (:ignorecase)';

#### :i(0) bcd		abcdef	y	ignorecase, repetition (:i(0))
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'abcdef' ~~ /:i(0) bcd/, 'ignorecase, repetition (:i(0))';

#### :i(0) bcd		abCdef	n	ignorecase, repetition (:i(0))
#?niecza skip "Action method mod_arg not yet implemented"
ok 'abCdef' !~~ /:i(0) bcd/, 'ignorecase, repetition (:i(0))';

#### :i(1) bcd		abcdef	y	ignorecase, repetition (:i(1))
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'abcdef' ~~ /:i(1) bcd/, 'ignorecase, repetition (:i(1))';

#### :i(1) bcd		abCdef	y	ignorecase, repetition (:i(1))
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'abCdef' ~~ /:i(1) bcd/, 'ignorecase, repetition (:i(1))';

#### :i(1) bcd		aBxDef	n	ignorecase, repetition (:i(1))
#?niecza skip "Action method mod_arg not yet implemented"
ok 'aBxDef' !~~ /:i(1) bcd/, 'ignorecase, repetition (:i(1))';

#### :0i bcd			abcdef	y	ignorecase, repetition (:0i)
#?pugs todo 
ok 'abcdef' ~~ /:0i bcd/, 'ignorecase, repetition (:0i)';

#### :0i bcd			abCdef	n	ignorecase, repetition (:0i)
#?niecza todo ""
ok 'abCdef' !~~ /:0i bcd/, 'ignorecase, repetition (:0i)';

#### :1i bcd			abcdef	y	ignorecase, repetition (:1i)
#?pugs todo 
ok 'abcdef' ~~ /:1i bcd/, 'ignorecase, repetition (:1i)';

#### :1i bcd			abCdef	y	ignorecase, repetition (:1i)
#?pugs todo 
ok 'abCdef' ~~ /:1i bcd/, 'ignorecase, repetition (:1i)';

#### :1i bcd			aBCDef	y	ignorecase, repetition (:1i)
#?pugs todo 
ok 'aBCDef' ~~ /:1i bcd/, 'ignorecase, repetition (:1i)';

#### :1i bcd			aBxDef	n	ignorecase, repetition (:1i)
ok 'aBxDef' !~~ /:1i bcd/, 'ignorecase, repetition (:1i)';

#### ab [:i cd ] ef		abcdef	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'abcdef' ~~ /ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### ab [:i cd ] ef		abCdef	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'abCdef' ~~ /ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### ab [:i cd ] ef		abcDef	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'abcDef' ~~ /ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### ab [:i cd ] ef		abCDef	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'abCDef' ~~ /ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### ab [:i cd ] ef		aBCDef	n	ignorecase, lexical (:i)
ok 'aBCDef' !~~ /ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### ab [:i cd ] ef		abCDEf	n	ignorecase, lexical (:i)
ok 'abCDEf' !~~ /ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### :i ab [:i cd ] ef	abCDef	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'abCDef' ~~ /:i ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### :i ab [:i cd ] ef	AbCDeF	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'AbCDeF' ~~ /:i ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### :i ab [:i cd ] ef	AbcdeF	y	ignorecase, lexical (:i)
#?pugs todo 
ok 'AbcdeF' ~~ /:i ab [:i cd ] ef/, 'ignorecase, lexical (:i)';

#### :i a [:i(0) b [:i(1) c [:0i d [:1i e [:i(0) f ] ] ] ] ]		AbCdEf		y	ignorecase, lexical (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'AbCdEf' ~~ /:i a [:i(0) b [:i(1) c [:0i d [:1i e [:i(0) f ] ] ] ] ]/, 'ignorecase, lexical (:i)';

#### :i aa [:i(0) bb [:i(1) cc [:0i dd [:1i ee [:i(0) ff ] ] ] ] ]	AabbCcddEeff	y	ignorecase, lexical (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'AabbCcddEeff' ~~ /:i aa [:i(0) bb [:i(1) cc [:0i dd [:1i ee [:i(0) ff ] ] ] ] ]/, 'ignorecase, lexical (:i)';

#### :i a [:i(0) b [:i(1) c [:0i d [:1i e [:i(0) f ] ] ] ] ]		AbCdEF		n	ignorecase, lexical (:i)
#?niecza skip "Action method mod_arg not yet implemented"
ok 'AbCdEF' !~~ /:i a [:i(0) b [:i(1) c [:0i d [:1i e [:i(0) f ] ] ] ] ]/, 'ignorecase, lexical (:i)';

#### :i aa [:i(0) bb [:i(1) cc [:0i dd [:1i ee [:i(0) ff ] ] ] ] ]	AabbCcddEeFf	n	ignorecase, lexical (:i)
#?niecza skip "Action method mod_arg not yet implemented"
ok 'AabbCcddEeFf' !~~ /:i aa [:i(0) bb [:i(1) cc [:0i dd [:1i ee [:i(0) ff ] ] ] ] ]/, 'ignorecase, lexical (:i)';

#### :i ab [:i(0) cd ] ef	AbcdeF	y	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'AbcdeF' ~~ /:i ab [:i(0) cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :i ab [:!i cd ] ef	AbcdeF	y	ignorecase, lexical repetition (:i)
#?pugs todo 
ok 'AbcdeF' ~~ /:i ab [:!i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :i ab [:0i cd ] ef	AbcdeF	y	ignorecase, lexical repetition (:i)
#?pugs todo 
ok 'AbcdeF' ~~ /:i ab [:0i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :0i ab [:1i cd ] ef	abCDef	y	ignorecase, lexical repetition (:i)
#?pugs todo 
ok 'abCDef' ~~ /:0i ab [:1i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :0i ab [:1i cd ] ef	AbCDeF	n	ignorecase, lexical repetition (:i)
#?niecza todo ""
ok 'AbCDeF' !~~ /:0i ab [:1i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :0i ab [:1i cd ] ef	AbcdeF	n	ignorecase, lexical repetition (:i)
#?niecza todo ""
ok 'AbcdeF' !~~ /:0i ab [:1i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :0i ab [:i(0) cd ] ef	abcdef	y	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'abcdef' ~~ /:0i ab [:i(0) cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :0i ab [:1i cd ] ef	AbcdeF	n	ignorecase, lexical repetition (:i)
#?niecza todo ""
ok 'AbcdeF' !~~ /:0i ab [:1i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :i(1) ab [:1i cd ] ef	AbCdeF	y	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'AbCdeF' ~~ /:i(1) ab [:1i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :i(1) ab [:i(0) cd ] ef	AbcdeF	y	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'AbcdeF' ~~ /:i(1) ab [:i(0) cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :i(1) ab [:i(0) cd ] ef	AbcDeF	n	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
ok 'AbcDeF' !~~ /:i(1) ab [:i(0) cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :i(2) ab [:i(999) cd ] ef	ABCDEF	y	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'ABCDEF' ~~ /:i(2) ab [:i(999) cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :1i ab [:i(1) cd ] ef		ABCDEF	y	ignorecase, lexical repetition (:i)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'ABCDEF' ~~ /:1i ab [:i(1) cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :0i ab [:1i cd ] ef		abcDeF	n	ignorecase, lexical repetition (:i)
#?niecza todo ""
ok 'abcDeF' !~~ /:0i ab [:1i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### :2i ab [:999i cd ] ef		ABCDEF	y	ignorecase, lexical repetition (:i)
#?pugs todo 
ok 'ABCDEF' ~~ /:2i ab [:999i cd ] ef/, 'ignorecase, lexical repetition (:i)';

#### ab [:ignorecase cd ] ef		abCDef	y	ignorecase, lexical (:ignorecase)
#?pugs todo 
ok 'abCDef' ~~ /ab [:ignorecase cd ] ef/, 'ignorecase, lexical (:ignorecase)';

#### ab [:ignorecase cd ] ef		aBCDef	n	ignorecase, lexical (:ignorecase)
ok 'aBCDef' !~~ /ab [:ignorecase cd ] ef/, 'ignorecase, lexical (:ignorecase)';

#### :1ignorecase ab [:ignorecase(1) cd ] ef	ABCDEF	y	ignorecase, lexical repetition (:ignorecase)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'ABCDEF' ~~ /:1ignorecase ab [:ignorecase(1) cd ] ef/, 'ignorecase, lexical repetition (:ignorecase)';

#### :s bcd			a bcdef		y	sigspace (:s)
#?pugs todo 
ok 'a bcdef' ~~ /:s bcd/, 'sigspace (:s)';

#### :s bcd			a bcd ef	y	sigspace (:s)
#?pugs todo 
ok 'a bcd ef' ~~ /:s bcd/, 'sigspace (:s)';

#### :s bcd			abcdef		y	sigspace (:s)
ok 'abcdef' ~~ /:s bcd/, 'sigspace (:s)';

#### :s bcd			abcd ef		y	sigspace (:s)
ok 'abcd ef' ~~ /:s bcd/, 'sigspace (:s)';

#### :s bcd			ab cdef		n	sigspace (:s)
ok 'ab cdef' !~~ /:s bcd/, 'sigspace (:s)';

#### :s b c d		a b c d ef	y	sigspace (:s)
#?pugs todo 
ok 'a b c d ef' ~~ /:s b c d/, 'sigspace (:s)';

#### :s b c d		a b c def	y	sigspace (:s)
#?pugs todo 
ok 'a b c def' ~~ /:s b c d/, 'sigspace (:s)';

#### :s b c d		ab c d ef	y	sigspace (:s)
ok 'ab c d ef' ~~ /:s b c d/, 'sigspace (:s)';

#### :s b c d		a bcdef		n	sigspace (:s)
ok 'a bcdef' !~~ /:s b c d/, 'sigspace (:s)';

#### :s b c d		abcdef		n	sigspace (:s)
ok 'abcdef' !~~ /:s b c d/, 'sigspace (:s)';

#### :sigspace bcd		a bcdef		y	sigspace (:sigspace)
#?pugs todo 
ok 'a bcdef' ~~ /:sigspace bcd/, 'sigspace (:sigspace)';

#### :sigspace bcd		a bcd ef	y	sigspace (:sigspace)
#?pugs todo 
ok 'a bcd ef' ~~ /:sigspace bcd/, 'sigspace (:sigspace)';

#### :sigspace bcd		abcdef		y	sigspace (:sigspace)
ok 'abcdef' ~~ /:sigspace bcd/, 'sigspace (:sigspace)';

#### :sigspace b c d		a b c d ef	y	sigspace (:sigspace)
#?pugs todo 
ok 'a b c d ef' ~~ /:sigspace b c d/, 'sigspace (:sigspace)';

#### :sigspace b c d		a b c def	y	sigspace (:sigspace)
#?pugs todo 
ok 'a b c def' ~~ /:sigspace b c d/, 'sigspace (:sigspace)';

#### :sigspace b c d		ab c d ef	y	sigspace (:sigspace)
ok 'ab c d ef' ~~ /:sigspace b c d/, 'sigspace (:sigspace)';

#### :s(1) b c [:s(0) d e f ]	a b c def	y	sigspace, lexical repetition (:s)
#?niecza skip "Action method mod_arg not yet implemented"
#?pugs todo 
ok 'a b c def' ~~ /:s(1) b c [:s(0) d e f ]/, 'sigspace, lexical repetition (:s)';

#### :s b c [:!s d e f ]	a b c def	y	sigspace, lexical repetition (:s)
#?pugs todo 
ok 'a b c def' ~~ /:s b c [:!s d e f ]/, 'sigspace, lexical repetition (:s)';

#### :s(0) b c [:s(1) d e f ]	a b c def	n	sigspace, lexical repetition (:s)
#?niecza skip "Action method mod_arg not yet implemented"
ok 'a b c def' !~~ /:s(0) b c [:s(1) d e f ]/, 'sigspace, lexical repetition (:s)';

# todo :pge
#### :!s b c [:s d e f ]	a b c def	n	sigspace, lexical repetition (:s)
ok 'a b c def' !~~ /:!s b c [:s d e f ]/, 'sigspace, lexical repetition (:s)';

#### :s(0) b c [:s(0) d e f ]	a b c def	n	sigspace, lexical repetition (:s)
#?niecza skip "Action method mod_arg not yet implemented"
ok 'a b c def' !~~ /:s(0) b c [:s(0) d e f ]/, 'sigspace, lexical repetition (:s)';

# todo :pge
#### :!s b c [:!s d e f ]	a b c def	n	sigspace, lexical repetition (:s)
ok 'a b c def' !~~ /:!s b c [:!s d e f ]/, 'sigspace, lexical repetition (:s)';

#### :s ab 				ab		y	sigspace, trailing ws
#?pugs todo 
ok 'ab' ~~ /:s ab /, 'sigspace, trailing ws';

#### foo\s*'-'?\s*bar		foo\t \n-\n\t bar	y	basic match
#?pugs todo 
ok "foo\t \n-\n\t bar" ~~ /foo\s*'-'?\s*bar/, 'basic match';

#### foo\s*'-'?\s*bar		foo - bar	y	basic match
#?pugs todo 
ok 'foo - bar' ~~ /foo\s*'-'?\s*bar/, 'basic match';

#### foo\s+'-'?\s*bar		foo   bar	y	basic match \s+ \s*
#?pugs todo 
ok 'foo   bar' ~~ /foo\s+'-'?\s*bar/, 'basic match \s+ \s*';

#### foo\s+'-'?\s*bar		foo  -bar	y	basic match \s+ \s*
#?pugs todo 
ok 'foo  -bar' ~~ /foo\s+'-'?\s*bar/, 'basic match \s+ \s*';

#### foo\s*'-'?\s+bar		foo-  bar	y	basic match \s* \s+
#?pugs todo 
ok 'foo-  bar' ~~ /foo\s*'-'?\s+bar/, 'basic match \s* \s+';

#### foo '-'? bar			foo-bar		y	basic match \s* \s*
#?pugs todo 
ok 'foo-bar' ~~ /foo '-'? bar/, 'basic match \s* \s*';

#### foo '-'? bar			foobar		y	basic match
#?pugs todo 
ok 'foobar' ~~ /foo '-'? bar/, 'basic match';

#### foo '-'? bar			foo - bar	n	basic non-match
ok 'foo - bar' !~~ /foo '-'? bar/, 'basic non-match';

#### :s foo '-'? bar			foo\n \t- \t\t\nbar	y	basic ws match
#?pugs todo 
ok "foo\n \t- \t\t\nbar" ~~ /:s foo '-'? bar/, 'basic ws match';

#### :s foo '-'? bar			foo - bar	y	basic ws match
#?pugs todo 
ok 'foo - bar' ~~ /:s foo '-'? bar/, 'basic ws match';

#### :s foo '-'? bar			foo   bar	y	basic ws match \s+ \s*
#?pugs todo 
ok 'foo   bar' ~~ /:s foo '-'? bar/, 'basic ws match \s+ \s*';

#### :s foo '-'? bar			foo  -bar	y	basic ws match \s+ \s*
#?pugs todo 
ok 'foo  -bar' ~~ /:s foo '-'? bar/, 'basic ws match \s+ \s*';

#### :s foo '-'? bar			foo-  bar	y	basic ws match \s* \s+
#?pugs todo 
ok 'foo-  bar' ~~ /:s foo '-'? bar/, 'basic ws match \s* \s+';

#### :s foo '-'? bar			foo-bar		y	basic ws match \s* \s*
#?pugs todo 
ok 'foo-bar' ~~ /:s foo '-'? bar/, 'basic ws match \s* \s*';

#### :s foo '-'? bar			foobar		n	basic ws non-match
ok 'foobar' !~~ /:s foo '-'? bar/, 'basic ws non-match';

#### :s()foo '-'? bar		foo - bar	n	basic ws match
#?rakudo skip ':s()'
#?niecza skip "Action method mod_arg not yet implemented"
ok 'foo - bar' !~~ /:s()foo '-'? bar/, 'basic ws match';

#### :s[]foo '-'? bar		foo - bar	y	basic ws match
#?pugs todo 
ok 'foo - bar' ~~ /:s foo '-'? bar/, 'basic ws match';

#### :sfoo '-'? bar		foo - bar	y	basic ws match with boundary modifier separation
#?niecza skip "Unable to resolve method wb in class Cursor"
#?pugs todo 
ok 'foo - bar' ~~ /:sfoo '-'? bar/, 'basic ws match with boundary modifier separation';

#### :s::foo '-'? bar			foo - bar	y	basic ws match with backtrack no-op modifier separation
#?rakudo skip ':: NYI'
#?pugs todo 
ok 'foo - bar' ~~ /:s::foo '-'? bar/, 'basic ws match with backtrack no-op modifier separation';

#### :s::(\w+) ':=' (\S+)		dog := spot	/mob 0: /	sigspace and capture together
#?rakudo skip ':: NYI'
#?pugs todo 
ok ('dog := spot' ~~ /:s::(\w+) ':=' (\S+)/) && matchcheck($/, q/mob 0: /), 'sigspace and capture together';

#### :s::(\w+) ':=' (\S+)		dog := spot	/mob 1: /	sigspace and capture together
#?rakudo skip ':: NYI'
#?pugs todo 
ok ('dog := spot' ~~ /:s::(\w+) ':=' (\S+)/) && matchcheck($/, q/mob 1: /), 'sigspace and capture together';

#### :perl5 \A.*? bcd\Q$\E..\z	a bcd$ef	y	perl5 syntax (:perl5)
#?rakudo skip 'parse error'
#?niecza skip 'Autoloading NYI'
ok 'a bcd$ef' ~~ m:Perl5/\A.*? bcd\Q$\E..\z/, 'perl5 syntax (:Perl5)';

#### :s^[\d+ ]* abc			11 12 13 abc	y	 before closing bracket
#?pugs todo 
ok '11 12 13 abc' ~~ /:s^[\d+ ]* abc/, ' before closing bracket';


##  Quantifiers

#### xa*			xaaaay		//	star 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*/) && matchcheck($/, q//), 'star 2+';

#### xa*			xay		//	star 1
#?pugs todo 
ok ('xay' ~~ /xa*/) && matchcheck($/, q//), 'star 1';

#### xa*			xy		//	star 0
#?pugs todo 
ok ('xy' ~~ /xa*/) && matchcheck($/, q//), 'star 0';

#### xa*y			xaaaay		//	star 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*y/) && matchcheck($/, q//), 'star 2+';

#### xa*y			xay		//	star 1
#?pugs todo 
ok ('xay' ~~ /xa*y/) && matchcheck($/, q//), 'star 1';

#### xa*y			xy		//	star 0
#?pugs todo 
ok ('xy' ~~ /xa*y/) && matchcheck($/, q//), 'star 0';


#### xa+			xaaaay		//	plus 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+/) && matchcheck($/, q//), 'plus 2+';

#### xa+			xay		//	plus 1
#?pugs todo 
ok ('xay' ~~ /xa+/) && matchcheck($/, q//), 'plus 1';

#### xa+			xy		n		plus 0
ok 'xy' !~~ /xa+/, 'plus 0';

#### xa+y			xaaaay		//	plus 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+y/) && matchcheck($/, q//), 'plus 2+';

#### xa+y			xay		//	plus 1
#?pugs todo 
ok ('xay' ~~ /xa+y/) && matchcheck($/, q//), 'plus 1';

#### xa+y			xy		n		plus 0
ok 'xy' !~~ /xa+y/, 'plus 0';


#### xa?			xaaaay		//	ques 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa?/) && matchcheck($/, q//), 'ques 2+';

#### xa?			xay		//	ques 1
#?pugs todo 
ok ('xay' ~~ /xa?/) && matchcheck($/, q//), 'ques 1';

#### xa?			xy		//	ques 0
#?pugs todo 
ok ('xy' ~~ /xa?/) && matchcheck($/, q//), 'ques 0';

#### xa?y			xaaaay		n		ques 2+
ok 'xaaaay' !~~ /xa?y/, 'ques 2+';

#### xa?y			xay		//	ques 1
#?pugs todo 
ok ('xay' ~~ /xa?y/) && matchcheck($/, q//), 'ques 1';

#### xa?y			xy		//	ques 0
#?pugs todo 
ok ('xy' ~~ /xa?y/) && matchcheck($/, q//), 'ques 0';


#### xa*!			xaaaay		//	star greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*!/) && matchcheck($/, q//), 'star greedy 2+';

#### xa*!			xay		//	star greedy 1
#?pugs todo 
ok ('xay' ~~ /xa*!/) && matchcheck($/, q//), 'star greedy 1';

#### xa*!			xy		//	star greedy 0
#?pugs todo 
ok ('xy' ~~ /xa*!/) && matchcheck($/, q//), 'star greedy 0';

#### xa*!y			xaaaay		//	star greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*!y/) && matchcheck($/, q//), 'star greedy 2+';

#### xa*!y			xay		//	star greedy 1
#?pugs todo 
ok ('xay' ~~ /xa*!y/) && matchcheck($/, q//), 'star greedy 1';

#### xa*!y			xy		//	star greedy 0
#?pugs todo 
ok ('xy' ~~ /xa*!y/) && matchcheck($/, q//), 'star greedy 0';


#### xa+!			xaaaay		//	plus greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+!/) && matchcheck($/, q//), 'plus greedy 2+';

#### xa+!			xay		//	plus greedy 1
#?pugs todo 
ok ('xay' ~~ /xa+!/) && matchcheck($/, q//), 'plus greedy 1';

#### xa+!			xy		n		plus greedy 0
ok 'xy' !~~ /xa+!/, 'plus greedy 0';

#### xa+!y			xaaaay		//	plus greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+!y/) && matchcheck($/, q//), 'plus greedy 2+';

#### xa+!y			xay		//	plus greedy 1
#?pugs todo 
ok ('xay' ~~ /xa+!y/) && matchcheck($/, q//), 'plus greedy 1';

#### xa+!y			xy		n		plus greedy 0
ok 'xy' !~~ /xa+!y/, 'plus greedy 0';


#### xa?!			xaaaay		//	ques greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa?!/) && matchcheck($/, q//), 'ques greedy 2+';

#### xa?!			xay		//	ques greedy 1
#?pugs todo 
ok ('xay' ~~ /xa?!/) && matchcheck($/, q//), 'ques greedy 1';

#### xa?!			xy		//	ques greedy 0
#?pugs todo 
ok ('xy' ~~ /xa?!/) && matchcheck($/, q//), 'ques greedy 0';

#### xa?!y			xaaaay		n		ques greedy 2+
ok 'xaaaay' !~~ /xa?!y/, 'ques greedy 2+';

#### xa?!y			xay		//	ques greedy 1
#?pugs todo 
ok ('xay' ~~ /xa?!y/) && matchcheck($/, q//), 'ques greedy 1';

#### xa?!y			xy		//	ques greedy 0
#?pugs todo 
ok ('xy' ~~ /xa?!y/) && matchcheck($/, q//), 'ques greedy 0';


#### xa*:!			xaaaay		//	star :greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*:!/) && matchcheck($/, q//), 'star :greedy 2+';

#### xa*:!			xay		//	star :greedy 1
#?pugs todo 
ok ('xay' ~~ /xa*:!/) && matchcheck($/, q//), 'star :greedy 1';

#### xa*:!			xy		//	star :greedy 0
#?pugs todo 
ok ('xy' ~~ /xa*:!/) && matchcheck($/, q//), 'star :greedy 0';

#### xa*:!y			xaaaay		//	star :greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*:!y/) && matchcheck($/, q//), 'star :greedy 2+';

#### xa*:!y			xay		//	star :greedy 1
#?pugs todo 
ok ('xay' ~~ /xa*:!y/) && matchcheck($/, q//), 'star :greedy 1';

#### xa*:!y			xy		//	star :greedy 0
#?pugs todo 
ok ('xy' ~~ /xa*:!y/) && matchcheck($/, q//), 'star :greedy 0';


#### xa+:!			xaaaay		//	plus :greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+:!/) && matchcheck($/, q//), 'plus :greedy 2+';

#### xa+:!			xay		//	plus :greedy 1
#?pugs todo 
ok ('xay' ~~ /xa+:!/) && matchcheck($/, q//), 'plus :greedy 1';

#### xa+:!			xy		n		plus :greedy 0
ok 'xy' !~~ /xa+:!/, 'plus :greedy 0';

#### xa+:!y			xaaaay		//	plus :greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+:!y/) && matchcheck($/, q//), 'plus :greedy 2+';

#### xa+:!y			xay		//	plus :greedy 1
#?pugs todo 
ok ('xay' ~~ /xa+:!y/) && matchcheck($/, q//), 'plus :greedy 1';

#### xa+:!y			xy		n		plus :greedy 0
ok 'xy' !~~ /xa+:!y/, 'plus :greedy 0';


#### xa?:!			xaaaay		//	ques :greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa?:!/) && matchcheck($/, q//), 'ques :greedy 2+';

#### xa?:!			xay		//	ques :greedy 1
#?pugs todo 
ok ('xay' ~~ /xa?:!/) && matchcheck($/, q//), 'ques :greedy 1';

#### xa?:!			xy		//	ques :greedy 0
#?pugs todo 
ok ('xy' ~~ /xa?:!/) && matchcheck($/, q//), 'ques :greedy 0';

#### xa?:!y			xaaaay		n		ques :greedy 2+
ok 'xaaaay' !~~ /xa?:!y/, 'ques :greedy 2+';

#### xa?:!y			xay		//	ques :greedy 1
#?pugs todo 
ok ('xay' ~~ /xa?:!y/) && matchcheck($/, q//), 'ques :greedy 1';

#### xa?:!y			xy		//	ques :greedy 0
#?pugs todo 
ok ('xy' ~~ /xa?:!y/) && matchcheck($/, q//), 'ques :greedy 0';


#### xa*?			xaaaay		//	star eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*?/) && matchcheck($/, q//), 'star eager 2+';

#### xa*?			xay		//	star eager 1
#?pugs todo 
ok ('xay' ~~ /xa*?/) && matchcheck($/, q//), 'star eager 1';

#### xa*?			xy		//	star eager 0
#?pugs todo 
ok ('xy' ~~ /xa*?/) && matchcheck($/, q//), 'star eager 0';

#### xa*?y			xaaaay		//	star eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*?y/) && matchcheck($/, q//), 'star eager 2+';

#### xa*?y			xay		//	star eager 1
#?pugs todo 
ok ('xay' ~~ /xa*?y/) && matchcheck($/, q//), 'star eager 1';

#### xa*?y			xy		//	star eager 0
#?pugs todo 
ok ('xy' ~~ /xa*?y/) && matchcheck($/, q//), 'star eager 0';


#### xa+?			xaaaay		//	plus eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+?/) && matchcheck($/, q//), 'plus eager 2+';

#### xa+?			xay		//	plus eager 1
#?pugs todo 
ok ('xay' ~~ /xa+?/) && matchcheck($/, q//), 'plus eager 1';

#### xa+?			xy		n		plus eager 0
ok 'xy' !~~ /xa+?/, 'plus eager 0';

#### xa+?y			xaaaay		//	plus eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+?y/) && matchcheck($/, q//), 'plus eager 2+';

#### xa+?y			xay		//	plus eager 1
#?pugs todo 
ok ('xay' ~~ /xa+?y/) && matchcheck($/, q//), 'plus eager 1';

#### xa+?y			xy		n		plus eager 0
ok 'xy' !~~ /xa+?y/, 'plus eager 0';


#### xa??			xaaaay		//	ques eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa??/) && matchcheck($/, q//), 'ques eager 2+';

#### xa??			xay		//	ques eager 1
#?pugs todo 
ok ('xay' ~~ /xa??/) && matchcheck($/, q//), 'ques eager 1';

#### xa??			xy		//	ques eager 0
#?pugs todo 
ok ('xy' ~~ /xa??/) && matchcheck($/, q//), 'ques eager 0';

#### xa??y			xaaaay		n		ques eager 2+
ok 'xaaaay' !~~ /xa??y/, 'ques eager 2+';

#### xa??y			xay		//	ques eager 1
#?pugs todo 
ok ('xay' ~~ /xa??y/) && matchcheck($/, q//), 'ques eager 1';

#### xa??y			xy		//	ques eager 0
#?pugs todo 
ok ('xy' ~~ /xa??y/) && matchcheck($/, q//), 'ques eager 0';


#### xa*:?			xaaaay		//	star :eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*:?/) && matchcheck($/, q//), 'star :eager 2+';

#### xa*:?			xay		//	star :eager 1
#?pugs todo 
ok ('xay' ~~ /xa*:?/) && matchcheck($/, q//), 'star :eager 1';

#### xa*:?			xy		//	star :eager 0
#?pugs todo 
ok ('xy' ~~ /xa*:?/) && matchcheck($/, q//), 'star :eager 0';

#### xa*:?y			xaaaay		//	star :eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*:?y/) && matchcheck($/, q//), 'star :eager 2+';

#### xa*:?y			xay		//	star :eager 1
#?pugs todo 
ok ('xay' ~~ /xa*:?y/) && matchcheck($/, q//), 'star :eager 1';

#### xa*:?y			xy		//	star :eager 0
#?pugs todo 
ok ('xy' ~~ /xa*:?y/) && matchcheck($/, q//), 'star :eager 0';


#### xa+:?			xaaaay		//	plus :eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+:?/) && matchcheck($/, q//), 'plus :eager 2+';

#### xa+:?			xay		//	plus :eager 1
#?pugs todo 
ok ('xay' ~~ /xa+:?/) && matchcheck($/, q//), 'plus :eager 1';

#### xa+:?			xy		n		plus :eager 0
ok 'xy' !~~ /xa+:?/, 'plus :eager 0';

#### xa+:?y			xaaaay		//	plus :eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+:?y/) && matchcheck($/, q//), 'plus :eager 2+';

#### xa+:?y			xay		//	plus :eager 1
#?pugs todo 
ok ('xay' ~~ /xa+:?y/) && matchcheck($/, q//), 'plus :eager 1';

#### xa+:?y			xy		n		plus :eager 0
ok 'xy' !~~ /xa+:?y/, 'plus :eager 0';


#### xa?:?			xaaaay		//	ques :eager 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa?:?/) && matchcheck($/, q//), 'ques :eager 2+';

#### xa?:?			xay		//	ques :eager 1
#?pugs todo 
ok ('xay' ~~ /xa?:?/) && matchcheck($/, q//), 'ques :eager 1';

#### xa?:?			xy		//	ques :eager 0
#?pugs todo 
ok ('xy' ~~ /xa?:?/) && matchcheck($/, q//), 'ques :eager 0';

#### xa?:?y			xaaaay		n		ques :eager 2+
ok 'xaaaay' !~~ /xa?:?y/, 'ques :eager 2+';

#### xa?:?y			xay		//	ques :eager 1
#?pugs todo 
ok ('xay' ~~ /xa?:?y/) && matchcheck($/, q//), 'ques :eager 1';

#### xa?:?y			xy		//	ques :eager 0
#?pugs todo 
ok ('xy' ~~ /xa?:?y/) && matchcheck($/, q//), 'ques :eager 0';


#### xa*:y			xaaaay		//	star cut 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa*: y/) && matchcheck($/, q//), 'star cut 2+';

#### xa*:y			xay		//	star cut 1
#?pugs todo 
ok ('xay' ~~ /xa*: y/) && matchcheck($/, q//), 'star cut 1';

#### xa*:y			xy		//	star cut 0
#?pugs todo 
ok ('xy' ~~ /xa*: y/) && matchcheck($/, q//), 'star cut 0';

#### xa*:a			xaaaay		n		star cut 2+
ok 'xaaaay' !~~ /xa*: a/, 'star cut 2+';

#### xa*:a			xay		n		star cut 1
ok 'xay' !~~ /xa*: a/, 'star cut 1';


#### xa+:y			xaaaay		//	plus cut 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa+: y/) && matchcheck($/, q//), 'plus cut 2+';

#### xa+:y			xay		//	plus cut 1
#?pugs todo 
ok ('xay' ~~ /xa+: y/) && matchcheck($/, q//), 'plus cut 1';

#### xa+:y			xy		n		plus cut 0
ok 'xy' !~~ /xa+: y/, 'plus cut 0';

#### xa+:a			xaaaay		n		plus cut 2+
ok 'xaaaay' !~~ /xa+: a/, 'plus cut 2+';

#### xa+:a			xay		n		plus cut 1
ok 'xay' !~~ /xa+: a/, 'plus cut 1';


#### xa?:y			xaaaay		n		ques cut 2+
ok 'xaaaay' !~~ /xa?: y/, 'ques cut 2+';

#### xa?:y			xay		//	ques cut 1
#?pugs todo 
ok ('xay' ~~ /xa?: y/) && matchcheck($/, q//), 'ques cut 1';

#### xa?:y			xy		//	ques cut 0
#?pugs todo 
ok ('xy' ~~ /xa?: y/) && matchcheck($/, q//), 'ques cut 0';

#### xa?:a			xaaaay		//	ques cut 2+
#?pugs todo 
ok ('xaaaay' ~~ /xa?: a/) && matchcheck($/, q//), 'ques cut 2+';

#### xa?:a			xay		n		ques cut 1
ok 'xay' !~~ /xa?: a/, 'ques cut 1';


#### :ratchet xa*y			xaaaay		//	star ratchet 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa*y/) && matchcheck($/, q//), 'star ratchet 2+';

#### :ratchet xa*y			xay		//	star ratchet 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa*y/) && matchcheck($/, q//), 'star ratchet 1';

#### :ratchet xa*y			xy		//	star ratchet 0
#?pugs todo 
ok ('xy' ~~ /:ratchet xa*y/) && matchcheck($/, q//), 'star ratchet 0';

#### :ratchet xa*a			xaaaay		n		star ratchet 2+
ok 'xaaaay' !~~ /:ratchet xa*a/, 'star ratchet 2+';

#### :ratchet xa*a			xay		n		star ratchet 1
ok 'xay' !~~ /:ratchet xa*a/, 'star ratchet 1';


#### :ratchet xa+y			xaaaay		//	plus ratchet 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa+y/) && matchcheck($/, q//), 'plus ratchet 2+';

#### :ratchet xa+y			xay		//	plus ratchet 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa+y/) && matchcheck($/, q//), 'plus ratchet 1';

#### :ratchet xa+y			xy		n		plus ratchet 0
ok 'xy' !~~ /:ratchet xa+y/, 'plus ratchet 0';

#### :ratchet xa+a			xaaaay		n		plus ratchet 2+
ok 'xaaaay' !~~ /:ratchet xa+a/, 'plus ratchet 2+';

#### :ratchet xa+a			xay		n		plus ratchet 1
ok 'xay' !~~ /:ratchet xa+a/, 'plus ratchet 1';


#### :ratchet xa?y			xaaaay		n		ques ratchet 2+
ok 'xaaaay' !~~ /:ratchet xa?y/, 'ques ratchet 2+';

#### :ratchet xa?y			xay		//	ques ratchet 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa?y/) && matchcheck($/, q//), 'ques ratchet 1';

#### :ratchet xa?y			xy		//	ques ratchet 0
#?pugs todo 
ok ('xy' ~~ /:ratchet xa?y/) && matchcheck($/, q//), 'ques ratchet 0';

#### :ratchet xa?a			xaaaay		//	ques ratchet 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa?a/) && matchcheck($/, q//), 'ques ratchet 2+';

#### :ratchet xa?a			xay		n		ques ratchet 1
ok 'xay' !~~ /:ratchet xa?a/, 'ques ratchet 1';


#### :ratchet xa*!y			xaaaay		//	star ratchet greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa*!y/) && matchcheck($/, q//), 'star ratchet greedy 2+';

#### :ratchet xa*!y			xay		//	star ratchet greedy 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa*!y/) && matchcheck($/, q//), 'star ratchet greedy 1';

#### :ratchet xa*!y			xy		//	star ratchet greedy 0
#?pugs todo 
ok ('xy' ~~ /:ratchet xa*!y/) && matchcheck($/, q//), 'star ratchet greedy 0';

#### :ratchet xa*!a			xaaaay		//	star ratchet greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa*!a/) && matchcheck($/, q//), 'star ratchet greedy 2+';

#### :ratchet xa*!a			xay		//	star ratchet greedy 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa*!a/) && matchcheck($/, q//), 'star ratchet greedy 1';


#### :ratchet xa+!y			xaaaay		//	plus ratchet greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa+!y/) && matchcheck($/, q//), 'plus ratchet greedy 2+';

#### :ratchet xa+!y			xay		//	plus ratchet greedy 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa+!y/) && matchcheck($/, q//), 'plus ratchet greedy 1';

#### :ratchet xa+!y			xy		n		plus ratchet greedy 0
ok 'xy' !~~ /:ratchet xa+!y/, 'plus ratchet greedy 0';

#### :ratchet xa+!a			xaaaay		//	plus ratchet greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa+!a/) && matchcheck($/, q//), 'plus ratchet greedy 2+';

#### :ratchet xa+!a			xay		n		plus ratchet greedy 1
ok 'xay' !~~ /:ratchet xa+!a/, 'plus ratchet greedy 1';


#### :ratchet xa?!y			xaaaay		n		ques ratchet greedy 2+
ok 'xaaaay' !~~ /:ratchet xa?!y/, 'ques ratchet greedy 2+';

#### :ratchet xa?!y			xay		//	ques ratchet greedy 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa?!y/) && matchcheck($/, q//), 'ques ratchet greedy 1';

#### :ratchet xa?!y			xy		//	ques ratchet greedy 0
#?pugs todo 
ok ('xy' ~~ /:ratchet xa?!y/) && matchcheck($/, q//), 'ques ratchet greedy 0';

#### :ratchet xa?!a			xaaaay		//	ques ratchet greedy 2+
#?pugs todo 
ok ('xaaaay' ~~ /:ratchet xa?!a/) && matchcheck($/, q//), 'ques ratchet greedy 2+';

#### :ratchet xa?!a			xay		//	ques ratchet greedy 1
#?pugs todo 
ok ('xay' ~~ /:ratchet xa?!a/) && matchcheck($/, q//), 'ques ratchet greedy 1';



## Quantifier closure
#### .**{2}			a			n	only one character
#?rakudo skip '**{}'
ok 'a' !~~ /.**{2}/, 'only one character';

#### .**{2}			ab			y	two characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'ab' ~~ /.**{2}/, 'two characters';

#### a**{2}			foobar		n	only one "a" character
#?rakudo skip '**{}'
ok 'foobar' !~~ /a**{2}/, 'only one "a" character';

#### a**{2}			baabaa		y	two "a" characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'baabaa' ~~ /a**{2}/, 'two "a" characters';

#### a**{0..4}		bbbbbbb		y	no "a" characters
#?rakudo skip '**{}'
#?pugs todo 
ok 'bbbbbbb' ~~ /a**{0..4}/, 'no "a" characters';

#### a**{2..4}		bababab		n	not two consecutive "a" characters
#?rakudo skip '**{}'
ok 'bababab' !~~ /a**{2..4}/, 'not two consecutive "a" characters';

#### a**{2..4}		baabbbb		y	two "a" characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'baabbbb' ~~ /a**{2..4}/, 'two "a" characters';

#### a**{2..4}		baaabbb		y	three "a" characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaabbb' ~~ /a**{2..4}/, 'three "a" characters';

#### a**{2..4}		baaaabb		y	four "a" characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaabb' ~~ /a**{2..4}/, 'four "a" characters';

#### a**{2..4}		baaaaaa		y	four "a" characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaaaa' ~~ /a**{2..4}/, 'four "a" characters';

#### a**{2..*}		baaaaaa		y	six "a" characters
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaaaa' ~~ /a**{2..*}/, 'six "a" characters';

#### a**?{2..*}		baaaaaa		y	two "a" characters (non-greedy)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaaaa' ~~ /a**?{2..*}/, 'two "a" characters (non-greedy)';

#### a**:?{2..*}		baaaaaa		y	two "a" characters (non-greedy)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaaaa' ~~ /a**:?{2..*}/, 'two "a" characters (non-greedy)';

#### a**!{2..*}		baaaaaa		y	six "a" characters (explicit greed)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaaaa' ~~ /a**!{2..*}/, 'six "a" characters (explicit greed)';

#### a**:!{2..*}		baaaaaa		y	six "a" characters (explicit greed)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaaaaa' ~~ /a**:!{2..*}/, 'six "a" characters (explicit greed)';

#### a**?{2..4}		baaabbb		y	two "a" characters (non-greedy)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaabbb' ~~ /a**?{2..4}/, 'two "a" characters (non-greedy)';

#### a**:?{2..4}		baaabbb		y	two "a" characters (non-greedy)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaabbb' ~~ /a**:?{2..4}/, 'two "a" characters (non-greedy)';

#### a**!{2..4}		baaabbb		y	three "a" characters (explicit greed)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaabbb' ~~ /a**!{2..4}/, 'three "a" characters (explicit greed)';

#### a**:!{2..4}		baaabbb		y	three "a" characters (explicit greed)
#?pugs todo 
#?rakudo skip '**{}'
ok 'baaabbb' ~~ /a**:!{2..4}/, 'three "a" characters (explicit greed)';


## Quantifier bare range
#### .**2			a			n	only one character
ok 'a' !~~ /.**2/, 'only one character';

#### .**2			ab			y	two characters
#?pugs todo 
ok 'ab' ~~ /.**2/, 'two characters';

#### a**2			foobar		n	only one "a" character
ok 'foobar' !~~ /a**2/, 'only one "a" character';

#### a**2			baabaa		y	two "a" characters
#?pugs todo 
ok 'baabaa' ~~ /a**2/, 'two "a" characters';

#### a**0..4			bbbbbbb		y	no "a" characters
#?pugs todo 
ok 'bbbbbbb' ~~ /a**0..4/, 'no "a" characters';

#### a**2..4			bababab		n	not two consecutive "a" characters
ok 'bababab' !~~ /a**2..4/, 'not two consecutive "a" characters';

#### a**2..4			baabbbb		y	two "a" characters
#?pugs todo 
ok 'baabbbb' ~~ /a**2..4/, 'two "a" characters';

#### a**2..4			baaabbb		y	three "a" characters
#?pugs todo 
ok 'baaabbb' ~~ /a**2..4/, 'three "a" characters';

#### a**2..4			baaaabb		y	four "a" characters
#?pugs todo 
ok 'baaaabb' ~~ /a**2..4/, 'four "a" characters';

#### a**2..4			baaaaaa		y	four "a" characters
#?pugs todo 
ok 'baaaaaa' ~~ /a**2..4/, 'four "a" characters';

#### a**2..*			baaaaaa		y	six "a" characters
#?pugs todo 
ok 'baaaaaa' ~~ /a**2..*/, 'six "a" characters';

#### a**?2..*		baaaaaa		y	two "a" characters (non-greedy)
#?pugs todo 
ok 'baaaaaa' ~~ /a**?2..*/, 'two "a" characters (non-greedy)';

#### a**:?2..*		baaaaaa		y	two "a" characters (non-greedy)
#?pugs todo 
ok 'baaaaaa' ~~ /a**:?2..*/, 'two "a" characters (non-greedy)';

#### a**!2..*		baaaaaa		y	six "a" characters (explicit greed)
#?pugs todo 
ok 'baaaaaa' ~~ /a**!2..*/, 'six "a" characters (explicit greed)';

#### a**:!2..*		baaaaaa		y	six "a" characters (explicit greed)
#?pugs todo 
ok 'baaaaaa' ~~ /a**:!2..*/, 'six "a" characters (explicit greed)';

#### a**?2..4		baaabbb		y	two "a" characters (non-greedy)
#?pugs todo 
ok 'baaabbb' ~~ /a**?2..4/, 'two "a" characters (non-greedy)';

#### a**:?2..4		baaabbb		y	two "a" characters (non-greedy)
#?pugs todo 
ok 'baaabbb' ~~ /a**:?2..4/, 'two "a" characters (non-greedy)';

#### a**!2..4		baaabbb		y	three "a" characters (explicit greed)
#?pugs todo 
ok 'baaabbb' ~~ /a**!2..4/, 'three "a" characters (explicit greed)';

#### a**:!2..4		baaabbb		y	three "a" characters (explicit greed)
#?pugs todo 
ok 'baaabbb' ~~ /a**:!2..4/, 'three "a" characters (explicit greed)';

# RT 112450
#?pugs todo 'RT 112450'
{
    ok 'foooo' ~~ /^ f o ** 4 $/, 'RT 112450 sanity';
    my $rt112450 = 4;
    #?rakudo 2 skip 'RT 112450'
    #?niecza 2 skip 'Dubious test, http://irclog.perlgeek.de/perl6/2012-05-27#i_5643089'
    ok 'foooo' ~~ /^ f o **  $rt112450  $/, 'RT 112450 interpolation';
    ok 'foooo' ~~ /^ f o ** {$rt112450} $/, 'RT 112450 closure interpolation';
}

# RT 112454
#?pugs skip 'RT 112454'
{
    my $rt112454 = 3;
    my $ten_x = 'x' x 10;

    ok $ten_x ~~ / x ** 3 /, 'RT 112454 match sanity';
    is $/.Str, 'x' x 3, 'RT 112454 quantifier sanity';

    #?rakudo 2 skip 'RT 112454'
    ok $ten_x ~~ / x ** {$rt112454} /, 'Simple match (RT 112454)';
    is $/.Str, 'x' x $rt112454, '** quantifier with braces (RT 112454)';
}

# RT 116415
#?pugs skip 'RT 116415'
{
    my $rt116415 = 0;

    ok 'foobar' ~~ / . ** 0 /, 'RT 116415 match sanity';
    is $/.Str, '', 'RT 116415 quantifier sanity';

    #?rakudo 2 skip 'RT 116415'
    ok 'foobar' ~~ / . ** {$rt116415} /, 'Simple match (RT 116415)';
    is $/.Str, '', '** quantifier with braces (RT 116415)';
}

# RT 115298
#?pugs todo
ok 'foobar' ~~ /$( $_ )/, '$( $_ ) will match literally';
#?pugs todo
is $/, 'foobar', '... will match correctly';

#### 			2+3 ab2		/mob: /		capturing builtin 
#?pugs todo 
ok ('2+3 ab2' ~~ //) && matchcheck($/, q/mob: /), 'capturing builtin ';

#### 			ab::cd::x3::42	/mob: /	capturing builtin 
#?rakudo skip 'regex '
#?niecza skip "Unable to resolve method name in class Cursor"
#?pugs todo 
ok ('ab::cd::x3::42' ~~ //) && matchcheck($/, q/mob: /), 'capturing builtin ';


#### <.ident>			2+3 ab2		y		non-capturing builtin <.ident>
#?pugs todo 
ok '2+3 ab2' ~~ /<.ident>/, 'non-capturing builtin <.ident>';

#### <.name>			ab::cd::x3::42	y	non-capturing builtin <.name>
#?rakudo skip 'regex '
#?niecza skip "Unable to resolve method name in class Cursor"
#?pugs todo 
ok 'ab::cd::x3::42' ~~ /<.name>/, 'non-capturing builtin <.name>';

#?niecza 12 skip "Unable to resolve method wb in class Cursor"

#### def		abc\ndef\n-==\nghi	y	word boundary \W\w
#?pugs todo 
ok "abc\ndef\n-==\ngh" ~~ /def/, 'word boundary \W\w';

#### abc		abc\ndef\n-==\nghi	y	word boundary \w\W
#?pugs todo 
ok "abc\ndef\n-==\nghi" ~~ /abc/, 'word boundary \w\W';

#### abc		abc\ndef\n-==\nghi	y	BOS word boundary
#?pugs todo 
ok "abc\ndef\n-==\nghi" ~~ /abc/, 'BOS word boundary';

#### ghi		abc\ndef\n-==\nghi	y	EOS word boundary
#?pugs todo 
ok "abc\ndef\n-==\nghi" ~~ /ghi/, 'EOS word boundary';

#### a			abc\ndef\n-==\nghi	n	\w\w word boundary
ok "abc\ndef\n-==\nghi" !~~ /a/, '\w\w word boundary';

#### \-			abc\ndef\n-==\nghi	n	\W\W word boundary
ok "abc\ndef\n-==\nghi" !~~ /\-/, '\W\W word boundary';

# L >>)/"A leading ! indicates">

#### def		abc\ndef\n-==\nghi	n	nonword boundary \W\w
ok "abc\ndef\n-==\nghi" !~~ /def/, 'nonword boundary \W\w';

#### abc		abc\ndef\n-==\nghi	n	nonword boundary \w\W
ok "abc\ndef\n-==\nghi" !~~ /abc/, 'nonword boundary \w\W';

#### abc		abc\ndef\n-==\nghi	n	BOS nonword boundary
ok "abc\ndef\n-==\nghi" !~~ /abc/, 'BOS nonword boundary';

#### ghi		abc\ndef\n-==\nghi	n	EOS nonword boundary
ok "abc\ndef\n-==\nghi" !~~ /ghi/, 'EOS nonword boundary';

#### a			abc\ndef\n-==\nghi	y	\w\w nonword boundary
#?pugs todo 
ok "abc\ndef\n-==\nghi" ~~ /a/, '\w\w nonword boundary';

#### \-			abc\ndef\n-==\nghi	y	\W\W nonword boundary
#?pugs todo 
ok "abc\ndef\n-==\nghi" ~~ /\-/, '\W\W nonword boundary';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: /), '';

#### <+upper>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /			<+upper>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+upper>/) && matchcheck($/, q/mob: /), '<+upper>';

#### <+upper>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /	<+upper>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+upper>+/) && matchcheck($/, q/mob: /), '<+upper>+';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: /), '';

#### <+lower>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /			<+lower>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+lower>/) && matchcheck($/, q/mob: /), '<+lower>';

#### <+lower>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /	<+lower>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+lower>+/) && matchcheck($/, q/mob: /), '<+lower>+';

#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: /), '';

#### <+alpha>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /			<+alpha>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+alpha>/) && matchcheck($/, q/mob: /), '<+alpha>';

#### <+alpha>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /	<+alpha>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+alpha>+/) && matchcheck($/, q/mob: /), '<+alpha>+';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0 @ 35>/		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: <0 @ 35>/), '';

#### <+digit>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0 @ 35>/			<+digit>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+digit>/) && matchcheck($/, q/mob: <0 @ 35>/), '<+digit>';

#### <+digit>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0123456789 @ 35>/	<+digit>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+digit>+/) && matchcheck($/, q/mob: <0123456789 @ 35>/), '<+digit>+';


#### 	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0 @ 35>/		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: <0 @ 35>/), '';

#### <+xdigit>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0 @ 35>/			<+xdigit>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+xdigit>/) && matchcheck($/, q/mob: <0 @ 35>/), '<+xdigit>';

#### <+xdigit>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0123456789ABCDEF @ 35>/	<+xdigit>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+xdigit>+/) && matchcheck($/, q/mob: <0123456789ABCDEF @ 35>/), '<+xdigit>+';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: <\t @ 0>/), '';

#### <+space>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/		<+space>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+space>/) && matchcheck($/, q/mob: <\t @ 0>/), '<+space>';

#### <+space>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t\n\r  @ 0>/		<+space>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+space>+/) && matchcheck($/, q/mob: <\t\n\r  @ 0>/), '<+space>+';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: <\t @ 0>/), '';

#### <+blank>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/			<+blank>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+blank>/) && matchcheck($/, q/mob: <\t @ 0>/), '<+blank>';

#### <+blank>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/			<+blank>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+blank>+/) && matchcheck($/, q/mob: <\t @ 0>/), '<+blank>+';

#?niecza 3 todo "Unable to resolve method cntrl in class Cursor"

#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/		
#?rakudo todo ''
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: <\t @ 0>/), '';

#### <+cntrl>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t @ 0>/			<+cntrl>
#?rakudo todo ''
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+cntrl>/) && matchcheck($/, q/mob: <\t @ 0>/), '<+cntrl>';

#### <+cntrl>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <\t\n\r @ 0>/		<+cntrl>+
#?rakudo todo ''
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+cntrl>+/) && matchcheck($/, q/mob: <\t\n\r @ 0>/), '<+cntrl>+';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: /), '';

#### <+punct>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: /			<+punct>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+punct>/) && matchcheck($/, q/mob: /), '<+punct>';

#### <+punct>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: +
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+punct>+/) && matchcheck($/, q/mob: +';


#### 		\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0 @ 35>/		
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ //) && matchcheck($/, q/mob: <0 @ 35>/), '';

#### <+alnum>	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0 @ 35>/	<+alnum>
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+alnum>/) && matchcheck($/, q/mob: <0 @ 35>/), '<+alnum>';

#### <+alnum>+	\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij	/mob: <0123456789ABCDEFGHIJabcdefghij @ 35>/	<+alnum>+
#?pugs todo 
ok ('\t\n\r !"#$%&\'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij' ~~ /<+alnum>+/) && matchcheck($/, q/mob: <0123456789ABCDEFGHIJabcdefghij @ 35>/), '<+alnum>+';

#### <+alnum+[_]>	ident_1				y	union of character classes
#?pugs todo 
ok 'ident_1' ~~ /<+alnum+[_]>/, 'union of character classes';

#### <+[ab]+[\-]>+	aaa-bbb				y	enumerated character classes
#?pugs todo 
ok 'aaa-bbb' ~~ /<+[ab]+[\-]>+/, 'enumerated character classes';

#### <+  [ a  b ]+[\-]>+		aaa-bbb		y	whitespace is ignored within square brackets and after the initial +
#?niecza skip "+  [ ] fails"
#?pugs todo 
ok 'aaa-bbb' ~~ /<+  [ a  b ]+[\-]>+/, 'whitespace is ignored within square brackets and after the initial +';

#### <+[ab]+[\-]>+	-ab-				y	enumerated character classes variant
#?pugs todo 
ok '-ab-' ~~ /<+[ab]+[\-]>+/, 'enumerated character classes variant';

#### <+[ab]+[\-]>+	----				y	enumerated character classes variant
#?pugs todo 
ok '----' ~~ /<+[ab]+[\-]>+/, 'enumerated character classes variant';

#### <+[ab]+[\-]>+	-				y	enumerated character classes variant
#?pugs todo 
ok '-' ~~ /<+[ab]+[\-]>+/, 'enumerated character classes variant';

#### <-[ab]+[cd]>+	ccdd				y	enumerated character classes variant
#?pugs todo 
ok 'ccdd' ~~ /<-[ab]+[cd]>+/, 'enumerated character classes variant';

#### ^<-[ab]+[cd]>+$	caad				n	enumerated character classes variant
ok 'caad' !~~ /^<-[ab]+[cd]>+$/, 'enumerated character classes variant';

#### <-  [ a  b ]+[cd]>+	ccdd			y	whitespace is ignored within square brackets and after the initial -
#?niecza skip "+  [ ] fails"
#?pugs todo 
ok 'ccdd' ~~ /<-  [ a  b ]+[cd]>+/, 'whitespace is ignored within square brackets and after the initial -';

#### ^<-upper>dent	ident_1				y	inverted character class
#?pugs todo 
ok 'ident_1' ~~ /^<-upper>dent/, 'inverted character class';

#### ^<-upper>dent	Ident_1				n	inverted character class
ok 'Ident_1' !~~ /^<-upper>dent/, 'inverted character class';

#### <+alpha-[Jj]>+	abc				y	character class with no j
#?pugs todo 
ok 'abc' ~~ /<+alpha-[Jj]>+/, 'character class with no j';

#### <+ alpha - [ Jj ]>	abc			y	character class with no j with ws
#?niecza skip "Unable to resolve method alpha in class Cursor"
#?pugs todo 
ok 'abc' ~~ /<+ alpha - [ Jj ]>/, 'character class with no j with ws';

#### ^<+alpha-[Jj]>+$	aJc			n	character class with no j fail
ok 'aJc' !~~ /^<+alpha-[Jj]>+$/, 'character class with no j fail';


##  syntax errors

#### {{		abcdef		/Missing closing braces/	unterminated closure
#?pugs todo 
eval_dies_ok '/{{/', 'unterminated closure';

#### \1		abcdef		/reserved/			back references
#?pugs todo 
eval_dies_ok '/\1/', 'back references';

#### \x[		abcdef		/Missing close bracket/		unterminated \x[..]
#?pugs todo 
eval_dies_ok '/\x[/', 'unterminated \x[..]';

#### \X[		abcdef		/Missing close bracket/		unterminated \X[..]
#?pugs todo 
eval_dies_ok '/\X[/', 'unterminated \X[..]';


#### * abc		abcdef		/Quantifier follows nothing/	bare * at start
#?pugs todo 
eval_dies_ok '/* abc/', 'bare * at start';

####   * abc		abcdef		/Quantifier follows nothing/	bare * after ws
#?pugs todo 
eval_dies_ok '/  * abc/', 'bare * after ws';

#### [*|a]		abcdef		/Quantifier follows nothing/	bare * after [
#?pugs todo 
eval_dies_ok '/[*|a]/', 'bare * after [';

#### [ *|a]		abcdef		/Quantifier follows nothing/	bare * after [+sp
#?pugs todo 
eval_dies_ok '/[ *|a]/', 'bare * after [+sp';

#### [a|*]		abcdef		/Quantifier follows nothing/	bare * after |
#?pugs todo 
eval_dies_ok '/[a|*]/', 'bare * after |';

#### [a| *]		abcdef		/Quantifier follows nothing/	bare * after |+sp
#?pugs todo 
eval_dies_ok '/[a| *]/', 'bare * after |+sp';


#### + abc		abcdef		/Quantifier follows nothing/	bare + at start
#?pugs todo 
eval_dies_ok '/+ abc/', 'bare + at start';

####   + abc		abcdef		/Quantifier follows nothing/	bare + after ws
#?pugs todo 
eval_dies_ok '/  + abc/', 'bare + after ws';

#### [+|a]		abcdef		/Quantifier follows nothing/	bare + after [
#?pugs todo 
eval_dies_ok '/[+|a]/', 'bare + after [';

#### [ +|a]		abcdef		/Quantifier follows nothing/	bare + after [+sp
#?pugs todo 
eval_dies_ok '/[ +|a]/', 'bare + after [+sp';

#### [a|+]		abcdef		/Quantifier follows nothing/	bare + after |
#?pugs todo 
eval_dies_ok '/[a|+]/', 'bare + after |';

#### [a| +]		abcdef		/Quantifier follows nothing/	bare + after |+sp
#?pugs todo 
eval_dies_ok '/[a| +]/', 'bare + after |+sp';


#### ? abc		abcdef		/Quantifier follows nothing/	bare ? at start
#?pugs todo 
eval_dies_ok '/? abc/', 'bare ? at start';

####   ? abc		abcdef		/Quantifier follows nothing/	bare ? after ws
#?pugs todo 
eval_dies_ok '/  ? abc/', 'bare ? after ws';

#### [?|a]		abcdef		/Quantifier follows nothing/	bare ? after [
#?pugs todo 
eval_dies_ok '/[?|a]/', 'bare ? after [';

#### [ ?|a]		abcdef		/Quantifier follows nothing/	bare ? after [+sp
#?pugs todo 
eval_dies_ok '/[ ?|a]/', 'bare ? after [+sp';

#### [a|?]		abcdef		/Quantifier follows nothing/	bare ? after |
#?pugs todo 
eval_dies_ok '/[a|?]/', 'bare ? after |';

#### [a| ?]		abcdef		/Quantifier follows nothing/	bare ? after |+sp
#?pugs todo 
eval_dies_ok '/[a| ?]/', 'bare ? after |+sp';

# L

#### 		abcdef		/Null pattern illegal/		null pattern
eval_dies_ok '//', '';

####   		abcdef		/Null pattern illegal/		ws null pattern
#?pugs todo 
eval_dies_ok '/  /', 'ws null pattern';

#?pugs todo 
eval_dies_ok '"b" ~~ /b| /', 'null pattern after alternation';

# RT #70007
# undefined captures should fail to match
# note the use of $1 (and not $0)
#?niecza todo 'undefined capture'
nok 'aa' ~~ /(.)$1/, 'undefined captures do not match';

# RT #71702
#?niecza todo 'allows them'
#?pugs todo 'allows them'
eval_dies_ok '"foo" ~~ /<[d..b]>? foo/', 'no reversed char ranges';

done;
# vim: ft=perl6 sw=4 expandtab
rakudo-2013.12/t/spec/S05-mass/stdrules.t0000664000175000017500000004215712224265625017361 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/stdrules.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

# L >>)/"The special named assertions include">

plan 186;


#?pugs todo
ok("abc1_2" ~~ m/^  $/, '');
#?pugs todo
is($/, 'abc1_2', 'Captured ');
#?pugs todo
ok("abc1_2" ~~ m/^ <.ident> $/, '<.ident>');
ok(!defined($/), 'Uncaptured <.ident>');
ok(!( "7abc1_2" ~~ m/^ <.ident> $/ ), 'not <.ident>');

#?pugs todo
ok("\t \n\t" ~~ m/^ <.ws> $/, '<.ws>');
ok(!defined($/), 'Uncaptured <.ws>');
ok(!( "7abc1_2" ~~ m/^ <.ws> $/ ), 'not <.ws>');

#?pugs todo
ok(" \t\t \t" ~~ m/^ (\h+) $/, '\h');
#?pugs todo
is($/, " \t\t \t", 'captured \h');
ok(!( " \t\n " ~~ m/^ (\h+) $/ ), 'not \h');

#?pugs todo
ok("\n\n" ~~ m/^ (\v+) $/, '\v');
#?pugs todo
is($/, "\n\n", 'captured \v');
ok(!( " \t\n " ~~ m/^ (\v+) $/ ), 'not \v');

# alpha

#?pugs todo
ok("A" ~~ m/^<.alpha>$/, q{Match alpha as subrule});
ok(!( "A" ~~ m/^.$/ ), q{Don't match negated alpha as subrule} );
ok(!( "A" ~~ m/^<-alpha>$/ ), q{Don't match inverted alpha as subrule} );
ok(!( "\x07"  ~~ m/^<.alpha>$/ ), q{Don't match unrelated alpha as subrule} );
#?pugs todo
ok("\x07"  ~~ m/^.$/, q{Match unrelated negated alpha as subrule});
#?pugs todo
ok("\x07"  ~~ m/^<-alpha>$/, q{Match unrelated inverted alpha as subrule});
 
#?pugs todo
ok("A" ~~ m/^<+alpha>$/, q{Match alpha as charset});
#?pugs todo
ok("A" ~~ m/^<+[A]+alpha>$/, q{Match compound alpha as charset});
ok(!( "A" ~~ m/^<-alpha>$/ ), q{Don't match inverted alpha as charset} );
ok(!( "A" ~~ m/^<+[A]-alpha>$/ ), q{Don't match compound inverted alpha as charset} );
ok(!( "\x07"  ~~ m/^<+alpha>$/ ), q{Don't match unrelated alpha as charset} );
#?pugs todo
ok("\x07"  ~~ m/^<-alpha>$/, q{Match inverted alpha as charset});
#?pugs todo
ok("\x07A" ~~ m/<+alpha>/, q{Match unanchored alpha as charset});

# space

{
    #?pugs todo
    ok("\x[9]" ~~ m/^<.space>$/, q{Match space as subrule});
    ok(!( "\x[9]" ~~ m/^.$/ ), q{Don't match negated space as subrule} );
    ok(!( "\x[9]" ~~ m/^<-space>$/ ), q{Don't match inverted space as subrule} );
    ok(!( "("  ~~ m/^<.space>$/ ), q{Don't match unrelated space as subrule} );
    #?pugs todo
    ok("("  ~~ m/^.$/, q{Match unrelated negated space as subrule});
    #?pugs todo
    ok("("  ~~ m/^<-space>$/, q{Match unrelated inverted space as subrule});
    
    #?pugs todo
    ok("\x[9]" ~~ m/^<+space>$/, q{Match space as charset});
    #?pugs todo
    ok("\x[9]" ~~ m/^<+[A]+space>$/, q{Match compound space as charset});
    ok(!( "\x[9]" ~~ m/^<-space>$/ ), q{Don't match externally inverted space as charset} );
    ok(!( "\x[9]" ~~ m/^<+[A]-space>$/ ), q{Don't match compound inverted space as charset} );
    ok(!( "\x[9]" ~~ m/^<-space>$/ ), q{Don't match internally inverted space as charset} );
    ok(!( "("  ~~ m/^<+space>$/ ), q{Don't match unrelated space as charset} );
    #?pugs todo
    ok("("  ~~ m/^<-space>$/, q{Match inverted space as charset});
    #?pugs todo
    ok("(\x[9]" ~~ m/<+space>/, q{Match unanchored space as charset});
}

# digit

{
    #?pugs todo
    ok("0" ~~ m/^<.digit>$/, q{Match digit as subrule});
    ok(!( "0" ~~ m/^.$/ ), q{Don't match negated digit as subrule} );
    ok(!( "0" ~~ m/^<-digit>$/ ), q{Don't match inverted digit as subrule} );
    ok(!( "\x[C]"  ~~ m/^<.digit>$/ ), q{Don't match unrelated digit as subrule} );
    #?pugs todo
    ok("\x[C]"  ~~ m/^.$/, q{Match unrelated negated digit as subrule});
    #?pugs todo
    ok("\x[C]"  ~~ m/^<-digit>$/, q{Match unrelated inverted digit as subrule});
    
    #?pugs todo
    ok("0" ~~ m/^<+digit>$/, q{Match digit as charset});
    #?pugs todo
    ok("0" ~~ m/^<+[A]+digit>$/, q{Match compound digit as charset});
    ok(!( "0" ~~ m/^<-digit>$/ ), q{Don't match externally inverted digit as charset} );
    ok(!( "0" ~~ m/^<+[A]-digit>$/ ), q{Don't match compound inverted digit as charset} );
    ok(!( "0" ~~ m/^<-digit>$/ ), q{Don't match internally inverted digit as charset} );
    ok(!( "\x[C]"  ~~ m/^<+digit>$/ ), q{Don't match unrelated digit as charset} );
    #?pugs todo
    ok("\x[C]"  ~~ m/^<-digit>$/, q{Match inverted digit as charset});
    #?pugs todo
    ok("\x[C]0" ~~ m/<+digit>/, q{Match unanchored digit as charset});
}

# alnum

{
    #?pugs todo
    ok("n" ~~ m/^<.alnum>$/, q{Match alnum as subrule});
    ok(!( "n" ~~ m/^.$/ ), q{Don't match negated alnum as subrule} );
    ok(!( "n" ~~ m/^<-alnum>$/ ), q{Don't match inverted alnum as subrule} );
    ok(!( '{'  ~~ m/^<.alnum>$/ ), q{Don't match unrelated alnum as subrule} );
    #?pugs todo
    ok('{'  ~~ m/^.$/, q{Match unrelated negated alnum as subrule});
    #?pugs todo
    ok('{'  ~~ m/^<-alnum>$/, q{Match unrelated inverted alnum as subrule});

    #?pugs todo
    ok("n" ~~ m/^<+alnum>$/, q{Match alnum as charset});
    #?pugs todo
    ok("n" ~~ m/^<+[A]+alnum>$/, q{Match compound alnum as charset});
    ok(!( "n" ~~ m/^<-alnum>$/ ), q{Don't match externally inverted alnum as charset} );
    ok(!( "n" ~~ m/^<+[A]-alnum>$/ ), q{Don't match compound inverted alnum as charset} );

    ok(!( "n" ~~ m/^<-alnum>$/ ), q{Don't match internally inverted alnum as charset} );
    ok(!( '{'  ~~ m/^<+alnum>$/ ), q{Don't match unrelated alnum as charset} );
    #?pugs todo
    ok('{'  ~~ m/^<-alnum>$/, q{Match inverted alnum as charset});
    #?pugs todo
    ok('{n' ~~ m/<+alnum>/, q{Match unanchored alnum as charset});
}

# ascii

# Unspecced
# ok("+" ~~ m/^<.ascii>$/, q{Match ascii as subrule});
# ok(!( "+" ~~ m/^.$/ ), q{Don't match negated ascii as subrule} );
# ok(!( "+" ~~ m/^<-ascii>$/ ), q{Don't match inverted ascii as subrule} );
#
# ok("+" ~~ m/^<+ascii>$/, q{Match ascii as charset});
# ok("+" ~~ m/^<+[A]+ascii>$/, q{Match compound ascii as charset});
# ok(!( "+" ~~ m/^<-ascii>$/ ), q{Don't match externally inverted ascii as charset} );
# ok(!( "+" ~~ m/^<+[A]-ascii>$/ ), q{Don't match compound inverted ascii as charset} );
# ok(!( "+" ~~ m/^<-ascii>$/ ), q{Don't match inverted ascii as charset} );
# ok("+" ~~ m/<+ascii>/, q{Match unanchored ascii as charset});

# blank
{
    #?pugs todo
    ok("\x[9]" ~~ m/^<.blank>$/, q{Match blank as subrule});
    ok(!( "\x[9]" ~~ m/^.$/ ), q{Don't match negated blank as subrule} );
    ok(!( "\x[9]" ~~ m/^<-blank>$/ ), q{Don't match inverted blank as subrule} );
    ok(!( "&"  ~~ m/^<.blank>$/ ), q{Don't match unrelated blank as subrule} );
    #?pugs todo
    ok("&"  ~~ m/^.$/, q{Match unrelated negated blank as subrule});
    #?pugs todo
    ok("&"  ~~ m/^<-blank>$/, q{Match unrelated inverted blank as subrule});
    
    #?pugs todo
    ok("\x[9]" ~~ m/^<+blank>$/, q{Match blank as charset});
    #?pugs todo
    ok("\x[9]" ~~ m/^<+[A]+blank>$/, q{Match compound blank as charset});
    ok(!( "\x[9]" ~~ m/^<-blank>$/ ), q{Don't match externally inverted blank as charset} );
    ok(!( "\x[9]" ~~ m/^<+[A]-blank>$/ ), q{Don't match compound inverted blank as charset} );
    ok(!( "\x[9]" ~~ m/^<-blank>$/ ), q{Don't match internally inverted blank as charset} );
    ok(!( "&"  ~~ m/^<+blank>$/ ), q{Don't match unrelated blank as charset} );
    #?pugs todo
    ok("&"  ~~ m/^<-blank>$/, q{Match inverted blank as charset});
    #?pugs todo
    ok("&\x[9]" ~~ m/<+blank>/, q{Match unanchored blank as charset} );
}

# cntrl

{
    #?pugs todo
    ok("\x[7F]" ~~ m/^<.cntrl>$/, q{Match cntrl as subrule});
    ok(!( "\x[7F]" ~~ m/^.$/ ), q{Don't match negated cntrl as subrule} );
    ok(!( "\x[7F]" ~~ m/^<-cntrl>$/ ), q{Don't match inverted cntrl as subrule} );
    ok(!( "="  ~~ m/^<.cntrl>$/ ), q{Don't match unrelated cntrl as subrule} );
    #?pugs todo
    ok("="  ~~ m/^.$/, q{Match unrelated negated cntrl as subrule});
    #?pugs todo
    ok("="  ~~ m/^<-cntrl>$/, q{Match unrelated inverted cntrl as subrule});
    
    #?pugs todo
    ok("\x[7F]" ~~ m/^<+cntrl>$/, q{Match cntrl as charset} );
    #?pugs todo
    ok("\x[7F]" ~~ m/^<+[A]+cntrl>$/, q{Match compound cntrl as charset});
    ok(!( "\x[7F]" ~~ m/^<-cntrl>$/ ), q{Don't match externally inverted cntrl as charset} );
    ok(!( "\x[7F]" ~~ m/^<+[A]-cntrl>$/ ), q{Don't match compound inverted cntrl as charset} );
    ok(!( "\x[7F]" ~~ m/^<-cntrl>$/ ), q{Don't match internally inverted cntrl as charset} );
    ok(!( "="  ~~ m/^<+cntrl>$/ ), q{Don't match unrelated cntrl as charset} );
    #?pugs todo
    ok("="  ~~ m/^<-cntrl>$/, q{Match inverted cntrl as charset});
    #?pugs todo
    ok("=\x[7F]" ~~ m/<+cntrl>/, q{Match unanchored cntrl as charset} );
}

# graph

#?rakudo skip '<.graph>'
{
    #?pugs todo
    ok("V" ~~ m/^<.graph>$/, q{Match graph as subrule});
    ok(!( "V" ~~ m/^.$/ ), q{Don't match negated graph as subrule} );
    ok(!( "V" ~~ m/^<-graph>$/ ), q{Don't match inverted graph as subrule} );
    ok(!( "\x[7F]"  ~~ m/^<.graph>$/ ), q{Don't match unrelated graph as subrule} );
    #?pugs todo
    ok("\x[7F]"  ~~ m/^.$/, q{Match unrelated negated graph as subrule});
    #?pugs todo
    ok("\x[7F]"  ~~ m/^<-graph>$/, q{Match unrelated inverted graph as subrule});
 
    #?pugs todo
    ok("V" ~~ m/^<+graph>$/, q{Match graph as charset} );
    #?pugs todo
    ok("V" ~~ m/^<+[A]+graph>$/, q{Match compound graph as charset});
    ok(!( "V" ~~ m/^<-graph>$/ ), q{Don't match externally inverted graph as charset} );
    ok(!( "V" ~~ m/^<+[A]-graph>$/ ), q{Don't match compound inverted graph as charset} );
    ok(!( "V" ~~ m/^<-graph>$/ ), q{Don't match internally inverted graph as charset} );
    ok(!( "\x[7F]"  ~~ m/^<+graph>$/ ), q{Don't match unrelated graph as charset} );
    #?pugs todo
    ok("\x[7F]"  ~~ m/^<-graph>$/, q{Match inverted graph as charset});
    #?pugs todo
    ok("\x[7F]V" ~~ m/<+graph>/, q{Match unanchored graph as charset} );
}

# lower

{
    #?pugs todo
    ok("a" ~~ m/^<.lower>$/, q{Match lower as subrule});
    ok(!( "a" ~~ m/^.$/ ), q{Don't match negated lower as subrule} );
    ok(!( "a" ~~ m/^<-lower>$/ ), q{Don't match inverted lower as subrule} );
    ok(!( "\x[1E]"  ~~ m/^<.lower>$/ ), q{Don't match unrelated lower as subrule} );
    #?pugs todo
    ok("\x[1E]"  ~~ m/^.$/, q{Match unrelated negated lower as subrule});
    #?pugs todo
    ok("\x[1E]"  ~~ m/^<-lower>$/, q{Match unrelated inverted lower as subrule});

    #?pugs todo
    ok("a" ~~ m/^<+lower>$/, q{Match lower as charset} );
    #?pugs todo
    ok("a" ~~ m/^<+[A]+lower>$/, q{Match compound lower as charset});
    ok(!( "a" ~~ m/^<-lower>$/ ), q{Don't match externally inverted lower as charset} );
    ok(!( "a" ~~ m/^<+[A]-lower>$/ ), q{Don't match compound inverted lower as charset} );
    ok(!( "a" ~~ m/^<-lower>$/ ), q{Don't match internally inverted lower as charset} );
    ok(!( "\x[1E]"  ~~ m/^<+lower>$/ ), q{Don't match unrelated lower as charset} );
    #?pugs todo
    ok("\x[1E]"  ~~ m/^<-lower>$/, q{Match inverted lower as charset});
    #?pugs todo
    ok("\x[1E]a" ~~ m/<+lower>/, q{Match unanchored lower as charset} );
}

# print

#?rakudo skip '<.print>'
{
    #?pugs todo
    ok("M" ~~ m/^<.print>$/, q{Match print as subrule});
    ok(!( "M" ~~ m/^.$/ ), q{Don't match negated print as subrule} );
    ok(!( "M" ~~ m/^<-print>$/ ), q{Don't match inverted print as subrule} );
    ok(!( "\x[7F]"  ~~ m/^<.print>$/ ), q{Don't match unrelated print as subrule} );
    #?pugs todo
    ok("\x[7F]"  ~~ m/^.$/, q{Match unrelated negated print as subrule});
    #?pugs todo
    ok("\x[7F]"  ~~ m/^<-print>$/, q{Match unrelated inverted print as subrule});

    #?pugs todo
    ok("M" ~~ m/^<+print>$/, q{Match print as charset} );
    #?pugs todo
    ok("M" ~~ m/^<+[A]+print>$/, q{Match compound print as charset});
    ok(!( "M" ~~ m/^<-print>$/ ), q{Don't match externally inverted print as charset} );
    ok(!( "M" ~~ m/^<+[A]-print>$/ ), q{Don't match compound inverted print as charset} );
    ok(!( "M" ~~ m/^<-print>$/ ), q{Don't match internally inverted print as charset} );
    ok(!( "\x[7F]"  ~~ m/^<+print>$/ ), q{Don't match unrelated print as charset} );
    #?pugs todo
    ok("\x[7F]"  ~~ m/^<-print>$/, q{Match inverted print as charset});
    #?pugs todo
    ok("\x[7F]M" ~~ m/<+print>/, q{Match unanchored print as charset} );
}

# punct

{
    #?pugs todo
    ok("[" ~~ m/^<.punct>$/, q{Match punct as subrule});
    ok(!( "[" ~~ m/^.$/ ), q{Don't match negated punct as subrule} );
    ok(!( "[" ~~ m/^<-punct>$/ ), q{Don't match inverted punct as subrule} );
    ok(!( "F"  ~~ m/^<.punct>$/ ), q{Don't match unrelated punct as subrule} );
    #?pugs todo
    ok("F"  ~~ m/^.$/, q{Match unrelated negated punct as subrule});
    #?pugs todo
    ok("F"  ~~ m/^<-punct>$/, q{Match unrelated inverted punct as subrule});

    #?pugs todo
    ok("[" ~~ m/^<+punct>$/, q{Match punct as charset} );
    #?pugs todo
    ok("[" ~~ m/^<+[A]+punct>$/, q{Match compound punct as charset});
    ok(!( "[" ~~ m/^<-punct>$/ ), q{Don't match externally inverted punct as charset} );
    ok(!( "[" ~~ m/^<+[A]-punct>$/ ), q{Don't match compound inverted punct as charset} );
    ok(!( "[" ~~ m/^<-punct>$/ ), q{Don't match internally inverted punct as charset} );
    ok(!( "F"  ~~ m/^<+punct>$/ ), q{Don't match unrelated punct as charset} );
    #?pugs todo
    ok("F"  ~~ m/^<-punct>$/, q{Match inverted punct as charset});
    #?pugs todo
    ok("F[" ~~ m/<+punct>/, q{Match unanchored punct as charset} );
}

# upper

{
    #?pugs todo
    ok("A" ~~ m/^<.upper>$/, q{Match upper as subrule});
    ok(!( "A" ~~ m/^.$/ ), q{Don't match negated upper as subrule} );
    ok(!( "A" ~~ m/^<-upper>$/ ), q{Don't match inverted upper as subrule} );
    ok(!( "\x[5F]"  ~~ m/^<.upper>$/ ), q{Don't match unrelated upper as subrule} );
    #?pugs todo
    ok("\x[5F]"  ~~ m/^.$/, q{Match unrelated negated upper as subrule});
    #?pugs todo
    ok("\x[5F]"  ~~ m/^<-upper>$/, q{Match unrelated inverted upper as subrule});

    #?pugs todo
    ok("A" ~~ m/^<+upper>$/, q{Match upper as charset} );
    #?pugs todo
    ok("A" ~~ m/^<+[A]+upper>$/, q{Match compound upper as charset});
    
    ok(!( "A" ~~ m/^<-upper>$/ ), q{Don't match externally inverted upper as charset} );
    ok(!( "A" ~~ m/^<+[A]-upper>$/ ), q{Don't match compound inverted upper as charset} );
    ok(!( "A" ~~ m/^<-upper>$/ ), q{Don't match internally inverted upper as charset} );
    ok(!( "\x[5F]"  ~~ m/^<+upper>$/ ), q{Don't match unrelated upper as charset} );
    #?pugs todo
    ok("\x[5F]"  ~~ m/^<-upper>$/, q{Match inverted upper as charset});
    #?pugs todo
    ok("\x[5F]A" ~~ m/<+upper>/, q{Match unanchored upper as charset} );
}

# word
# unspecced
# ok("b" ~~ m/^<.word>$/, q{Match word as subrule});
# ok(!( "b" ~~ m/^.$/ ), q{Don't match negated word as subrule} );
# ok(!( "b" ~~ m/^<-word>$/ ), q{Don't match inverted word as subrule} );
# ok(!( '{'  ~~ m/^<.word>$/ ), q{Don't match unrelated word as subrule} );
# ok('{'  ~~ m/^.$/, q{Match unrelated negated word as subrule} );
# ok('{'  ~~ m/^<-word>$/, q{Match unrelated inverted word as subrule});
# 
# ok("b" ~~ m/^<+word>$/, q{Match word as charset} );
# ok("b" ~~ m/^<+[A]+word>$/, q{Match compound word as charset});
# ok(!( "b" ~~ m/^<-word>$/ ), q{Don't match externally inverted word as charset} );
# ok(!( "b" ~~ m/^<+[A]-word>$/ ), q{Don't match compound inverted word as charset} );
# ok(!( "b" ~~ m/^<-word>$/ ), q{Don't match internally inverted word as charset} );
# ok(!( '{'  ~~ m/^<+word>$/ ), q{Don't match unrelated word as charset} );
# ok('{'  ~~ m/^<-word>$/, q{Match inverted word as charset});
# ok('{b' ~~ m/<+word>/, q{Match unanchored word as charset} );

# xdigit

{
    #?pugs todo
    ok("0" ~~ m/^<.xdigit>$/, q{Match xdigit as subrule});
    ok(!( "0" ~~ m/^.$/ ), q{Don't match negated xdigit as subrule} );
    ok(!( "0" ~~ m/^<-xdigit>$/ ), q{Don't match inverted xdigit as subrule} );
    ok(!( "}"  ~~ m/^<.xdigit>$/ ), q{Don't match unrelated xdigit as subrule} );
    #?pugs todo
    ok("}"  ~~ m/^.$/, q{Match unrelated negated xdigit as subrule});
    #?pugs todo
    ok("}"  ~~ m/^<-xdigit>$/, q{Match unrelated inverted xdigit as subrule});

    #?pugs todo
    ok("0" ~~ m/^<+xdigit>$/, q{Match xdigit as charset} );
    #?pugs todo
    ok("0" ~~ m/^<+[A]+xdigit>$/, q{Match compound xdigit as charset});
    ok(!( "0" ~~ m/^<-xdigit>$/ ), q{Don't match externally inverted xdigit as charset} );
    ok(!( "0" ~~ m/^<+[A]-xdigit>$/ ), q{Don't match compound inverted xdigit as charset} );
    ok(!( "0" ~~ m/^<-xdigit>$/ ), q{Don't match internally inverted xdigit as charset} );
    ok(!( "}"  ~~ m/^<+xdigit>$/ ), q{Don't match unrelated xdigit as charset} );
    #?pugs todo
    ok("}"  ~~ m/^<-xdigit>$/, q{Match inverted xdigit as charset});
    #?pugs todo
    ok("}0" ~~ m/<+xdigit>/, q{Match unanchored xdigit as charset} );
}

# L

ok 'abc' !~~ /a /, ' fails';
ok '' !~~ //, ' fails (empty string)';

#?niecza 3 skip ''
#?pugs todo
 ok 'abc' ~~ /^/, 'basic ';
#?pugs skip "missing test function nok"
nok 'abc' ~~ /^/, '^/, ' 1, 'b' => 2);
ok(%a ~~ / 'b' /);
#?niecza todo
ok(%a ~~ / ^ 'b' /);
ok(%a ~~ / ^ 'a' /);
#?niecza todo
ok(%a ~~ / ^ 'a' $ /);

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-match/blocks.t0000664000175000017500000000556412224265625017123 0ustar  moritzmoritzuse v6;
use Test;

plan 22;

=begin description

Rakudo had a bug which caused failures when a regex match happened inside the
body of a C loop.
See L.

So now we test that you can use both a regex and its result object in any
kind of block, and in the condition, if any. 

=end description

if 1 {
    ok 'a' ~~ /./, 'Can match in an if block';
    is ~$/, 'a', '... and can use the match var';
}

#?rakudo todo 'nom regression'
#?niecza todo
ok !defined($/), '$/ still undefined in the outer block';

my $loop = 1;

while $loop {
    ok 'b' ~~ /./, 'Can match in a while block';
    is ~$/, 'b', '... and can use the match var';
    $loop = 0;
}
#?rakudo todo 'nom regression'
#?niecza todo
ok !defined($/), '$/ still undefined in the outer block';

{
    ok 'c' ~~ /./, 'Can match in a bare block';
    is ~$/, 'c', '... and can use the match var';
}
#?rakudo todo 'nom regression'
#?niecza todo
ok !defined($/), '$/ still undefined in the outer block';

my $discarded = do {
    ok 'd' ~~ /./, 'Can match in a do block';
    is ~$/, 'd', '... and can use the match var';

}
#?rakudo todo 'nom regression'
#?niecza todo
ok !defined($/), '$/ still undefined in the outer block';

{
    my $str = 'abc';
    my $count = 0;
    my $match = '';;
    while $str ~~ /b/ {
        $count++;
        $match = "$/";
        $str = '';
    }
    ok $count, 'Can match in the condition of a while loop';
    is $match, 'b', '... and can use $/ in the block';
    #?rakudo todo 'Assignment to matched string affects earlier match objects'
    #?niecza todo
    is "$/",   'b', '... and can use $/ outside the block';
}

{
    my $match = '';
    if 'xyc' ~~ /x/ {
        $match = "$/";
    }
    is $match, 'x', 'Can match in the condition of an if statement';
    is "$/",   'x', '... and can use $/ outside the block';
}

{
    given '-Wall' {
        if $_ ~~ /al/ {
            ok $/ eq 'al', '$/ is properly set with explicit $_ in a given { } block';
        }
        else {
            flunk 'regex did not match - $/ is properly set with explicit $_ in a given { } block';
        }
        if /\w+/ {
            is $/, 'Wall', '$/ is properly set in a given { } block';
        } else {
            flunk 'regex did not match - $/ is properly set in a given { } block';
        }
    }
}

# TODO: repeat ... until, gather/take, lambdas, if/unless statement modifiers
# TODO: move to t/spec/integration/

# test that a regex in an `if' matches against $_, not boolifies

{
    my $s1 = 0;
    my $s2 = 1;
    given 'foo' {
        if /foo/ { $s1 = 1 }
        if /not/ { $s2 = 0 }
    }
    is $s1, 1, '/foo/ matched against $_ (successfully)';
    is $s2, 1, '/not/ matched against $_ (no match)';

    given 'foo' {
        if /bar/ {
            ok 0, 'match in /if/;'
        } else {
            ok 1, 'match in /if/;'
        }
    }
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-match/capturing-contexts.t0000664000175000017500000001141012224265625021472 0ustar  moritzmoritzuse v6;
use MONKEY_TYPING;

use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;
plan 43;

# old: L
# L
{
  my $match = 'abd' ~~ m/ (a) (b) c || (\w) b d /;
  isa_ok $match, Match, 'Match object returned';
  isa_ok $/, Match, 'Match object assigned to $/';
  ok( $/ === $match, 'Same match objects');
}

{
  my $match = 'xyz' ~~ / abc /;
  #?niecza skip 'No value for parameter $obj in isa_ok'
  isa_ok( $/, Nil, 'Failed match returns Nil' );
}

# old: L object are referred to" >
# L
{
  'abd' ~~ m/ (a) (b) c || (\w) b d /;
  ok( $/[0] eq 'a', 'positional capture accessible');
  ok( @($/).[0] eq 'a', 'array context - correct number of positional captures');
  ok( @($/).elems == 1, 'array context - correct number of positional captures');
  ok( $/.list.elems == 1, 'the .list methods returns a list object');
}

# old: L object" >
# L
{
  'abd' ~~ m/   c ||  b d /;
  ok( $/ eq 'a', 'named capture accessible');
  ok( %($/).keys == 1, 'hash context - correct number of named captures');
  ok( %($/). eq 'a', 'hash context - named capture accessible');
  ok( $/.hash.keys[0] eq 'alpha', 'the .hash method returns a hash object');
}

# RT 62530
#?niecza skip 'rule declaration outside of grammar'
{
  augment class Match { method keys () {return %(self).keys }; };
  my rule a {H};
  "Hello" ~~ //;
  is $/.keys, 'a', 'get rule result';
  my $x = $/;
  is $x.keys, 'a', 'match copy should be same as match';
}

# RT #64946
{
    my regex o { o };
    "foo" ~~ /f+/;

    is ~$, 'o o', 'match list stringifies like a normal list';
    ok $ ~~ Positional, '... and it is Positional';
    # I don't know what difference 'isa' makes, but it does.
    # Note that calling .WHAT (as in the original ticket) does not have
    # the same effect.
    is ~$, 'o o', 'match list stringifies like a normal list AFTER "isa"';
}

# RT #64952
{
    'ab' ~~ /(.)+/;
    is $/[0][0], 'a', 'match element [0][0] from /(.)+/';
    is $/[0][1], 'b', 'match element [0][1] from /(.)+/';

    my @match = @( 'ab' ~~ /(.)+/ );
    #?rakudo 2 todo 'nom regression'
    is @match[0][0], 'a', 'match element [0][0] from /(.)+/ coerced';
    is @match[0][1], 'b', 'match element [0][1] from /(.)+/ coerced';
}

# RT #64948
{
    ok %( 'foo' ~~ / oo/ ):exists,
       'Match coerced to Hash says match exists';
}

# This is similar to a test in S05-interpolation/regex-in-variable.t
#?niecza todo 'match with non-existent capture does not match'
nok 'aa' ~~ /(.)$1/, 'match with non-existent capture does not match';
#?rakudo todo 'RT 70007'
#?niecza todo 'eek'
is_run( q{'aa' ~~ /(.)$1/},
        {
            status => 0,
            out    => '',
            err    => rx/undef/,
        },
        'match with non-existent capture emits a warning' );

# RT #66252
{
    $_ = 'RT 66252';
    m/(R.)/;
    #?niecza todo 'Match object in $/ after match in void context'
    isa_ok $/, 'Match', 'Match object in $/ after match in void context';
    is $/, 'RT', 'Matched as intended in void context';
}

# RT #70003
{
    'abc' ~~ /a/;
    is ($/.orig).rindex('a'), 0, 'rindex() works on $/.orig';
    is ($/.orig).rindex('a', 2), 0, 'rindex() works on $/.orig';
}

# RT #71362
#?rakudo skip 'binding to $/'
{
    $/ := 'foobar';
    is $0, 'foobar', '$0 works like $/[0], even for non-Match objects';
    nok $1.defined, '$1 is not defined';
}

# RT #72956
#?rakudo skip 'binding to $/'
{
    $/ := Any;
    lives_ok { $0 },
        '$0 accessible when $/ is undefined';
    ok $0 === Any,
        '$0 is Any when $/ is undefined';
    nok $0.defined, '$0 is undefined';
}

# RT #77160
{
    ok 'abc' ~~ /(.)+/, 'regex sanity';
    my $x = 0;
    $x++ for $/.list;
    #?rakudo todo 'nom regression'
    is $x, 1, '$/.list does not flatten quantified subcaptures';

    ok 'abc' ~~ /(.)**2 (.)/, 'regex sanity';
    $x = 0;
    $x++ for $/.list;
    #?rakudo todo 'nom regression'
    is $x, 2, '$/.list does not flattens subcaptures';
}

# RT 74180
{
    my $s;
    try { $s = eval '"foo" ~~ /(foo)/; "$0a"' };
    ok not $!, 'alphabetic characters can follow digits in $0 variable in interpolation';
    is $s, 'fooa', 'alphabetic characters follows $0 interpolated value';
}

# L

# RT 117461
{
    ok "a \n \b \n c \n d" ~~ /a .* c/, "match multiple lines with '.'";
    ok $/.can('lines'), "Match has a .lines method";
    is +$/.lines, 3, "Correct number of lines";
    isa_ok $/, Cool, "Match is Cool";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-match/make.t0000664000175000017500000000075212224265625016555 0ustar  moritzmoritzuse v6;
use Test;

plan 3;

# should be: L reduction using the C function">
# L

# L

"blah foo blah" ~~ / foo                 # Match 'foo'
                      { make 'bar' }     # But pretend we matched 'bar'
                    /;
ok($/, 'matched');
is($(), 'bar');
is $/.ast, 'bar', '$/.ast';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-match/non-capturing.t0000664000175000017500000000172212224265625020422 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/noncap.t.

=end pod

# L

plan 9;

my $str = "abbbbbbbbc";

ok($str ~~ m{a(b+)c}, 'Matched 1');
ok($/, 'Saved 1');
is($/, $str, 'Grabbed all 1');
is($/[0], substr($str,1,*-1), 'Correctly captured 1');

ok($str ~~ m{a[b+]c}, 'Matched 2');
ok($/, 'Saved 2');
is($/, $str, 'Grabbed all 2');
ok(!defined($/[0]), "Correctly didn't capture 2");

{
    # this used to be a regression on pugs with external parrot
    # some regex matched failed when other named regexes where
    # present, but not used.
    # moved here from t/xx-uncategoritzed/rules_with_embedded_parrot.t 
    
    my rule abc {abc}

    my rule once {<&abc>}

    my rule mumble {}

    ok("abcabcabcabcd" ~~ m/<&once>/, 'Once match');
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-match/perl.t0000664000175000017500000000234312224265625016600 0ustar  moritzmoritzuse v6;
use Test;
plan 10;

# tests for Match.perl

# the simplest tests are just that it lives, which isn't always the case
# for early implementations. In particular there were some Rakudo 
# regressions, like RT #63904 and RT #64944	

grammar ExprT1 {
    rule TOP { ^ \d+ [  \d+ ]* }
    token operator { '/' | '*' | '+' | '-' };
};

my $m = ExprT1.parse('2 + 4');
ok $m, 'Regex matches (1)';
lives_ok { $m.perl }, '$/.perl lives (with named captures';
#?niecza skip 'No value for parameter $a in is_deeply'
is_deeply eval($m.perl), $m, '... and it reproduces the right thing (1)'; 
#?niecza todo 'empty result'
is ~eval($m.perl)., '+', ' right result (2)';

my regex f { f };
my regex o { o };
ok "foo" ~~ / + /, 'Regex matches (2)';
lives_ok { $/.perl }, 'lives on quantified named captures';

# RT #64874
#?rakudo skip ''
#?niecza skip 'Cannot dispatch to a method on GLOBAL::Perl6::Grammar'
{
    my $code_str = 'say ';
    $code_str ~~ //;

    isa_ok $/, Match;
    is $/.ast, $code_str, 'Match.ast is the code matched';
    is $/.Str, $code_str, 'Match.Str is the code matched';
    is_deeply eval($/.perl), $/, 'eval of Match.perl recreates Match';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-match/positions.t0000664000175000017500000000133612224265625017666 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/pos.t.

=end pod

plan 10;

#?pugs emit force_todo(2,4,6,8,9);

my $str = "abrAcadAbbra";

ok($str ~~ m/ a .+ A /, 'Match from start');
is($/.from , 0,        'Match.from is 0');
is($/.to   , 8,        'Match.to is 7');
is($/.chars, 8,        'Match.chars');

ok($str ~~ m/ A .+ a /, 'Match from 3');
ok($/.from == 3,        'Match.from is 3');

my regex Aa { A .* a }
ok($str ~~ m/ .*?  /, 'Subrule match from 3');
ok($/.from == 0,          'Full match pos is 0');
ok($/.from == 3,      'Subrule match pos is 3');

is ('abc' ~~ /\d+/), Nil, 'Failed match returns Nil';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metachars/closure.t0000664000175000017500000000231112224265625020160 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/codevars.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

# L

plan 12;

{
    my $x = 3;
    my $y = 2;
    ok 'a' ~~ /. { $y = $x; 0 }/, 'can match and execute a closure';
    is $y, 3, 'could access and update outer lexicals';
}

#?rakudo skip 'assignment to match variables (dubious)'
#?niecza skip 'assigning to readonly value'
{
    ok("abc" ~~ m/a(bc){$ = $0}/, 'Inner match');
    is(~$/, "bc", 'Inner caught');
}

my $caught = "oops!";
ok("abc" ~~ m/a(bc){$caught = $0}/, 'Outer match');
is($caught, "bc", 'Outer caught');

#?rakudo skip 'assignment to match variables (dubious)'
#?niecza skip 'assigning to readonly value'
{
    ok("abc" ~~ m/a(bc){$0 = uc $0}/, 'Numeric match');
    is($/, "abc", 'Numeric matched');
    is($0, "BC", 'Numeric caught');
}

#?rakudo skip 'make() inside closure'
{
    ok("abc" ~~ m/a(bc){make uc $0}/ , 'Zero match');
    #?niecza todo
    is($($/), "BC", 'Zero matched');
    is(~$0, "bc", 'One matched');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metachars/line-anchors.t0000664000175000017500000000235412224265625021075 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/anchors.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

# L

plan 19;

my $str = q{abc
def
ghi};

#?pugs todo
ok(   $str ~~ m/^abc/, 'SOS abc' );
ok(!( $str ~~ m/^bc/ ), 'SOS bc' );
#?pugs todo
ok(   $str ~~ m/^^abc/, 'SOL abc' );
ok(!( $str ~~ m/^^bc/ ), 'SOL bc' );
#?pugs todo
ok(   $str ~~ m/abc\n?$$/, 'abc newline EOL' );
#?pugs todo
ok(   $str ~~ m/abc$$/, 'abc EOL' );
ok(!( $str ~~ m/ab$$/ ), 'ab EOL' );
ok(!( $str ~~ m/abc$/ ), 'abc EOS' );
ok(!( $str ~~ m/^def/ ), 'SOS def' );
#?pugs todo
ok(   $str ~~ m/^^def/, 'SOL def' );
#?pugs todo
ok(   $str ~~ m/def\n?$$/, 'def newline EOL' );
#?pugs todo
ok(   $str ~~ m/def$$/, 'def EOL' );
ok(!( $str ~~ m/def$/ ), 'def EOS' );
ok(!( $str ~~ m/^ghi/ ), 'SOS ghi' );
#?pugs todo
ok(   $str ~~ m/^^ghi/, 'SOL ghi' );
#?pugs todo
ok(   $str ~~ m/ghi\n?$$/, 'ghi newline EOL' );
#?pugs todo
ok(   $str ~~ m/ghi$$/, 'ghi EOL' );
#?pugs todo
ok(   $str ~~ m/ghi$/, 'ghi EOS' );
#?pugs todo
ok(   $str ~~ m/^abc$$\n^^d.*f$$\n^^ghi$/, 'All dot' );

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metachars/newline.t0000664000175000017500000000165512224265625020157 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/newline.t.

=end pod

plan 15;

# L

#?pugs todo
ok("\n" ~~ m/\n/, '\n');

#?pugs todo
ok("\o15\o12" ~~ m/\n/, 'CR/LF');
#?pugs todo
ok("\o12" ~~ m/\n/, 'LF');
#?pugs todo
ok("a\o12" ~~ m/\n/, 'aLF');
#?pugs todo
ok("\o15" ~~ m/\n/, 'CR');
#?pugs todo
ok("\x85" ~~ m/\n/, 'NEL');
#?pugs todo
#?rakudo.parrot todo 'Unicode'
ok("\x2028" ~~ m/\n/, 'LINE SEP');

ok(!( "abc" ~~ m/\n/ ), 'not abc');

ok(!( "\n" ~~ m/\N/ ), 'not \n');

ok(!( "\o12" ~~ m/\N/ ), 'not LF');
ok(!( "\o15\o12" ~~ m/\N/ ), 'not CR/LF');
ok(!( "\o15" ~~ m/\N/ ), 'not CR');
ok(!( "\x85" ~~ m/\N/ ), 'not NEL');
#?rakudo.parrot todo 'Unicode'
ok(!( "\x2028" ~~ m/\N/ ), 'not LINE SEP');

#?pugs todo
ok("abc" ~~ m/\N/, 'abc');


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metachars/tilde.t0000664000175000017500000000577512224265625017626 0ustar  moritzmoritzuse v6;
use Test;

plan 26;

# L

my regex t1 {
    '(' ~ ')' 'ab'
}

ok 'c(ab)d' ~~ m/<&t1>/, 'Can work with ~ and constant atoms (match)';
ok 'ab)d'  !~~ m/<&t1>/, '~ and constant atoms (missing opening bracket)';
ok '(a)d'  !~~ m/<&t1>/, '~ and constant atoms (wrong content)';
# this shouldn't throw an exception. See here:
# http://irclog.perlgeek.de/perl6/2009-01-08#i_816425
#?rakudo skip 'should not throw exceptions'
#?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
ok 'x(ab'  !~~ m/<&t1>/,  '~ and constant atoms (missing closing bracket)';

{
    my regex recursive {
        '(' ~ ')' [ 'a'* <&recursive>* ]
    };

    ok '()'     ~~ m/^ <&recursive> $/, 'recursive "()"';
    ok '(a)'    ~~ m/^ <&recursive> $/, 'recursive "(a)"';
    ok '(aa)'   ~~ m/^ <&recursive> $/, 'recursive "(aa)"';
    ok '(a(a))' ~~ m/^ <&recursive> $/, 'recursive "(a(a))"';
    ok '(()())' ~~ m/^ <&recursive> $/, 'recursive "(()())"';
    #?rakudo 4 skip 'should not throw exceptions'
    #?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
    ok '('     !~~ m/^ <&recursive> $/, '"(" is not matched';
    #?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
    ok '(()'   !~~ m/^ <&recursive> $/, '"(()" is not matched';
    #?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
    ok '())'   !~~ m/^ <&recursive> $/, '"())" is not matched';
    ok 'a()'   !~~ m/^ <&recursive> $/, '"a()" is not matched';
}

{
    my regex m1 { '(' ~ ')' <&m2> };
    my regex m2 { a* <&m1>*       };

    ok '()'     ~~ m/^ <&m1> $/, 'mutually recursive "()"';
    ok '(a)'    ~~ m/^ <&m1> $/, 'mutually recursive "(a)"';
    ok '(aa)'   ~~ m/^ <&m1> $/, 'mutually recursive "(aa)"';
    ok '(a(a))' ~~ m/^ <&m1> $/, 'mutually recursive "(a(a))"';
    ok '(()())' ~~ m/^ <&m1> $/, 'mutually recursive "(()())"';
    #?rakudo 3 skip 'exceptions from regexes'
    #?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
    ok '('     !~~ m/^ <&m1> $/, '"(" is not matched';
    #?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
    ok '(()'   !~~ m/^ <&m1> $/, '"(()" is not matched';
    #?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
    ok '())'   !~~ m/^ <&m1> $/, '"())" is not matched';
    ok 'a()'   !~~ m/^ <&m1> $/, '"a()" is not matched';
}

#?rakudo skip 'backtracking into ~'
#?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
{
    my regex even_a { ['a' ~ 'a' <&even_a> ]? };
    ok 'aaaa' ~~ m/^ <&even_a> $ /, 'backtracking into tilde rule (1)';
    ok 'aaa' !~~ m/^ <&even_a> $ /, 'backtracking into tilde rule (2)';
}

#?rakudo skip 'backtracking to find ~ goal'
#?niecza skip 'Unable to resolve method FAILGOAL in class Cursor'
{
    my regex even_b { 'a' ~ 'a' <&even_b>? };
    ok 'aaaa' ~~ m/^ <&even_b> /, 'tilde regex backtracks to find its goal';
    ok 'aaa' !~~ m/^ <&even_b> /, '...and fails for odd numbers';
}  

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/angle-brackets.t0000664000175000017500000002560312224265625021625 0ustar  moritzmoritzuse v6;
use Test;

plan 80;

=begin pod

This file attempts to cover all the possible variants in regexes that use the
<...> syntax. They are listed in the same order as they are defined in S05.

Other files may have more comprehensive tests for a specific form (such as the
character classes), and those are referenced at the correct spot.

=end pod

# L >>)/>

# tests for the simpler parts of <...> syntax in regexes

# the first character is whitespace
{
    is('aaaaa' ~~ /< a aa aaaa >/, 'aaaa', 'leading whitespace quotes words (space)');
    is('aaaaa' ~~ /<	a aa aaaa >/, 'aaaa', 'leading whitespace quotes words (tab)');

    eval_dies_ok('"aaaa" ~~ //', '<...> without whitespace calls a function (not quote words)');
    
    is('hello' ~~ /< hello >/, 'hello', 'degenerate case of quote list');
}

# A leading alphabetic character means it's a capturing grammatical assertion
{
    is('moose'  ~~ //, 'm', 'capturing grammatical assertion (1)');
    is('1a2b3c' ~~ //, 'a', 'capturing grammatical assertion (2)');
}

{
    my regex with-dash { '-' }
    ok '-'  ~~ //, 'can call regexes which dashes (positive)';
    ok '|' !~~ //, 'can call regexes which dashes (negative)';

    my regex with'hyphen { a }
    ok 'a'  ~~ //, 'can call regex with hypen (positive)';
    ok 'b' !~~ //, 'can call regex with hypen (negative)';
}

# so if the first character is a left parenthesis, it really is a call
#?rakudo skip ' not implemented'
#?niecza skip 'Unable to resolve method test in class Cursor'
{
    my $pass = 0;
    my sub test (Int $a = 1) {$pass += $a}
    '3.14' ~~ /3 /;
    ok($pass, 'function call (no arguments)');
}

#?rakudo skip ' not implemented'
#?niecza skip 'Unable to resolve method test in class Cursor'
{
    my $pass = 0;
    my sub test (Int $a) {$pass += $a}
    '3.14' ~~ /3 /;
    ok($pass, 'function call (with arguments)');
}

# If the first character after the identifier is an =,
# then the identifier is taken as an alias for what follows
{
    ok 'foo' ~~ //, 'basic  aliasing';
    is $, 'f', 'alias works';
    is $, 'f', 'alias does not throw away original name';
}

{
    ok 'foo' ~~ //, 'basic  aliasing';
    is $, 'f', 'alias works';
    ok !defined($), 'alias does throw away original name';
}

{
    ok '123gb' ~~ /  /, '';
    is $, 'g', '=. renaming worked';
    nok $.defined, '=. removed the old capture name';
}

# If the first character after the identifier is whitespace, the subsequent
# text (following any whitespace) is passed as a regex
#?rakudo skip 'angle quotes in regexes'
#?niecza skip 'Unable to resolve method test in class Cursor'
{
    my $is_regex = 0;
    my sub test ($a) {$is_regex++ if $a ~~ Regex}

    'whatever' ~~ /w < test hat >/;
    ok($is_regex, 'text passed as a regex (1)');

    $is_regex = 0;
    'whatever' ~~ /w '>/;
    ok($is_regex, 'more complicated text passed as a regex (2)');
}

# If the first character is a colon followed by whitespace the
# rest of the text is taken as a list of arguments to the method
#?rakudo skip 'colon arguments not implemented'
#?niecza skip 'Unable to resolve method test in class Cursor'
{
    my $called_ok = 0;
    my sub test ($a, $b) {$called_ok++ if $a && $b}

    'some text' ~~ /some /;
    ok($called_ok, 'method call syntax in <...>');
}

# No other characters are allowed after the initial identifier.
{
    eval_dies_ok('"foo" ~~ //', 'no other characters are allowed (*)');
    eval_dies_ok('"foo" ~~ //', 'no other characters are allowed (|)');
    eval_dies_ok('"foo" ~~ //', 'no other characters are allowed (&)');
    eval_dies_ok('"foo" ~~ //', 'no other characters are allowed (:)');
}

# L >>)/explicitly calls a method as a subrule>
{
    is('blorg' ~~ /<.alpha>/, 'b', 'leading . prevents capturing');
}

# If the dot is not followed by an identifier, it is parsed as
# a "dotty" postfix of some type, such as an indirect method call
#?niecza todo '<.$foo> syntax placeholder'
{
    # placeholder test for <.$foo>
    lives_ok({
        my $method = 'WHAT';
        'foo bar baz' ~~ /foo <.$method>/;
    }, '<.$foo> syntax placeholder');
}

# A leading $ indicates an indirect subrule. The variable must contain
# either a Regex object, or a string to be compiled as the regex.
{
    my $rule = rx/bar/;
    my $str  = 'qwe';
    ok('bar' ~~ /<$rule>/, '<$whatever> subrule (Regex, 1)');
    ok('qwer' ~~ /<$str>/, '<$whatever> subrule (String, 1)');

    is('abar' ~~ /a<$rule>/, 'abar', '<$whatever> subrule (Regex, 2)');
    is('qwer' ~~ /<$str>r/, 'qwer', '<$whatever> subrule (String, 2)');
}

# A leading :: indicates a symbolic indirect subrule
#?rakudo skip 'indirect subrule call not implemented'
{
    my $name = 'alpha';
    ok('abcdef' ~~ /<::($name)>/, '<::($name)> symbolic indirect subrule');
}

# A leading @ matches like a bare array except that each element is
# treated as a subrule (string or Regex object) rather than as a literal
{
    my @first = ;
    ok('dddd' ~~ /<@first>/, 'strings are treated as a subrule in <@foo>');

    my @second = rx/\.**2/, rx/'.**2'/;
    #?rakudo todo 'array interpolation into regexes'
    ok('abc.**2def' ~~ /<@second>/, 'Regexes are left alone in <@foo> subrule');
}

# A leading % matches like a bare hash except that
# a string value is always treated as a subrule
#?rakudo todo '<%hash> not implemented'
#?niecza skip 'Sigil % is not allowed for regex assertions'
{
    my %first = {'' => '', 'b' => '', 'c' => ''};
    ok('aeiou' ~~ /<%first>/, 'strings are treated as a subrule in <%foo>');

    my %second = {rx/\.**2/ => '', rx/'.**2'/ => ''};
    ok('abc.**2def' ~~ /<%second>/, 'Regexes are left alone in <%foo> subrule');
}

# A leading { indicates code that produces a regex to be
# interpolated into the pattern at that point as a subrule:
{
    ok('abcdef' ~~ /<{''}>/, 'code interpolation');
}

# A leading & interpolates the return value of a subroutine call as a regex.
#?rakudo skip '<&foo()> not implemented'
#?niecza skip 'Anonymous submatch returned a Str instead of a Cursor, violating the submatch protocol'
{
    my sub foo {return ''}
    ok('abcdef' ~~ /<&foo()>/, 'subroutine call interpolation');
}

# If it is a string, the compiled form is cached with the string so that
# it is not recompiled next time you use it unless the string changes.
#?rakudo skip '<$subrule> not implemented'
{
    my $counter = 0;
    my $subrule = '{$counter++; \'\'}';

    'abc' ~~ /<$subrule>/;
    is($counter, 1, 'code inside string was executed');

    'def' ~~ /<$subrule>/;
    #?niecza todo "string value was cached"
    is($counter, 1, 'string value was cached');
}

# A leading ?{ or !{ indicates a code assertion
{
    ok('192' ~~ /(\d**3) /, ' works');
    ok(!('992' ~~ /(\d**3) /), ' works');
    ok(!('192' ~~ /(\d**3) /), ' works');
    ok('992' ~~ /(\d**3) /, ' works');
}

# A leading [ indicates an enumerated character class
# A leading - indicates a complemented character class
# A leading + may also be supplied
# see charset.t

# The special assertion <.>
# see combchar.t

# L >>)/A leading ! indicates a negated meaning (always a zero-width assertion)>
{
    ok('1./:"{}=-' ~~ /^[ .]+$/, ' matches non-letter characters');
    ok(!('abcdef'   ~~ /./), ' does not match letter characters');
    is(+('.2 1' ~~ / \d/), 1, '');
    is +$/.caps, 0, ' does not capture';
}

# A leading ? indicates a positive zero-width assertion
{
    is(~('123abc456def' ~~ /(.+? )/), '123', 'positive zero-width assertion');
}

# The <...>, , and  special tokens have the same "not-defined-yet"
# meanings within regexes that the bare elipses have in ordinary code
#?niecza skip 'Action method assertion:sym not yet implemented'
{
    eval_dies_ok('"foo" ~~ /<...>/', '<...> dies in regex match');
    # XXX: Should be warns_ok, but we don't have that yet
    lives_ok({'foo' ~~ //}, ' lives in regex match');
    #?rakudo todo '!!! in regexes'
    eval_dies_ok('"foo" ~~ //', ' dies in regex match');
}

# A leading * indicates that the following pattern allows a partial match.
# It always succeeds after matching as many characters as possible.
#?rakudo skip '<*literal>'
#?niecza skip 'Action method assertion:sym<*> not yet implemented'
{
    is(''    ~~ /^ <*xyz> $ /, '',    'partial match (0)');
    is('x'   ~~ /^ <*xyz> $ /, 'x',   'partial match (1a)');
    is('xz'  ~~ /^ <*xyz> $ /, 'x',   'partial match (1b)');
    is('yzx' ~~ /^ <*xyz> $ /, 'x',   'partial match (1c)');
    is('xy'  ~~ /^ <*xyz> $ /, 'xy',  'partial match (2a)');
    is('xyx' ~~ /^ <*xyz> $ /, 'xy',  'partial match (2a)');
    is('xyz' ~~ /^ <*xyz> $ /, 'xyz', 'partial match (3)');

    is('abc'   ~~ / ^ <*ab+c> $ /,   'abc',   'partial match with quantifier (1)');
    is('abbbc' ~~ / ^ <*ab+c> $ /,   'abbbc', 'partial match with quantifier (2)');
    is('ababc' ~~ / ^ <*'ab'+c> $ /, 'ababc', 'partial match with quantifier (3)');
    is('aba'   ~~ / ^ <*'ab'+c> $ /, 'ababc', 'partial match with quantifier (4)');
}

# A leading ~~ indicates a recursive call back into some or all of the
# current rule. An optional argument indicates which subpattern to re-use
#?niecza skip 'Action method assertion:sym<~~>'
{
    ok('1.2.' ~~ /\d+\. <~~> | /, 'recursive regex using whole pattern');
    #?rakudo skip '<~~ ... >'
    ok('foodbard' ~~ /(foo|bar) d <~~0>/, 'recursive regex with partial pattern');
}

# The following tokens include angles but are not required to balance

# A <( token indicates the start of a result capture,
# while the corresponding )> token indicates its endpoint
{
    is('foo123bar' ~~ /foo <(\d+)> bar/, 123, '<(...)> pair');
    is('foo456bar' ~~ /foo <(\d+ bar/, '456bar', '<( match');
    is('foo789bar' ~~ /foo \d+)> bar/, 'foo789', ')> match');
    ok(!('foo123' ~~ /foo <(\d+)> bar/), 'non-matching <(...)>');

    is('foo123bar' ~~ /foo <( bar || ....../, 'foo123', '<( in backtracking');
    #?niecza todo
    is('foo123bar' ~~ /foo <( 123 <( bar/, 'bar', 'multiple <(');
    is('foo123bar' ~~ /foo <( 123 [ <( xyz ]?/, '123', 'multiple <( backtracking');
}

# A « or << token indicates a left word boundary.
# A » or >> token indicates a right word boundary.
{
   is('abc'   ~~ /<>/,   'abc', 'right word boundary (string end)');
   is('abc!'  ~~ /abc>>/,   'abc', 'right word boundary (\W character)');
   is('!abc!' ~~ /<>/, 'abc', 'both word boundaries (\W character)');
}

done();

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/assertions.t0000664000175000017500000000110412224265625021123 0ustar  moritzmoritzuse v6;

use Test;

plan 4;

# L >>)"/indicates a code assertion:>

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/assert.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

ok("1"       ~~ m/ (\d)  /,           '1 < 5');
ok("5"      !~~ m/ (\d) /,       '5 !< 5');

ok("x254"    ~~ m/x (\d+):  /, '254 < 255');
ok("x255"   !~~ m/x (\d+):  /, '255 !< 255');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/changed.t0000664000175000017500000000214212224265625020325 0ustar  moritzmoritzuse v6;
use Test;

plan 12;

# L

{
    # A dot . now matches any character including newline.
    my $str = "abc\ndef";
    #?pugs todo
    ok($str ~~ /./,   '. matches something');
    #?pugs todo
    ok($str ~~ /c.d/, '. matches \n');
    
    # ^ and $ now always match the start/end of a string, like the old \A and \z.
    #?pugs todo
    ok($str ~~ /^abc/, '^ matches beginning of string');
    ok(!($str ~~ /^de/), '^ does not match \n');
    #?pugs todo
    ok($str ~~ /def$/, '$ matches end of string');
    ok(!($str ~~ /bc$/), '$ does not match \n');
    
    # (The /m modifier is gone.)
    eval_dies_ok('$str ~~ m:m/bc$/', '/m modifier (as :m) is gone');
}

# A $ no longer matches an optional preceding \n
{
    my $str = "abc\ndef\n";
    #?pugs todo
    ok($str ~~ /def\n$/, '\n$ matches as expected');
    ok(!($str ~~ /def$/),  '$ does not match \n at end of string');
}

# The \A, \Z, and \z metacharacters are gone.
#?pugs todo
{
    eval_dies_ok('/\A/', '\\A is gone');
    eval_dies_ok('/\Z/', '\\Z is gone');
    eval_dies_ok('/\z/', '\\z is gone');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/charset.t0000664000175000017500000000722312224265625020372 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/charset.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 41;

# Broken:
# L >>)/"A leading [ ">

#?pugs todo
ok("zyxaxyz" ~~ m/(<[aeiou]>)/, 'Simple set');
#?pugs todo
is($0, 'a', 'Simple set capture');

# L >>)/"A leading - indicates">
ok(!( "a" ~~ m/<-[aeiou]>/ ), 'Simple neg set failure');
#?pugs todo
ok("f" ~~ m/(<-[aeiou]>)/, 'Simple neg set match');
#?pugs todo
is($0, 'f', 'Simple neg set capture');

# L >>)/Character classes can be combined>
ok(!( "a" ~~ m/(<[a..z]-[aeiou]>)/ ), 'Difference set failure');
#?pugs todo
ok("y" ~~ m/(<[a..z]-[aeiou]>)/, 'Difference set match');
#?pugs todo
is($0, 'y', 'Difference set capture');

# RT #115802
#?pugs todo
ok(  "abc" ~~ m/<[\w]-[\n]>/,  'Difference set match 1');
ok(!("abc" ~~ m/<[\w]-[\N]>/), 'Difference set match 2');
#?pugs todo
is(("abc123" ~~ m/<[\w]-[a\d]>+/), 'bc', 'Difference set match 3');
#?pugs todo
is(("abc123" ~~ m/<[\w]-[1\D]>+/), '23', 'Difference set match 4');
#?pugs todo
#?niecza todo 'gives c123?'
is(("abc123def" ~~ m/<[\w]-[\D\n]>+/), '123', 'Difference set match 5');
#?pugs todo
is(("abc123def" ~~ m/<[\w]-[\D\h]>+/), '123', 'Difference set match 6');
#?pugs todo
is(("abc" ~~ /<-["\\\t\n]>+/), 'abc', 'Difference set match 7');

ok(!( "a" ~~ m/(<+alpha-[aeiou]>)/ ), 'Named difference set failure');
#?pugs todo
ok("y" ~~ m/(<+alpha-[aeiou]>)/, 'Named difference set match');
#?pugs todo
is($0, 'y', 'Named difference set capture');
ok(!( "y" ~~ m/(<[a..z]-[aeiou]-[y]>)/ ), 'Multi-difference set failure');
#?pugs todo
ok("f" ~~ m/(<[a..z]-[aeiou]-[y]>)/, 'Multi-difference set match');
#?pugs todo
is($0, 'f', 'Multi-difference set capture');

#?pugs todo
ok(']' ~~ m/(<[\]]>)/, 'quoted close LSB match');
#?pugs todo
is($0, ']', 'quoted close LSB capture');
#?pugs todo
ok('[' ~~ m/(<[\[]>)/, 'quoted open LSB match');
#?pugs todo
is($0, '[', 'quoted open LSB capture');
#?pugs todo
ok('{' ~~ m/(<[\{]>)/, 'quoted open LCB match');
#?pugs todo
is($0, '{', 'quoted open LCB capture');
#?pugs todo
ok('}' ~~ m/(<[\}]>)/, 'quoted close LCB match');
#?pugs todo
is($0, '}', 'quoted close LCB capture');

# RT #67124
eval_lives_ok( '"foo" ~~ /<[f] #`[comment] + [o]>/',
               'comment embedded in charset can be parsed' );
#?pugs todo
ok( "foo" ~~ /<[f] #`[comment] + [o]>/, 'comment embedded in charset works' );

# RT #67122
#?rakudo skip 'large \\x char spec in regex (RT #67122) (noauto)'
#?pugs todo
ok "\x[10001]" ~~ /<[\x10000..\xEFFFF]>/, 'large \\x char spec';

#?niecza todo
#?pugs todo
eval_dies_ok( "'RT 71702' ~~ /<[d..b]>? RT/",
    'reverse range in charset is lethal (RT 71702)' );

# RT #64220
#?pugs todo
ok 'b' ~~ /<[. .. b]>/, 'weird char class matches at least its end point';

# RT #69682
#?pugs todo
{
try { eval "/<[a-z]>/"; }
ok ~$! ~~ / 'Unsupported use of - as character range; in Perl 6 please use ..'/,
    "STD error message for - as character range";
}

#?pugs todo
ok 'ab' ~~ /^(.*) b/,
    'Quantifiers in capture groups work (RT 100650)';

# RT #74012
# backslashed characters in char classes
#?pugs todo
ok '[]\\' ~~ /^ <[ \[ .. \] ]>+ $ /, 'backslashed chars in char classes';
nok '^'   ~~ /  <[ \[ .. \] ]>    /, '... does not match outside its range';

# RT #89470
{
    nok  '' ~~ / <[a..z]-[x]> /, 'Can match empty string against char class';
    nok 'x' ~~ / <[a..z]-[x]> /, 'char excluded from class';
    #?pugs todo
     ok 'z' ~~ / <[a..z]-[x]> /, '... but others are fine';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/combchar.t0000664000175000017500000000112012224265625020505 0ustar  moritzmoritzuse v6;

use Test;

# L >>)/matches any logical grapheme>

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/combchar.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 3;

my $unichar = "\c[GREEK CAPITAL LETTER ALPHA]";
my $combchar = "\c[LATIN CAPITAL LETTER A]\c[COMBINING ACUTE ACCENT]";

#?pugs todo 'feature'
ok("A" ~~ m/^<.>$/, 'ASCII');
ok($combchar ~~ m/^<.>$/, 'Unicode combining');
ok($unichar ~~ m/^<.>$/, 'Unicode');


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/delimiters.t0000664000175000017500000000116312224265625021077 0ustar  moritzmoritz
use Test;

plan 21;

# L

my @delims = < ^ ° ! " § $ % @ € & / = ? ` * + ~ ; , . | >;
my %todo;

#?niecza emit %todo = < ? 1 * 1 + 1 ~ 1 >;

for @delims -> $d {
    my $ok  = try { eval("my \$x = 'abc'; \$x ~~ m{$d}b{$d}") };
    my $nok = try { eval("my \$x = 'abc'; \$x ~~ m{$d}d{$d}") };
    my $is  = try { eval("my \$x = 'abc'; \$x ~~ s{$d}a{$d}b{$d}; \$x") } eq 'bbc';
    
    todo "$d not yet supported" if %todo{$d};
    ok $ok && !$nok && $is, "$d as delimiter in match and substitution";
}
rakudo-2013.12/t/spec/S05-metasyntax/interpolating-closure.t0000664000175000017500000000164012224265625023267 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/rulecode.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 6;

# L >>)/unambiguously calls a routine instead>

my regex abc { a b c }

my $var = "";
ok("aaabccc" ~~ m/aa <{ $var ?? $var !! rx{abc} }> cc/, 'Rule block second');

$var = rx/<&abc>/;
ok("aaabccc" ~~ m/aa <{ $var ?? $var !! rx{<.null>} }> cc/, 'Rule block first');

$var = rx/xyz/;
#?rakudo todo 'dunno'
#?niecza todo 'dunno'
ok("aaabccc" !~~ m/aa <{ $var ?? $var !! rx{abc} }> cc/, 'Rule block fail');

$var = rx/<&abc>/;
ok("aaabccc" ~~ m/aa <{ $var ?? $var !! rx{abc} }> cc/, 'Rule block interp');

# RT #102860
ok 'abc' ~~ /<{ '.+' }>/, 'interpolating string with meta characters';
is $/.Str, 'abc', '... gives the right match';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/litvar.t0000664000175000017500000000420512224265625020237 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/litvar.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 22;

# L

my $var = "a*b";
my @var = ;
my $aref = \@var;


# SCALARS

# just document ticket test below
#?pugs 2 todo 'bug'
ok($var ~~ m/$var/, 'Simple scalar interpolation');
ok("zzzzzz{$var}zzzzzz" ~~ m/$var/, 'Nested scalar interpolation');
ok(!( "aaaaab" ~~ m/$var/ ), 'Rulish scalar interpolation');

#?pugs 5 todo 'feature'
ok(!('a0' ~~ m/$aref[0]/), 'Array ref stringifies before matching'); #OK
#?niecza todo
ok('a b ab c0' ~~ m/$aref[0]/, 'Array ref stringifies before matching'); #OK
ok('a0' ~~ m/@$aref[0]/, 'Array deref ignores 0');                 #OK
ok('bx0' ~~ m/@$aref.[0]/, 'Array deref ignores dot 0');           #OK
ok('c0' ~~ m/@var[0]/, 'Array ignores 0');                         #OK


# ARRAYS
# L

#?pugs 3 todo 'feature'
ok("a" ~~ m/@var/, 'Simple array interpolation (a)');
ok("b" ~~ m/@var/, 'Simple array interpolation (b)');
ok("c" ~~ m/@var/, 'Simple array interpolation (c)');
ok(!( "d" ~~ m/@var/ ), 'Simple array interpolation (d)');
#?pugs 2 todo 'feature'
ok("ddddaddddd" ~~ m/@var/, 'Nested array interpolation (a)');

ok("abca" ~~ m/^@var+$/, 'Multiple array matching');
ok(!( "abcad" ~~ m/^@var+$/ ), 'Multiple array non-matching');

#?pugs 3 todo 'feature'
is("abc" ~~ m/ @var /,     'ab', 'Array using implicit junctive semantics');
is("abc" ~~ m/ | @var /,   'ab', 'Array using explicit junctive semantics');
#?niecza todo "sequential semantics NYI"
is("abc" ~~ m/ || @var /,  'a',  'Array using explicit sequential semantics');

# contextializer $( )

# RT 115298
#?pugs 4 todo
ok 'foobar' ~~ /$( $_ )/, '$( $_ ) will match';
is $/, 'foobar', '... $( $_ ) matched entire string';
is 'foobar' ~~ /$( $_.substr(3) )/, 'bar', 'Contextualizer with functions calls';
is 'foobar' ~~ /@(  )+/,   'ooba', '@(  )+';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/longest-alternative.t0000664000175000017500000001011512224265625022722 0ustar  moritzmoritzuse v6;
use Test;

plan 31;

#L

my $str = 'a' x 7;

{
    ok $str ~~ m:c(0)/a|aa|aaaa/, 'basic sanity with |';
    is ~$/, 'aaaa', 'Longest alternative wins 1';

    ok $str ~~ m:c(4)/a|aa|aaaa/, 'Second match still works';
    is ~$/, 'aa',   'Longest alternative wins 2';

    ok $str ~~ m:c(6)/a|aa|aaaa/, 'Third match still works';
    is ~$/, 'a',    'Only one alternative left';

    ok $str !~~ m:c(7)/a|aa|aaaa/, 'No fourth match';
}

# now test with different order in the regex - it shouldn't matter at all

#?niecza skip 'Regex modifier g not yet implemented'
{
    ok $str ~~ m:c/aa|a|aaaa/, 'basic sanity with |, different order';
    is ~$/, 'aaaa', 'Longest alternative wins 1, different order';

    ok $str ~~ m:c/aa|a|aaaa/, 'Second match still works, different order';
    is ~$/, 'aa',   'Longest alternative wins 2, different order';

    ok $str ~~ m:c/aa|a|aaaa/, 'Third match still works, different order';
    is ~$/, 'a',    'Only one alternative left, different order';

    ok $str !~~ m:c/aa|a|aaaa/, 'No fourth match, different order';
}

{
    my @list = ;
    ok $str ~~ m/ @list /, 'basic sanity with interpolated arrays';
    is ~$/, 'aaaa', 'Longest alternative wins 1';

    ok $str ~~ m:c(4)/ @list /, 'Second match still works';
    is ~$/, 'aa',   'Longest alternative wins 2';

    ok $str ~~ m:c(6)/ @list /, 'Third match still works';
    is ~$/, 'a',    'Only one alternative left';

    ok $str !~~ m:c(7)/ @list /, 'No fourth match';
}

# L

{
    my token ab { 'ab' };
    my token abb { 'abb' };
    my token a_word { a \w* };
    my token word { \w+ };
    my token indirect_abb {  'b' }

    #?niecza todo 'LTM - literals in tokens'
    #?rakudo todo 'LTM - literals in tokens'
    ok ('abb' ~~ /<&ab> | <&abb> /) && ~$/ eq 'abb',
       'LTM - literals in tokens';

    #?niecza todo 'LTM - literals in nested tokens'
    #?rakudo todo 'LTM - literals in tokens'
    ok ('abb' ~~ /<&ab> | <&indirect_abb> /) && $/ eq 'abb',
       'LTM - literals in nested torkens';

    ok ('abb' ~~ /'ab' | \w+ / && $/) eq 'abb',
       'LTM - longer quantified charclass wins against shorter literal';

    #?niecza todo 'LTM - longer quantified atom wins against shorter literal (subrules)'
    #?rakudo todo 'LTM - longer quantified atom wins against shorter literal (subrules)'
    ok ('abb' ~~ /<&ab> | <&a_word> /) && $/ eq 'abb',
       'LTM - longer quantified atom wins against shorter literal (subrules)';

    ok ('abb' ~~ /  | <&word> /) && $,
       'LTM - literal wins tie against \w*';
}

#?rakudo skip ':::'
{
    # with LTM stoppers
    my token foo1 { 
        a+
        ::: # a LTM stopper
        .+
    }
    my token foo2 { \w+ }

    #?niecza todo 'LTM only participated up to the LTM stopper :::'
    ok ('aaab---' ~~ /<&foo1> |  /) && $,
       'LTM only participated up to the LTM stopper :::';
}

# LTM stopper by implicit <.ws>
#?niecza todo 'implicit <.ws> stops LTM'
#?rakudo todo 'implicit <.ws> stops LTM'
{
    my rule  ltm_ws1 {\w+ '-'+}
    my token ltm_ws2 {\w+ '-'}
    ok ('abc---' ~~ /<<m_ws1> | /) && $,
       'implicit <.ws> stops LTM';
}

{
    # check that the execution of action methods doesn't stop LTM
    grammar LTM::T1 {
        token TOP {  |  }
        token a { \w+ '-' }
        token b { a+ + }
        token c { '-' }
    }

    class LTM::T1::Action {
        has $.matched_TOP;
        has $.matched_a;
        has $.matched_b;
        has $.matched_c;
        method TOP($/) { $!matched_TOP = 1 };
        method a($/)   { $!matched_a   = 1 };
        method b($/)   { $!matched_b   = 1 };
        method c($/)   { $!matched_c   = 1 };
    }
    my $o = LTM::T1::Action.new();
    ok LTM::T1.parse('aaa---', :actions($o)), 'LTM grammar - matched';
    is ~$/, 'aaa---', 'LTM grammar - matched full string';
    # TODO: find out if $.matched_a is allowed to be set
    ok $o.matched_TOP && $o.matched_b && $o.matched_c,
       'was in the appropriate action methods';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/lookaround.t0000664000175000017500000000165012224265625021114 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/lookaround.t.

=end pod

plan 10;

#?pugs emit force_todo(1,4,9,10);

# L >>)/The special named assertions include:>

ok("a cdef" ~~ m/ c> def/, 'Lookbehind');
ok(!( "acdef" ~~ m/ c> def/ ), 'Lookbehind failure');
ok(!( "a cdef" ~~ m/ c> def/ ), 'Negative lookbehind failure');
ok("acdef" ~~ m/ c> def/, 'Negative lookbehind');

ok("abcd f" ~~ m/abc  f> (.)/, 'Lookahead');
is(~$0, 'd', 'Verify lookahead');
ok(!( "abcdef" ~~ m/abc  f>/ ), 'Lookahead failure');
ok(!( "abcd f" ~~ m/abc  f>/ ), 'Negative lookahead failure');
ok("abcdef" ~~ m/abc  f> (.)/, 'Negative lookahead');
is(~$0, 'd', 'Verify negative lookahead');


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/null.t0000664000175000017500000000073412224265625017713 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/null.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 4;

# L

ok("" ~~ m//, 'Simple null as ');
ok("" ~~ m/''/, "Simple null as ''");
ok("a" ~~ m//, 'Simple null A');

ok("ab" ~~ m{ab}, 'Compound null AB');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/prior.t0000664000175000017500000000204312224265625020067 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/prior.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

plan 11;

# L

# so rule prior matches a constant substring

ok("A" !~~ m/<.prior>/, 'No prior successful match');

#?pugs todo
ok("A" ~~ m/<[A..Z]>/, 'Successful match');

#?pugs todo
ok("ABC" ~~ m/<.prior>/, 'Prior successful match');
ok("B" !~~ m/<.prior>/, 'Prior successful non-match');

ok("C" !~~ m/B/,  'Unsuccessful match');

#?pugs todo
ok("A" ~~ m/<.prior>/, 'Still prior successful match');
#?pugs todo
ok("A" ~~ m/<.prior>/, 'And still prior successful match');

#?pugs todo
ok("BA" ~~ m/B <.prior>/, 'Nested prior successful match');
#?pugs todo
is ~$/, 'BA', 'matched all we wanted';

# now the prior match is "BA"
ok("A" !~~ m/B <.prior>/, 'Nested prior successful non-match');
ok( 'A' !~~ m/<.prior>/, 'prior target updated');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/proto-token-ltm.t0000664000175000017500000000236312224265625022014 0ustar  moritzmoritzuse v6;
use Test;

plan 10;

grammar LTM2 {
    proto token TOP {*}
    token TOP:sym { 'aa' }
    token TOP:sym { 'ab' }
    token TOP:sym { 'ac' }
    token TOP:sym { 'a' | 'i' | 'j' }
    token TOP:sym { a**4 }
    token TOP:sym { a**2 % c }
    token TOP:sym { a**3..3 % d }
    token TOP:sym { a**1..* % e }
    token TOP:sym { afafafa? %% f }
    token TOP:sym { agagagaga? % g } # last g is never tried
        token TOP:sym {
            ahahahahaha+ % h }
    token TOP:sym { i**5..6
    }
    token TOP:sym {
        j**7..* }
}

is ~LTM2.parse('aaaaaaaa'), 'aaaa', 'LTM a**4 worked';
is ~LTM2.parse('acacaca'), 'aca', 'LTM a**2 % c worked';
is ~LTM2.parse('adadadadada'), 'adada', 'LTM a**3..3 % d worked';
is ~LTM2.parse('aeaeaea'), 'aeaeaea', 'LTM a**1..* % e worked';
is ~LTM2.parse('afafafafafafa'), 'afafafaf', 'LTM afafafa? %% f worked';
is ~LTM2.parse('agagagagagagaga'), 'agagagaga', 'LTM agaagaga? % g worked';
is ~LTM2.parse('ahahahahahahahaha'), 'ahahahahahahahaha', 'LTM ahaahahaha+ % h worked';
isnt LTM2.parse('ahahahahah'), 'ahahahaha', 'LTM ahahahahaha+ % h~failed correctly';
is ~LTM2.parse('iiiiii'), 'iiiiii', 'LTM i**5..6 worked';
is ~LTM2.parse('jjjjjjjjjj'), 'jjjjjjjjjj', 'LTM j**7..* worked';
rakudo-2013.12/t/spec/S05-metasyntax/regex.t0000664000175000017500000000466612224265625020063 0ustar  moritzmoritzuse v6;
use Test;

plan 26;

eval_dies_ok('qr/foo/', 'qr// is gone');

isa_ok(rx/oo/, Regex);
isa_ok(rx (o), Regex);
eval_dies_ok('rx(o)', 'rx () whitespace if the delims are parens');
isa_ok(regex {oo}, Regex);

eval_dies_ok('rx :foo:', 'colons are not allowed as rx delimiters');

lives_ok { my Regex $x = rx/foo/ }, 'Can store regexes in typed variables';

{
    my $var = /foo/;
    isa_ok($var, Regex, '$var = /foo/ returns a Regex object');
}

# fairly directly from RT #61662
{
    $_ = "a";
    my $mat_tern_y = /a/ ?? "yes" !! "no";
    my $mat_tern_n = /b/ ?? "yes" !! "no";
    ok  $mat_tern_y eq 'yes' && $mat_tern_n eq 'no',
        'basic implicit topic match test';
}

# Note for RT - change to $_ ~~ /oo/ to fudge ok
{
    $_ = "foo";
    my $mat_tern = /oo/ ?? "yes" !! "no"; 
    is($/, 'oo', 'matching should set match');
}

{
    $_ = 'foo';
    my $match = m{oo};
    is($match, 'oo', 'm{} always matches instead of making a Regex object');
}

{

    $_ = 'foo';
    my $match = m/oo/;
    is($match, 'oo', 'm{} always matches instead of making a Regex object');
}

# we'll just check that this syntax is valid for now
#?niecza todo 'invalid syntax'
{
    eval_lives_ok('token foo {bar}', 'token foo {...} is valid');
    eval_lives_ok('regex baz {qux}', 'regex foo {...} is valid');
}

{
    my regex alien { ET };
    my token archaeologist { Indiana };
    my rule food { pasta };

    ok 'ET phone home' ~~ m//, 'named regex outside of a grammar works';
    ok 'Indiana has left the fridge' ~~ m//,
                                  'named token outside of a grammar works';
    ok 'mmm, pasta' ~~ m//, 'named rule outside of a grammar works';
}

ok Any !~~ / 'RT #67234' /, 'match against undefined does not match';

eval_dies_ok q['x' ~~ m/RT (#)67612 /], 'commented capture end = parse error';

# L

eval_dies_ok 'rx/;/',       'bare ";" in rx is not allowed';
eval_dies_ok q{';' ~~ /;/}, 'bare ";" in match is not allowed';
isa_ok rx/\;/, Regex,       'escaped ";" in rx// works';
ok ';' ~~ /\;/,             'escaped ";" in m// works';

# RT #64668
#?niecza skip 'Exception NYI'
{
    try { eval '"RT #64668" ~~ //' };
    ok  $!  ~~ Exception, 'use of missing named rule dies';
    ok "$!" ~~ /nosuchrule/, 'error message mentions the missing rule';
}

#?niecza todo 'invalid syntax'
eval_lives_ok '/<[..b]>/', '/<[..b]>/ lives';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/repeat.t0000664000175000017500000000542312237474612020223 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/repeat.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end pod

# Note: single-quotes.t tests repetition on single quoted items in regexes.

plan 24;

# L

# Exact repetition
#?pugs todo
ok("abcabcabcabcd" ~~ m/'abc'**4/, 'Fixed exact repetition');
#?pugs todo
is $/, 'abc' x 4, '...with the correct capture';
ok(!("abcabcabcabcd" ~~ m/'abc'**5/), 'Fail fixed exact repetition');
#?pugs todo force_todo
#?rakudo 2 skip 'closure repetition'
ok("abcabcabcabcd"    ~~ m/'abc'**{4}/, 'Fixed exact repetition using closure');
ok(!( "abcabcabcabcd" ~~ m/'abc'**{5}/ ), 'Fail fixed exact repetition using closure');

# Closed range repetition
#?pugs todo
ok("abcabcabcabcd" ~~ m/'abc'**2..4/, 'Fixed range repetition');
ok(!( "abc"        ~~ m/'abc'**2..4/ ), 'Fail fixed range repetition');
#?pugs todo force_todo
#?rakudo 2 skip 'closure repetition'
ok("abcabcabcabcd" ~~ m/'abc'**{2..4}/, 'Fixed range repetition using closure');
ok(!( "abc"        ~~ m/'abc'**{2..4}/ ), 'Fail fixed range repetition using closure');

# Open range repetition
#?pugs todo
ok("abcabcabcabcd" ~~ m/'abc'**2..*/, 'Open range repetition');
ok(!( "abcd"       ~~ m/'abc'**2..*/ ), 'Fail open range repetition');
#?pugs todo force_todo
#?rakudo 2 skip 'closure repetition'
ok("abcabcabcabcd" ~~ m/'abc'**{2..*}/, 'Open range repetition using closure');
ok(!( "abcd"       ~~ m/'abc'**{2..*}/), 'Fail open range repetition using closure');

# It is illegal to return a list, so this easy mistake fails:
#?pugs todo
eval_dies_ok('"foo" ~~ m/o{1,3}/', 'P5-style {1,3} range mistake is caught');
#?pugs todo
eval_dies_ok('"foo" ~~ m/o{1,}/',  'P5-style {1,} range mistake is caught');

#?pugs todo
is(~('foo,bar,baz,' ~~ m/[+]+ %  ','/), 'foo,bar,baz',  '% with a term worked');
#?pugs todo
is(~('foo,bar,baz,' ~~ m/[+]+ %% ','/), 'foo,bar,baz,', '%% with a term worked');
#?pugs todo
is(~('foo, bar,' ~~ m/[+]+ % [','\s*]/), 'foo, bar', '% with a more complex term');

ok 'a, b, c' !~~ /:s^+%\,$/, 'with no spaces around %, no spaces can be matched';
#?pugs todo
ok 'a, b, c'  ~~ /:s^  +% \, $/, 'with spaces around %, spaces can be matched';
#?pugs todo
ok 'a , b ,c' ~~ /:s^  +% \, $/, 'same, but with leading spaces';

# RT #76792
#?pugs todo
ok ('a b,c,d' ~~ token { \w \s \w+ % \, }), 'can combine % with backslash character classes';

# RT #119513
#?pugs 2 todo
#?niecza 2 todo 'underscore in quantifier numeral'
{
    ok ("a" x 1_0 ~~ /a ** 1_0/, 'underscore in quantifier numeral (1)' );
    ok ( "a_0" !~~ /a ** 1_0/, 'underscore in quantifier numeral (2)' );
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/sequential-alternation.t0000664000175000017500000000150712224265625023430 0ustar  moritzmoritzuse v6;
use Test;
plan 10;

#L

{
    my $str = 'x' x 7;

    ok $str ~~ m/x||xx||xxxx/;
    is ~$/,  'x',  'first || alternative matches';
    ok $str ~~ m/xx||x||xxxx/;
    is ~$/,  'xx', 'first || alternative matches';
}

{
    my $str = 'x' x 3;
    ok $str ~~ m/xxxx||xx||x/;
    is ~$/, 'xx', 'second alternative || matches if first fails';
}

#L

{
    my $str = 'x' x 7;
    my @list = ;

    ok $str ~~ m/ ||@list /;
    #?niecza todo 'sequential alternation NYI'
    is ~$/,  'x',  'first ||@list alternative matches';

    @list = ;

    ok $str ~~ m/ ||@list /;
    #?niecza todo 'sequential alternation NYI'
    is ~$/,  'xx', 'first ||@list alternative matches';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/single-quotes.t0000664000175000017500000000113312224265625021532 0ustar  moritzmoritzuse v6;
use Test;

=begin description

This file was derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/qinterp.t.

It has (hopefully) been, and should continue to be, updated to
be valid perl6.

=end description

plan 5;

# L


ok("ab cd" ~~ m/a 'b c' d/, 'ab cd 1');
ok(!( "abcd" ~~ m/a 'b c' d/ ), 'not abcd 1');
ok("ab cd" ~~ m/ab ' ' c d/, 'ab cd 2');

ok 'abab' ~~ m/'ab' **2/, "Single quotes group";

#?pugs skip bug
ok("ab/cd" ~~ m/ab '/' c d/, 'ab/cd');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-metasyntax/unknown.t0000664000175000017500000000210012224265625020425 0ustar  moritzmoritzuse v6;
use Test;

plan 13;

# L

# testing unknown metasyntax handling

eval_dies_ok('"aa!" ~~ /!/', '"!" is not valid metasyntax');
lives_ok({"aa!" ~~ /\!/}, 'escaped "!" is valid');
lives_ok({"aa!" ~~ /'!'/}, 'quoted "!" is valid');

eval_dies_ok('"aa!" ~~ /\a/', 'escaped "a" is not valid metasyntax');
lives_ok({"aa!" ~~ /a/}, '"a" is valid');
lives_ok({"aa!" ~~ /'a'/}, 'quoted "a" is valid');

# used to be a pugs bug

{
    my rule foo { \{ };
    ok '{'  ~~ //, '\\{ in a rule (+)';
    ok '!' !~~ //, '\\{ in a rule (-)';
}

# RT #74832
{
    dies_ok {eval('/ a+ + /')}, 'Cannot parse regex a+ +';
    #?rakudo todo 'RT 74832'
    #?niecza todo
    ok "$!" ~~ /:i quantif/, 'error message mentions quantif{y,ier}';
}

# RT #77110, #77386
#?niecza skip "throws_like"
#?DOES 3
{
    BEGIN { @*INC.push('t/spec/packages/') };
    use Test::Util;
    throws_like '$_ = "0"; s/-/1/', X::Syntax::Regex::UnrecognizedMetachar, metachar => '-';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/continue.t0000664000175000017500000000226112224265625020163 0ustar  moritzmoritzuse v6;
use Test;

plan 13;

#L

my regex simple { . a };
my $string = "1a2a3a";

{
    $string ~~ m:c/<&simple>/;
    is(~$/, '1a', "match first 'a'");
    $string ~~ m:c/<&simple>/;
    is(~$/, '2a', "match second 'a'");
    $string ~~ m:c/<&simple>/;
    is(~$/, '3a', "match third 'a'");
    $string ~~ m:c/<&simple>/;
    is(~$/, '', "no more 'a's to match");
}

{
    my $m = $string.match(/.a/);
    is(~$m, '1a', "match first 'a'");
    $m = $string.match(/.a/, :c(2));
    is(~$m, '2a', "match second 'a'");
    $m = $string.match(/.a/, :c(4));
    is(~$m, '3a', "match third 'a'");
}

# this batch not starting on the exact point, and out of order
{
    my $m = $string.match(/.a/, :c(0));
    is(~$m, '1a', "match first 'a'");
    $m = $string.match(/.a/, :c(3));
    is(~$m, '3a', "match third 'a'");
    $m = $string.match(/.a/, :c(1));
    is(~$m, '2a', "match second 'a'");
}

{
    my $m = $string.match(/.a/);
    is(~$m, '1a', "match first 'a'");
    $m = $string.match(/.a/, :continue(2));
    is(~$m, '2a', "match second 'a'");
    $m = $string.match(/.a/, :continue(4));
    is(~$m, '3a', "match third 'a'");
}

done;

# vim: syn=perl6 sw=4 ts=4 expandtab
rakudo-2013.12/t/spec/S05-modifier/counted-match.t0000664000175000017500000000462312224265625021076 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/counted.t.

=end pod

plan 22;

my $data = "f fo foo fooo foooo fooooo foooooo";

# :nth(N)...

{
    nok $data.match(/fo+/, :nth(0)), 'No match nth(0)';

    my $match = $data.match(/fo+/, :nth(1));
    ok $match, 'Match :nth(1)';
    is ~$match, 'fo', 'Matched value for :nth(1)';

    $match = $data.match(/fo+/, :nth(2));
    ok $match, 'Match :nth(2)';
    is ~$match, 'foo', 'Matched value for :nth(2)';

    $match = $data.match(/fo+/, :nth(3));
    ok $match, 'Match :nth(3)';
    is ~$match, 'fooo', 'Matched value for :nth(3)';

    $match = $data.match(/fo+/, :nth(6));
    ok $match, 'Match :nth(6)';
    is ~$match, 'foooooo', 'Matched value for :nth(6)';

    nok $data.match(/fo+/, :nth(7)), 'No match nth(7)';
}

# :nth($N)...

# for (1..6) -> $N {
#     ok($data ~~ m:nth($N)/fo+/, "Match nth(\$N) for \$N == $N" );
#     is($/, 'f'~'o' x $N, "Matched value for $N" );
# }
# 

# more interesting variations of :nth(...)
#?rakudo skip 'hangs'
#?niecza skip 'hangs'
{
    my @match = $data.match(/fo+/, :nth(2, 3)).list;
    is +@match, 2, 'nth(list) is ok';
    is @match, , 'nth(list) matched correctly';

    @match = $data.match(/fo+/, :nth(2..4)).list;
    is +@match, 3, 'nth(Range) is ok';
    is @match, , 'nth(Range) matched correctly';

    @match = $data.match(/fo+/, :nth(2, 4 ... *)).list;
    is +@match, 3, 'nth(infinite series) is ok';
    is @match, , 'nth(infinite series) matched correctly';
}

#?niecza skip 'Excess arguments to CORE Cool.match'
{
    is 'abecidofug'.match(/<[aeiou]>./, :nth(1,3,5), :x(2)).join('|'),
        'ab|id', ':x and :nth';

    nok 'abecidofug'.match(/<[aeiou]>./, :nth(1,3,5,7,9), :x(6)).join('|'),
        ':x and :nth (not matching)';

    is 'abcdefg'.match(/.*/, :nth(2,4,6,7), :x(2..3), :overlap).join('|'),
        'bcdefg|defg|fg', ':x and :nth and :overlap';

    nok 'abcdefg'.match(/.+/, :nth(2,4,6,7), :x(6..8), :overlap).join('|'),
        ':x and :nth and :overlap (not matching)'
}

# test that non-monotonic items in :nth lists are ignored
#?niecza todo
{
    is 'abacadaeaf'.match(/a./, :nth(2, 1, 4)).join(', '),
        'ac, ae', 'non-monotonic items in :nth are ignored';
}

# RT 77408
{
    dies_ok { "a" ~~ m:nth(Mu)/a/ }, ':nth does not accept Mu param';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/counted.t0000664000175000017500000001452612224265625020007 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/counted.t.

=end pod

plan 118;

# L

my $data = "f fo foo fooo foooo fooooo foooooo";
my $sub1 = "f bar foo fooo foooo fooooo foooooo";
my $sub2 = "f fo bar fooo foooo fooooo foooooo";
my $sub3 = "f fo foo bar foooo fooooo foooooo";
my $sub4 = "f fo foo fooo bar fooooo foooooo";
my $sub5 = "f fo foo fooo foooo bar foooooo";
my $sub6 = "f fo foo fooo foooo fooooo bar";

# :nth(N)...

ok(!( $data ~~ m:nth(0)/fo+/ ), 'No match nth(0)');

ok($data ~~ m:nth(1)/fo+/, 'Match nth(1)');
is($/, 'fo', 'Matched value for nth(1)');

ok($data ~~ m:nth(2)/fo+/, 'Match nth(2)');
is($/, 'foo', 'Matched value for nth(2)');

ok($data ~~ m:nth(3)/fo+/, 'Match nth(3)');
is($/, 'fooo', 'Matched value for nth(3)');

ok($data ~~ m:nth(4)/fo+/, 'Match nth(4)');
is($/, 'foooo', 'Matched value for nth(4)');

ok($data ~~ m:nth(5)/fo+/, 'Match nth(5)');
is($/, 'fooooo', 'Matched value for nth(5)');

ok($data ~~ m:nth(6)/fo+/, 'Match nth(6)');
is($/, 'foooooo', 'Matched value for nth(6)');

ok(!( $data ~~ m:nth(7)/fo+/ ), 'No match nth(7)');


# :nth($N)...

for (1..6) -> $N {
    ok($data ~~ m:nth($N)/fo+/, "Match nth(\$N) for \$N == $N" );
    is($/, 'f'~'o' x $N, "Matched value for $N" );
}

# more interesting variations of :nth(...)
#?niecza skip 'm:g'
#?rakudo todo 'unknown'
{
    ok($data ~~ m:nth(2,3):global/(fo+)/, 'nth(list) is ok');
    is(@(), , 'nth(list) matched correctly');
}


# :Nst...

ok($data ~~ m:1st/fo+/, 'Match 1st');
is($/, 'fo', 'Matched value for 1st');

ok($data ~~ m:2st/fo+/, 'Match 2st');
is($/, 'foo', 'Matched value for 2st');

ok($data ~~ m:3st/fo+/, 'Match 3st');
is($/, 'fooo', 'Matched value for 3st');

ok($data ~~ m:4st/fo+/, 'Match 4st');
is($/, 'foooo', 'Matched value for 4st');

ok($data ~~ m:5st/fo+/, 'Match 5st');
is($/, 'fooooo', 'Matched value for 5st');

ok($data ~~ m:6st/fo+/, 'Match 6st');
is($/, 'foooooo', 'Matched value for 6st');

ok(!( $data ~~ m:7st/fo+/ ), 'No match 7st');


# :Nnd...

ok($data ~~ m:1nd/fo+/, 'Match 1nd');
is($/, 'fo', 'Matched value for 1nd');

ok($data ~~ m:2nd/fo+/, 'Match 2nd');
is($/, 'foo', 'Matched value for 2nd');

ok($data ~~ m:3nd/fo+/, 'Match 3nd');
is($/, 'fooo', 'Matched value for 3nd');

ok($data ~~ m:4nd/fo+/, 'Match 4nd');
is($/, 'foooo', 'Matched value for 4nd');

ok($data ~~ m:5nd/fo+/, 'Match 5nd');
is($/, 'fooooo', 'Matched value for 5nd');

ok($data ~~ m:6nd/fo+/, 'Match 6nd');
is($/, 'foooooo', 'Matched value for 6nd');

ok(!( $data ~~ m:7nd/fo+/ ), 'No match 7nd');


# :Nrd...

ok($data ~~ m:1rd/fo+/, 'Match 1rd');
is($/, 'fo', 'Matched value for 1rd');

ok($data ~~ m:2rd/fo+/, 'Match 2rd');
is($/, 'foo', 'Matched value for 2rd');

ok($data ~~ m:3rd/fo+/, 'Match 3rd');
is($/, 'fooo', 'Matched value for 3rd');

ok($data ~~ m:4rd/fo+/, 'Match 4rd');
is($/, 'foooo', 'Matched value for 4rd');

ok($data ~~ m:5rd/fo+/, 'Match 5rd');
is($/, 'fooooo', 'Matched value for 5rd');

ok($data ~~ m:6rd/fo+/, 'Match 6rd');
is($/, 'foooooo', 'Matched value for 6rd');

ok(!( $data ~~ m:7rd/fo+/ ), 'No match 7rd');


# :Nth...

ok($data ~~ m:1th/fo+/, 'Match 1th');
is($/, 'fo', 'Matched value for 1th');

ok($data ~~ m:2th/fo+/, 'Match 2th');
is($/, 'foo', 'Matched value for 2th');

ok($data ~~ m:3th/fo+/, 'Match 3th');
is($/, 'fooo', 'Matched value for 3th');

ok($data ~~ m:4th/fo+/, 'Match 4th');
is($/, 'foooo', 'Matched value for 4th');

ok($data ~~ m:5th/fo+/, 'Match 5th');
is($/, 'fooooo', 'Matched value for 5th');

ok($data ~~ m:6th/fo+/, 'Match 6th');
is($/, 'foooooo', 'Matched value for 6th');

ok(!( $data ~~ m:7th/fo+/ ), 'No match 7th');


# Substitutions...
{
    my $try = $data;
    ok(!( $try ~~ s:0th{fo+}=q{bar} ), "Can't substitute 0th" );
    is($try, $data, 'No change to data for 0th');

    $try = $data;
    ok($try ~~ s:1st{fo+}=q{bar}, 'substitute 1st');
    is($try, $sub1, 'substituted 1st correctly');

    $try = $data;
    ok($try ~~ s:2nd{fo+}=q{bar}, 'substitute 2nd');
    is($try, $sub2, 'substituted 2nd correctly');

    $try = $data;
    ok($try ~~ s:3rd{fo+}=q{bar}, 'substitute 3rd');
    is($try, $sub3, 'substituted 3rd correctly');

    $try = $data;
    ok($try ~~ s:4th{fo+}=q{bar}, 'substitute 4th');
    is($try, $sub4, 'substituted 4th correctly');

    $try = $data;
    ok($try ~~ s:5th{fo+}=q{bar}, 'substitute 5th');
    is($try, $sub5, 'substituted 5th correctly');

    $try = $data;
    ok($try ~~ s:6th{fo+}=q{bar}, 'substitute 6th');
    is($try, $sub6, 'substituted 6th correctly');

    $try = $data;
    ok(!( $try ~~ s:7th{fo+}=q{bar} ), "Can't substitute 7th" );
    is($try, $data, 'No change to data for 7th');
}


# Other patterns...

ok($data ~~ m:3rd/ f [\d|\w+]/, 'Match 3rd f[\d|\w+]');
is($/, 'fooo', 'Matched value for 3rd f[\d|\w+]');

ok($data ~~ m:3rd/  /, 'Match 3rd ');
is($/, 'foo', 'Matched value for 3th ');

ok($data ~~ m:3rd/ «  /, 'Match 3rd « ');
is($/, 'foo', 'Matched value for 3th « ');


$data = "f fo foo fooo foooo fooooo foooooo";
$sub1 = "f bar foo fooo foooo fooooo foooooo";
$sub2 = "f bar bar fooo foooo fooooo foooooo";
$sub3 = "f bar bar bar foooo fooooo foooooo";
$sub4 = "f bar bar bar bar fooooo foooooo";
$sub5 = "f bar bar bar bar bar foooooo";
$sub6 = "f bar bar bar bar bar bar";

# :Nx...

{
    my $try = $data;
    ok(!( $try ~~ s:0x{fo+}=q{bar} ), "Can't substitute 0x" );
    is($try, $data, 'No change to data for 0x');

    $try = $data;
    ok($try ~~ s:1x{fo+}=q{bar}, 'substitute 1x');
    is($try, $sub1, 'substituted 1x correctly');

    $try = $data;
    ok($try ~~ s:2x{fo+}=q{bar}, 'substitute 2x');
    is($try, $sub2, 'substituted 2x correctly');

    $try = $data;
    ok($try ~~ s:3x{fo+}=q{bar}, 'substitute 3x');
    is($try, $sub3, 'substituted 3x correctly');

    $try = $data;
    ok($try ~~ s:4x{fo+}=q{bar}, 'substitute 4x');
    is($try, $sub4, 'substituted 4x correctly');

    $try = $data;
    ok($try ~~ s:5x{fo+}=q{bar}, 'substitute 5x');
    is($try, $sub5, 'substituted 5x correctly');

    $try = $data;
    ok($try ~~ s:6x{fo+}=q{bar}, 'substitute 6x');
    is($try, $sub6, 'substituted 6x correctly');

    $try = $data;
    #?niecza todo "https://github.com/sorear/niecza/issues/186"
    nok($try ~~ s:7x{fo+}=q{bar}, 'substitute 7x');
    is($try, $data, 'did not substitute 7x');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/exhaustive.t0000664000175000017500000001070612224265625020527 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/exhaustive.t.

# L

=end pod

#?pugs emit force_todo(2,3,5,6,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42);

my $str = "abrAcadAbbra";

my @expected = (
    [ 0 => 'abrAcadAbbra' ],
    [ 0 => 'abrAcadA'     ],
    [ 0 => 'abrAca'       ],
    [ 0 => 'abrA'         ],
    [ 3 =>    'AcadAbbra' ],
    [ 3 =>    'AcadA'     ],
    [ 3 =>    'Aca'       ],
    [ 5 =>      'adAbbra' ],
    [ 5 =>      'adA'     ],
    [ 7 =>        'Abbra' ],
);

for (1..2) -> $rep {
    ok($str ~~ m:i:exhaustive/ a .+ a /, "Repeatable every-way match ($rep)" );

    ok(@$/ == @expected, "Correct number of matches ($rep)" );
    my %expected; %expected{map {$_[1]}, @expected} = (1) x @expected;
    my %position; %position{map {$_[1]}, @expected} = map {$_[0]}, @expected;
    for (@$/) {
        ok( %expected{$_}, "Matched '$_' ($rep)" );
        ok( %position{$_} == $_.pos, "At correct position of '$_' ($rep)" );
        #?rakudo emit #
        %expected{$_} :delete;
        #?rakudo emit %expected{$_}:delete
    }
    ok(%expected.keys == 0, "No matches missed ($rep)" );
}

ok(!( "abcdefgh" ~~ m:exhaustive/ a .+ a / ), 'Failed every-way match');
ok(@$/ == 0, 'No matches');

ok($str ~~ m:ex:i/ a (.+) a /, 'Capturing every-way match');

ok(@$/ == @expected, 'Correct number of capturing matches');
my %expected; %expected{map {$_[1]}, @expected} = (1) x @expected;

for @($/) {
    ok( %expected{$_}, "Capture matched '$_'" );
    ok( $_[1] = substr($_[0],1,-1), "Captured within '$_'" );
    %expected{$_} :delete;
}

my @adj  = 
        || b 
        || c 
        || d 
    }
    token a {
        :constant $x = 'foo';
        $x
    }
    token b {
        :my $y = ' yack';
        $y $y
    }
    token c {
        :state $z++;
        $z
    }
    token d {
        :our $our = 'zho';
        $our
    }
}

ok DeclaratorTest1.parse( 'afoo' ), 'can declare :constant in regex';
is ~$/, 'afoo', '... and it matched the constant';
ok !DeclaratorTest1.parse( 'abar' ), 'does not work with wrong text';

ok DeclaratorTest1.parse( 'b yack yack' ), 'can declare :my in regex';
is ~$/, 'b yack yack', 'correct match with "my" variable';
ok !DeclaratorTest1.parse('b yack shaving'), 'does not work with wrong text';

ok DeclaratorTest1.parse('c1'), ':state in regex (match) (1)';
is ~$/, 'c1', ':state in regex ($/) (1)';

ok DeclaratorTest1.parse('c2'), ':state in regex (match) (2)';
is ~$/, 'c2', ':state in regex ($/) (2)';
ok !DeclaratorTest1.parse('c3'), ':state in regex (no match)';

ok DeclaratorTest1.parse('dzho'), ':our in regex (match)';
is ~$/, 'dzho', ':our in regex ($/)';

is $DeclaratorTest1::our, 'zho', 'can access our variable from the outside';

{
    my $a = 1;
    regex ta { :temp $a = 5;  };
    regex ma { $a $a };
    ok '11'  ~~ m/ ^  $ /, "can access variables in regex (not temp'ed)";
    ok '55' !~~ m/ ^  $ /, "(-) not temp'ed";
    is $a, 1, "temp'ed variable still 1";

    ok '55'  ~~ m/ ^  $ /, "can access temp'ed variable in regex (+)";
    ok '11' !~~ m/ ^  $ /, "(-) temp'ed";
    is $a, 1, "temp'ed variable again 1";
}

{
    my $a = 1;
    regex la { :let $a = 5;  };
    regex lma { $a $a };
    ok '23' !~~ m/ ^  $ /, 'can detect a non-match with :let';
    is $a, 1, 'unsuccessful match did not affect :let variable';

    ok '55' ~~ m/ ^  $ /, 'can match changed :let variable';
    is $a, 5, 'successful match preserves new :let value';
}

done;
# vim: ft=perl6 sw=4 ts=4 expandtab
rakudo-2013.12/t/spec/S05-modifier/overlapping.t0000664000175000017500000000474112224265625020672 0ustar  moritzmoritzuse v6;
use Test;

=begin pod

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/overlapping.t.

It probably needs a few syntax updates to remove p5isms

=end pod

plan 22;

#?pugs emit force_todo(2,3,5,6,10);

# should be: L (C<:overlap>) modifier,>
# L

my $str = "abrAcadAbbra";

my @expected = (
    [ 0, 'abrAcadAbbra' ],
    [ 3,    'AcadAbbra' ],
    [ 5,      'adAbbra' ],
    [ 7,        'Abbra' ],
);

#?rakudo todo 'm:overlap NYI'
{
    for (1..2) -> $rep {
         ok($str ~~ m:i:overlap/ a .+ a /, "Repeatable overlapping match ($rep)" );

        ok(@$/ == @expected, "Correct number of matches ($rep)" );
        my %expected; %expected{map {$_[1]}, @expected} = (1) x @expected;
        my %position; %position{map {$_[1]}, @expected} = map {$_[0]}, @expected;
        for (@$/) {
            ok( %expected{$_}, "Matched '$_' ($rep)" );
            ok( %position{$_} == $_.to, "At correct position of '$_' ($rep)" );
            %expected{$_} :delete;
        }
        ok(%expected.keys == 0, "No matches missed ($rep)" );
    }
}

#?rakudo skip "m:overlap// NYI"
{
    ok(!( "abcdefgh" ~~ m:overlap/ a .+ a / ), 'Failed overlapping match');
    ok(@$/ == 0, 'No matches');

    ok($str ~~ m:i:overlap/ a (.+) a /, 'Capturing overlapping match');

    ok(@$/ == @expected, 'Correct number of capturing matches');
    my %expected; %expected{@expected} = (1) x @expected;
    for (@$/) {
        my %expected; %expected{map {$_[1]}, @expected} = (1) x @expected;
        ok( $_[1] = substr($_[0],1,-1), "Captured within '$_'" );
        %expected{$_} :delete;
    }
}

{
    # $str eq abrAcadAbbra
    my @match = $str.match(/a .* a/, :ov).list;
    is +@match, 2, "Two matches found";
    is ~@match[0], "abrAcadAbbra", "First is abrAcadAbbra";
    is ~@match[1], "adAbbra", "Second is adAbbra";
}

{
    # $str eq abrAcadAbbra
    my @match = $str.match(/a .* a/, :overlap).list;
    is +@match, 2, "Two matches found";
    is ~@match[0], "abrAcadAbbra", "First is abrAcadAbbra";
    is ~@match[1], "adAbbra", "Second is adAbbra";
}

{
    my @match = "aababcabcd".match(/a .*/, :ov).list;
    is +@match, 4, "Four matches found";
    is ~@match[0], "aababcabcd", "First is aababcabcd";
    is ~@match[1], "ababcabcd", "Second is ababcabcd";
    is ~@match[2], "abcabcd", "Third is abcabcd";
    is ~@match[3], "abcd", "Last is abcd";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_0.t0000664000175000017500000000654712224265625017620 0ustar  moritzmoritzuse v6;

use Test;

plan 24;

# Really really really minimal s:P5//// and m:P5 tests. Please add more!!

#L

unless "a" ~~ m:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $foo = "foo";
$foo ~~ s:Perl5{f}=q{b};
is($foo, "boo", 'substitute regexp works');
unless $foo eq "boo" {
  skip_rest "Skipping test which depend on a previous failed test";
}

my $bar = "barrrr";
$bar ~~ s:Perl5:g{r+}=q{z};
is($bar, "baz", 'substitute regexp works with :g modifier');

my $path = "/path//to///a//////file";
$path ~~ s:Perl5:g{/+} = '/';
is($path, "/path/to/a/file", 'substitute regexp works with :g modifier');

my $baz = "baz";
$baz ~~ s:Perl5{.(a)(.)}=qq{$1$0p};
is($baz, "zap", 'substitute regexp with capturing variables works');

my $bazz = "bazz";
$bazz ~~ s:Perl5:g{(.)}=qq{x$0};
is($bazz, "xbxaxzxz", 'substitute regexp with capturing variables works with :g');

my $bad = "1   ";
$bad ~~ s:Perl5:g/\s*//;
is($bad, "1", 'Zero width replace works with :g');

#?pugs skip 'temp'
{
	my $r;
	temp $_ = 'heaao';
	s:Perl5 /aa/ll/ && ($r = $_);
	is $r, 'hello', 's/// in boolean context properly defaults to $_';
}

my $str = "http://foo.bar/";
ok(($str ~~ m:Perl5/http:\/\//), "test the regular expression escape");

# returns the count of matches in scalar
my $vals = "hello world" ~~ m:P5:g/(\w+)/;
#?rakudo todo 'NYI'
is($vals, 2, 'returned two values in the match');

# return all the strings we matched
my @vals = "hello world" ~~ m:P5:g/(\w+)/;
#?pugs todo
#?rakudo todo 'NYI'
is(+@vals, 2, 'returned two values in the match');
#?pugs todo
#?rakudo todo 'NYI'
is(@vals[0], 'hello', 'returned correct first value in the match');
#?pugs todo
#?rakudo todo 'NYI'
is(@vals[1], 'world', 'returned correct second value in the match');


=begin pod

$0 should not be defined.

Pcre is doing the right thing:
  $ pcretest
...
    re> /a|(b)/
  data> a
   0: a
  data>
so it looks like a pugs-pcre interface bug.

=end pod

{
    "a" ~~ m:Perl5/a|(b)/;
    #?pugs todo
    nok($0.defined, 'An unmatched capture should be undefined.');
    my $str = "http://foo.bar/";
    ok(($str ~~ m:Perl5 {http{0,1}}));

    my $rule = '\d+';
    #?rakudo todo 'NYI'
    ok('2342' ~~ m:P5/$rule/, 'interpolated rule applied successfully');

    my $rule2 = 'he(l)+o';
    #?rakudo todo 'NYI'
    ok('hello' ~~ m:P5/$rule2/, 'interpolated rule applied successfully');

    my $rule3 = 'r+';
    my $subst = 'z';
    my $bar = "barrrr"; 
    $bar ~~ s:P5:g{$rule3}=qq{$subst}; 
    #?rakudo todo 'NYI'
    is($bar, "baz", 'variable interpolation in substitute regexp works with :g modifier');

    my $a = 'a:';
    $a ~~ s:P5 [(..)]=qq[{uc $0}];
    is($a, 'A:', 'closure interpolation with qq[] as delimiter');

    my $b = 'b:';
    $b ~~ s:P5{(..)} = uc $0;
    is($b, 'B:', 'closure interpolation with no delimiter');
}

{
        diag "Now going to test numbered match variable.";
        "asdfg/" ~~ m:P5 {^(\w+)?/(\w+)?}; $1 ?? "true" !! "false";

        ok !$1, "Test the status of non-matched number match variable (1)";
}

{
        "abc" ~~ m:P5/^(doesnt_match)/;

        ok !$1, "Test the status of non-matched number match variable (2)";
}

my $rule = rx:P5/\s+/;
isa_ok($rule, 'Regex');

ok("hello world" ~~ $rule, '... applying rule object returns true');
ok(!("helloworld" ~~ $rule), '... applying rule object returns false (correctly)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_1.t0000664000175000017500000001425612224265625017615 0ustar  moritzmoritzuse v6;

use Test;

plan 100;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

is(("abc" ~~ rx:P5/abc/ && $/), "abc", 're_tests 1/0 (1)');
is(("abc" ~~ rx:P5/abc/ && $/.from), 0, 're_tests 1/0 (2)');
ok((not ("xbc" ~~ rx:P5/abc/)), 're_tests 3  (5)');
ok((not ("axc" ~~ rx:P5/abc/)), 're_tests 5  (7)');
ok((not ("abx" ~~ rx:P5/abc/)), 're_tests 7  (9)');
is(("xabcy" ~~ rx:P5/abc/ && $/), "abc", 're_tests 9/0 (11)');
is(("xabcy" ~~ rx:P5/abc/ && $/.from), 1, 're_tests 9/0 (12)');
is(("ababc" ~~ rx:P5/abc/ && $/), "abc", 're_tests 11/0 (15)');
is(("ababc" ~~ rx:P5/abc/ && $/.from), 2, 're_tests 11/0 (16)');
is(("abc" ~~ rx:P5/ab*c/ && $/), "abc", 're_tests 13/0 (19)');
is(("abc" ~~ rx:P5/ab*c/ && $/.from), 0, 're_tests 13/0 (20)');
is(("abc" ~~ rx:P5/ab*bc/ && $/), "abc", 're_tests 15/0 (23)');
is(("abc" ~~ rx:P5/ab*bc/ && $/.from), 0, 're_tests 15/0 (24)');
is(("abbc" ~~ rx:P5/ab*bc/ && $/), "abbc", 're_tests 17/0 (27)');
is(("abbc" ~~ rx:P5/ab*bc/ && $/.from), 0, 're_tests 17/0 (28)');
is(("abbbbc" ~~ rx:P5/ab*bc/ && $/), "abbbbc", 're_tests 19/0 (31)');
is(("abbbbc" ~~ rx:P5/ab*bc/ && $/.from), 0, 're_tests 19/0 (32)');
is(("abbbbc" ~~ rx:P5/.{1}/ && $/), "a", 're_tests 21/0 (35)');
is(("abbbbc" ~~ rx:P5/.{1}/ && $/.from), 0, 're_tests 21/0 (36)');
is(("abbbbc" ~~ rx:P5/.{3,4}/ && $/), "abbb", 're_tests 23/0 (39)');
is(("abbbbc" ~~ rx:P5/.{3,4}/ && $/.from), 0, 're_tests 23/0 (40)');
is(("abbbbc" ~~ rx:P5/ab{0,}bc/ && $/), "abbbbc", 're_tests 25/0 (43)');
is(("abbbbc" ~~ rx:P5/ab{0,}bc/ && $/.from), 0, 're_tests 25/0 (44)');
is(("abbc" ~~ rx:P5/ab+bc/ && $/), "abbc", 're_tests 27/0 (47)');
is(("abbc" ~~ rx:P5/ab+bc/ && $/.from), 0, 're_tests 27/0 (48)');
ok((not ("abc" ~~ rx:P5/ab+bc/)), 're_tests 29  (51)');
ok((not ("abq" ~~ rx:P5/ab+bc/)), 're_tests 31  (53)');
ok((not ("abq" ~~ rx:P5/ab{1,}bc/)), 're_tests 33  (55)');
is(("abbbbc" ~~ rx:P5/ab+bc/ && $/), "abbbbc", 're_tests 35/0 (57)');
is(("abbbbc" ~~ rx:P5/ab+bc/ && $/.from), 0, 're_tests 35/0 (58)');
is(("abbbbc" ~~ rx:P5/ab{1,}bc/ && $/), "abbbbc", 're_tests 37/0 (61)');
is(("abbbbc" ~~ rx:P5/ab{1,}bc/ && $/.from), 0, 're_tests 37/0 (62)');
is(("abbbbc" ~~ rx:P5/ab{1,3}bc/ && $/), "abbbbc", 're_tests 39/0 (65)');
is(("abbbbc" ~~ rx:P5/ab{1,3}bc/ && $/.from), 0, 're_tests 39/0 (66)');
is(("abbbbc" ~~ rx:P5/ab{3,4}bc/ && $/), "abbbbc", 're_tests 41/0 (69)');
is(("abbbbc" ~~ rx:P5/ab{3,4}bc/ && $/.from), 0, 're_tests 41/0 (70)');
ok((not ("abbbbc" ~~ rx:P5/ab{4,5}bc/)), 're_tests 43  (73)');
is(("abbc" ~~ rx:P5/ab?bc/ && $/), "abbc", 're_tests 45/0 (75)');
is(("abc" ~~ rx:P5/ab?bc/ && $/), "abc", 're_tests 47/0 (77)');
is(("abc" ~~ rx:P5/ab{0,1}bc/ && $/), "abc", 're_tests 49/0 (79)');
ok((not ("abbbbc" ~~ rx:P5/ab?bc/)), 're_tests 51  (81)');
is(("abc" ~~ rx:P5/ab?c/ && $/), "abc", 're_tests 53/0 (83)');
is(("abc" ~~ rx:P5/ab{0,1}c/ && $/), "abc", 're_tests 55/0 (85)');
is(("abc" ~~ rx:P5/^abc$/ && $/), "abc", 're_tests 57/0 (87)');
ok((not ("abcc" ~~ rx:P5/^abc$/)), 're_tests 59  (89)');
is(("abcc" ~~ rx:P5/^abc/ && $/), "abc", 're_tests 61/0 (91)');
ok((not ("aabc" ~~ rx:P5/^abc$/)), 're_tests 63  (93)');
is(("aabc" ~~ rx:P5/abc$/ && $/), "abc", 're_tests 65/0 (95)');
ok((not ("aabcd" ~~ rx:P5/abc$/)), 're_tests 67  (97)');
is(("abc" ~~ rx:P5/^/ && $/), "", 're_tests 69/0 (99)');
is(("abc" ~~ rx:P5/$/ && $/), "", 're_tests 71/0 (101)');
is(("abc" ~~ rx:P5/a.c/ && $/), "abc", 're_tests 73/0 (103)');
is(("axc" ~~ rx:P5/a.c/ && $/), "axc", 're_tests 75/0 (105)');
is(("axyzc" ~~ rx:P5/a.*c/ && $/), "axyzc", 're_tests 77/0 (107)');
ok((not ("axyzd" ~~ rx:P5/a.*c/)), 're_tests 79  (109)');
ok((not ("abc" ~~ rx:P5/a[bc]d/)), 're_tests 81  (111)');
is(("abd" ~~ rx:P5/a[bc]d/ && $/), "abd", 're_tests 83/0 (113)');
ok((not ("abd" ~~ rx:P5/a[b-d]e/)), 're_tests 85  (115)');
is(("ace" ~~ rx:P5/a[b-d]e/ && $/), "ace", 're_tests 87/0 (117)');
is(("aac" ~~ rx:P5/a[b-d]/ && $/), "ac", 're_tests 89/0 (119)');
is(("a-" ~~ rx:P5/a[-b]/ && $/), "a-", 're_tests 91/0 (121)');
is(("a-" ~~ rx:P5/a[b-]/ && $/), "a-", 're_tests 93/0 (123)');
is(("a]" ~~ rx:P5/a]/ && $/), "a]", 're_tests 95/0 (125)');
is(("a]b" ~~ rx:P5/a[]]b/ && $/), "a]b", 're_tests 97/0 (127)');
is(("aed" ~~ rx:P5/a[^bc]d/ && $/), "aed", 're_tests 99/0 (129)');
ok((not ("abd" ~~ rx:P5/a[^bc]d/)), 're_tests 101  (131)');
is(("adc" ~~ rx:P5/a[^-b]c/ && $/), "adc", 're_tests 103/0 (133)');
ok((not ("a-c" ~~ rx:P5/a[^-b]c/)), 're_tests 105  (135)');
ok((not ("a]c" ~~ rx:P5/a[^]b]c/)), 're_tests 107  (137)');
is(("adc" ~~ rx:P5/a[^]b]c/ && $/), "adc", 're_tests 109/0 (139)');
ok(("a-" ~~ rx:P5/\ba\b/), 're_tests 111  (141)');
ok(("-a" ~~ rx:P5/\ba\b/), 're_tests 113  (143)');
ok(("-a-" ~~ rx:P5/\ba\b/), 're_tests 115  (145)');
ok((not ("xy" ~~ rx:P5/\by\b/)), 're_tests 117  (147)');
ok((not ("yz" ~~ rx:P5/\by\b/)), 're_tests 119  (149)');
ok((not ("xyz" ~~ rx:P5/\by\b/)), 're_tests 121  (151)');
ok((not ("a-" ~~ rx:P5/\Ba\B/)), 're_tests 123  (153)');
ok((not ("-a" ~~ rx:P5/\Ba\B/)), 're_tests 125  (155)');
ok((not ("-a-" ~~ rx:P5/\Ba\B/)), 're_tests 127  (157)');
ok(("xy" ~~ rx:P5/\By\b/), 're_tests 129  (159)');
is(("xy" ~~ rx:P5/\By\b/ && $/.from), 1, 're_tests 131/0 (161)');
ok(("xy" ~~ rx:P5/\By\b/), 're_tests 133  (163)');
ok(("yz" ~~ rx:P5/\by\B/), 're_tests 135  (165)');
ok(("xyz" ~~ rx:P5/\By\B/), 're_tests 137  (167)');
ok(("a" ~~ rx:P5/\w/), 're_tests 139  (169)');
ok((not ("-" ~~ rx:P5/\w/)), 're_tests 141  (171)');
ok((not ("a" ~~ rx:P5/\W/)), 're_tests 143  (173)');
ok(("-" ~~ rx:P5/\W/), 're_tests 145  (175)');
ok(("a b" ~~ rx:P5/a\sb/), 're_tests 147  (177)');
ok((not ("a-b" ~~ rx:P5/a\sb/)), 're_tests 149  (179)');
ok((not ("a b" ~~ rx:P5/a\Sb/)), 're_tests 151  (181)');
ok(("a-b" ~~ rx:P5/a\Sb/), 're_tests 153  (183)');
ok(("1" ~~ rx:P5/\d/), 're_tests 155  (185)');
ok((not ("-" ~~ rx:P5/\d/)), 're_tests 157  (187)');
ok((not ("1" ~~ rx:P5/\D/)), 're_tests 159  (189)');
ok(("-" ~~ rx:P5/\D/), 're_tests 161  (191)');
ok(("a" ~~ rx:P5/[\w]/), 're_tests 163  (193)');
ok((not ("-" ~~ rx:P5/[\w]/)), 're_tests 165  (195)');
ok((not ("a" ~~ rx:P5/[\W]/)), 're_tests 167  (197)');
ok(("-" ~~ rx:P5/[\W]/), 're_tests 169  (199)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_2.t0000664000175000017500000001606612224265625017617 0ustar  moritzmoritzuse v6;

use Test;

plan 100;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

ok(("a b" ~~ rx:P5/a[\s]b/), 're_tests 171  (201)');
ok((not ("a-b" ~~ rx:P5/a[\s]b/)), 're_tests 173  (203)');
ok((not ("a b" ~~ rx:P5/a[\S]b/)), 're_tests 175  (205)');
ok(("a-b" ~~ rx:P5/a[\S]b/), 're_tests 177  (207)');
ok(("1" ~~ rx:P5/[\d]/), 're_tests 179  (209)');
ok((not ("-" ~~ rx:P5/[\d]/)), 're_tests 181  (211)');
ok((not ("1" ~~ rx:P5/[\D]/)), 're_tests 183  (213)');
ok(("-" ~~ rx:P5/[\D]/), 're_tests 185  (215)');
is(("abc" ~~ rx:P5/ab|cd/ && $/), "ab", 're_tests 187/0 (217)');
is(("abcd" ~~ rx:P5/ab|cd/ && $/), "ab", 're_tests 189/0 (219)');
is(("def" ~~ rx:P5/()ef/ && $/), "ef", 're_tests 191/0 (221)');
is(("def" ~~ rx:P5/()ef/ && $0), "", 're_tests 191/1 (222)');
is(("def" ~~ rx:P5/()ef/ && $/.from), 1, 're_tests 193/0 (225)');
is(("def" ~~ rx:P5/()ef/ && $/[0].from), 1, 're_tests 195/1 (227)');
ok((not ("b" ~~ rx:P5/$b/)), 're_tests 197  (229)');
is(("a(b" ~~ rx:P5/a\(b/ && $/), "a(b", 're_tests 199/0 (231)');
is(("a(b" ~~ rx:P5/a\(b/ && $0), "", 're_tests 199/1 (232)');
is(("ab" ~~ rx:P5/a\(*b/ && $/), "ab", 're_tests 201/0 (235)');
is(("a((b" ~~ rx:P5/a\(*b/ && $/), "a((b", 're_tests 203/0 (237)');
#?rakudo todo "variable interpolation in p5 regex"
is(("a\b" ~~ rx:P5/a$backspace/ && $/), "a\b", 're_tests 205/0 (239)');
is(("a\\b" ~~ rx:P5/a\\b/ && $/), "a\\b", 're_tests 205/0 (239)');
is(("abc" ~~ rx:P5/((a))/ && $/), "a", 're_tests 207/0 (241)');
is(("abc" ~~ rx:P5/((a))/ && $0), "a", 're_tests 207/1 (242)');
is(("abc" ~~ rx:P5/((a))/ && $1), "a", 're_tests 207/2 (243)');
is(("abc" ~~ rx:P5/(a)b(c)/ && $/), "abc", 're_tests 209/0 (247)');
is(("abc" ~~ rx:P5/(a)b(c)/ && $0), "a", 're_tests 209/1 (248)');
is(("abc" ~~ rx:P5/(a)b(c)/ && $1), "c", 're_tests 209/2 (249)');
is(("aabbabc" ~~ rx:P5/a+b+c/ && $/), "abc", 're_tests 211/0 (253)');
is(("aabbabc" ~~ rx:P5/a{1,}b{1,}c/ && $/), "abc", 're_tests 213/0 (255)');
is(("abcabc" ~~ rx:P5/a.+?c/ && $/), "abc", 're_tests 215/0 (257)');
is(("ab" ~~ rx:P5/(a+|b)*/ && $/), "ab", 're_tests 217/0 (259)');
is(("ab" ~~ rx:P5/(a+|b)*/ && $0), "b", 're_tests 217/1 (260)');
is(("ab" ~~ rx:P5/(a+|b)*/ && $/.from), 0, 're_tests 219/0 (263)');
is(("ab" ~~ rx:P5/(a+|b)*/ && $/[0].from), 1, 're_tests 221/1 (265)');
is(("ab" ~~ rx:P5/(a+|b){0,}/ && $/), "ab", 're_tests 223/0 (267)');
is(("ab" ~~ rx:P5/(a+|b){0,}/ && $0), "b", 're_tests 223/1 (268)');
is(("ab" ~~ rx:P5/(a+|b)+/ && $/), "ab", 're_tests 225/0 (271)');
is(("ab" ~~ rx:P5/(a+|b)+/ && $0), "b", 're_tests 225/1 (272)');
is(("ab" ~~ rx:P5/(a+|b){1,}/ && $/), "ab", 're_tests 227/0 (275)');
is(("ab" ~~ rx:P5/(a+|b){1,}/ && $0), "b", 're_tests 227/1 (276)');
is(("ab" ~~ rx:P5/(a+|b)?/ && $/), "a", 're_tests 229/0 (279)');
is(("ab" ~~ rx:P5/(a+|b)?/ && $0), "a", 're_tests 229/1 (280)');
is(("ab" ~~ rx:P5/(a+|b){0,1}/ && $/), "a", 're_tests 231/0 (283)');
is(("ab" ~~ rx:P5/(a+|b){0,1}/ && $0), "a", 're_tests 231/1 (284)');
is(("cde" ~~ rx:P5/[^ab]*/ && $/), "cde", 're_tests 233/0 (287)');
ok((not ("" ~~ rx:P5/abc/)), 're_tests 235  (289)');
is(("" ~~ rx:P5/a*/ && $/), "", 're_tests 237/0 (291)');
is(("abbbcd" ~~ rx:P5/([abc])*d/ && $/), "abbbcd", 're_tests 239/0 (293)');
is(("abbbcd" ~~ rx:P5/([abc])*d/ && $0), "c", 're_tests 239/1 (294)');
is(("abcd" ~~ rx:P5/([abc])*bcd/ && $/), "abcd", 're_tests 241/0 (297)');
is(("abcd" ~~ rx:P5/([abc])*bcd/ && $0), "a", 're_tests 241/1 (298)');
is(("e" ~~ rx:P5/a|b|c|d|e/ && $/), "e", 're_tests 243/0 (301)');
is(("ef" ~~ rx:P5/(a|b|c|d|e)f/ && $/), "ef", 're_tests 245/0 (303)');
is(("ef" ~~ rx:P5/(a|b|c|d|e)f/ && $0), "e", 're_tests 245/1 (304)');
is(("ef" ~~ rx:P5/(a|b|c|d|e)f/ && $/.from), 0, 're_tests 247/0 (307)');
is(("ef" ~~ rx:P5/(a|b|c|d|e)f/ && $/[0].from), 0, 're_tests 249/1 (309)');
is(("abcdefg" ~~ rx:P5/abcd*efg/ && $/), "abcdefg", 're_tests 251/0 (311)');
is(("xabyabbbz" ~~ rx:P5/ab*/ && $/), "ab", 're_tests 253/0 (313)');
is(("xayabbbz" ~~ rx:P5/ab*/ && $/), "a", 're_tests 255/0 (315)');
is(("abcde" ~~ rx:P5/(ab|cd)e/ && $/), "cde", 're_tests 257/0 (317)');
is(("abcde" ~~ rx:P5/(ab|cd)e/ && $0), "cd", 're_tests 257/1 (318)');
is(("hij" ~~ rx:P5/[abhgefdc]ij/ && $/), "hij", 're_tests 259/0 (321)');
is(("abcdef" ~~ rx:P5/(abc|)ef/ && $/), "ef", 're_tests 261/0 (323)');
is(("abcdef" ~~ rx:P5/(abc|)ef/ && $0), "", 're_tests 261/1 (324)');
is(("abcd" ~~ rx:P5/(a|b)c*d/ && $/), "bcd", 're_tests 263/0 (327)');
is(("abcd" ~~ rx:P5/(a|b)c*d/ && $0), "b", 're_tests 263/1 (328)');
is(("abc" ~~ rx:P5/(ab|ab*)bc/ && $/), "abc", 're_tests 265/0 (331)');
is(("abc" ~~ rx:P5/(ab|ab*)bc/ && $0), "a", 're_tests 265/1 (332)');
is(("abc" ~~ rx:P5/a([bc]*)c*/ && $/), "abc", 're_tests 267/0 (335)');
is(("abc" ~~ rx:P5/a([bc]*)c*/ && $0), "bc", 're_tests 267/1 (336)');
is(("abcd" ~~ rx:P5/a([bc]*)(c*d)/ && $/), "abcd", 're_tests 269/0 (339)');
is(("abcd" ~~ rx:P5/a([bc]*)(c*d)/ && $0), "bc", 're_tests 269/1 (340)');
is(("abcd" ~~ rx:P5/a([bc]*)(c*d)/ && $1), "d", 're_tests 269/2 (341)');
is(("abcd" ~~ rx:P5/a([bc]*)(c*d)/ && $/.from), 0, 're_tests 271/0 (345)');
is(("abcd" ~~ rx:P5/a([bc]*)(c*d)/ && $/[0].from), 1, 're_tests 273/1 (347)');
is(("abcd" ~~ rx:P5/a([bc]*)(c*d)/ && $/[1].from), 3, 're_tests 275/2 (349)');
is(("abcd" ~~ rx:P5/a([bc]+)(c*d)/ && $/), "abcd", 're_tests 277/0 (351)');
is(("abcd" ~~ rx:P5/a([bc]+)(c*d)/ && $0), "bc", 're_tests 277/1 (352)');
is(("abcd" ~~ rx:P5/a([bc]+)(c*d)/ && $1), "d", 're_tests 277/2 (353)');
is(("abcd" ~~ rx:P5/a([bc]*)(c+d)/ && $/), "abcd", 're_tests 279/0 (357)');
is(("abcd" ~~ rx:P5/a([bc]*)(c+d)/ && $0), "b", 're_tests 279/1 (358)');
is(("abcd" ~~ rx:P5/a([bc]*)(c+d)/ && $1), "cd", 're_tests 279/2 (359)');
is(("abcd" ~~ rx:P5/a([bc]*)(c+d)/ && $/.from), 0, 're_tests 281/0 (363)');
is(("abcd" ~~ rx:P5/a([bc]*)(c+d)/ && $/[0].from), 1, 're_tests 283/1 (365)');
is(("abcd" ~~ rx:P5/a([bc]*)(c+d)/ && $/[1].from), 2, 're_tests 285/2 (367)');
is(("adcdcde" ~~ rx:P5/a[bcd]*dcdcde/ && $/), "adcdcde", 're_tests 287/0 (369)');
ok((not ("adcdcde" ~~ rx:P5/a[bcd]+dcdcde/)), 're_tests 289  (371)');
is(("abc" ~~ rx:P5/(ab|a)b*c/ && $/), "abc", 're_tests 291/0 (373)');
is(("abc" ~~ rx:P5/(ab|a)b*c/ && $0), "ab", 're_tests 291/1 (374)');
is(("abc" ~~ rx:P5/(ab|a)b*c/ && $/.from), 0, 're_tests 293/0 (377)');
is(("abc" ~~ rx:P5/(ab|a)b*c/ && $/[0].from), 0, 're_tests 295/1 (379)');
is(("abcd" ~~ rx:P5/((a)(b)c)(d)/ && $/.from), 0, 're_tests 297/0 (381)');
is(("abcd" ~~ rx:P5/((a)(b)c)(d)/ && $/[0].from), 0, 're_tests 299/1 (383)');
is(("abcd" ~~ rx:P5/((a)(b)c)(d)/ && $/[1].from), 0, 're_tests 301/2 (385)');
is(("abcd" ~~ rx:P5/((a)(b)c)(d)/ && $/[2].from), 1, 're_tests 303/3 (387)');
is(("abcd" ~~ rx:P5/((a)(b)c)(d)/ && $/[3].from), 3, 're_tests 305/4 (389)');
is(("alpha" ~~ rx:P5/[a-zA-Z_][a-zA-Z0-9_]*/ && $/), "alpha", 're_tests 307/0 (391)');
is(("abh" ~~ rx:P5/^a(bc+|b[eh])g|.h$/ && $/), "bh", 're_tests 309/0 (393)');
is(("abh" ~~ rx:P5/^a(bc+|b[eh])g|.h$/ && $0), "", 're_tests 309/1 (394)');
is(("effgz" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $/), "effgz", 're_tests 311/0 (397)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_3.t0000664000175000017500000001651512224265625017617 0ustar  moritzmoritzuse v6;

use Test;

plan 100;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

is(("effgz" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $0), "effgz", 're_tests 311/1 (398)');
is(("effgz" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $1), "", 're_tests 311/2 (399)');
is(("ij" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $/), "ij", 're_tests 313/0 (403)');
is(("ij" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $0), "ij", 're_tests 313/1 (404)');
is(("ij" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $1), "j", 're_tests 313/2 (405)');
ok((not ("effg" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/)), 're_tests 315  (409)');
ok((not ("bcdd" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/)), 're_tests 317  (411)');
is(("reffgz" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $/), "effgz", 're_tests 319/0 (413)');
is(("reffgz" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $0), "effgz", 're_tests 319/1 (414)');
is(("reffgz" ~~ rx:P5/(bc+d$|ef*g.|h?i(j|k))/ && $1), "", 're_tests 319/2 (415)');
is(("a" ~~ rx:P5/((((((((((a))))))))))/ && $00), "a", 're_tests 321/10 (419)');
is(("a" ~~ rx:P5/((((((((((a))))))))))/ && $/.from), 0, 're_tests 323/0 (421)');
is(("a" ~~ rx:P5/((((((((((a))))))))))/ && $/[0].from), 0, 're_tests 325/10 (423)');
is(("aa" ~~ rx:P5/((((((((((a))))))))))\10/ && $/), "aa", 're_tests 327/0 (425)');
ok((not ("aa" ~~ rx:P5/((((((((((a))))))))))$bang/)), 're_tests 329  (427)');
#?rakudo todo "variable interpolation"
is(("a!" ~~ rx:P5/((((((((((a))))))))))$bang/ && $/), "a!", 're_tests 330/0 (428)');
is(("a" ~~ rx:P5/(((((((((a)))))))))/ && $/), "a", 're_tests 331/0 (429)');
ok((not ("uh-uh" ~~ rx:P5/multiple words of text/)), 're_tests 333  (431)');
is(("multiple words, yeah" ~~ rx:P5/multiple words/ && $/), "multiple words", 're_tests 335/0 (433)');
is(("abcde" ~~ rx:P5/(.*)c(.*)/ && $/), "abcde", 're_tests 337/0 (435)');
is(("abcde" ~~ rx:P5/(.*)c(.*)/ && $0), "ab", 're_tests 337/1 (436)');
is(("abcde" ~~ rx:P5/(.*)c(.*)/ && $1), "de", 're_tests 337/2 (437)');
ok((not ("ab" ~~ rx:P5/[k]/)), 're_tests 339  (441)');
is(("ac" ~~ rx:P5/a[-]?c/ && $/), "ac", 're_tests 341/0 (443)');
is(("abcabc" ~~ rx:P5/(abc)\1/ && $0), "abc", 're_tests 343/1 (445)');
is(("abcabc" ~~ rx:P5/([a-c]*)\1/ && $0), "abc", 're_tests 345/1 (447)');
ok(("a" ~~ rx:P5/(a)|\1/), 're_tests 347  (449)');
ok((not ("x" ~~ rx:P5/(a)|\1/)), 're_tests 349  (451)');
is(("ababbbcbc" ~~ rx:P5/(([a-c])b*?\2)*/ && $/), "ababb", 're_tests 351/0 (453)');
is(("ababbbcbc" ~~ rx:P5/(([a-c])b*?\2)*/ && $0), "bb", 're_tests 351/1 (454)');
is(("ababbbcbc" ~~ rx:P5/(([a-c])b*?\2)*/ && $1), "b", 're_tests 351/2 (455)');
is(("ababbbcbc" ~~ rx:P5/(([a-c])b*?\2){3}/ && $/), "ababbbcbc", 're_tests 353/0 (459)');
is(("ababbbcbc" ~~ rx:P5/(([a-c])b*?\2){3}/ && $0), "cbc", 're_tests 353/1 (460)');
is(("ababbbcbc" ~~ rx:P5/(([a-c])b*?\2){3}/ && $1), "c", 're_tests 353/2 (461)');
ok((not ("aaxabxbaxbbx" ~~ rx:P5/((\3|b)\2(a)x)+/)), 're_tests 355  (465)');
is(("b" ~~ rx:P5/(a)|(b)/ && $/.from), 0, 're_tests 357/0 (467)');
is(("b" ~~ rx:P5/(a)|(b)/ && $/[1].from), 0, 're_tests 359/2 (469)');
is(("ABC" ~~ rx:P5/(?i)abc/ && $/), "ABC", 're_tests 361/0 (471)');
ok((not ("XBC" ~~ rx:P5/(?i)abc/)), 're_tests 363  (473)');
ok((not ("AXC" ~~ rx:P5/(?i)abc/)), 're_tests 365  (475)');
ok((not ("ABX" ~~ rx:P5/(?i)abc/)), 're_tests 367  (477)');
is(("XABCY" ~~ rx:P5/(?i)abc/ && $/), "ABC", 're_tests 369/0 (479)');
is(("ABABC" ~~ rx:P5/(?i)abc/ && $/), "ABC", 're_tests 371/0 (481)');
is(("ABC" ~~ rx:P5/(?i)ab*c/ && $/), "ABC", 're_tests 373/0 (483)');
is(("ABC" ~~ rx:P5/(?i)ab*bc/ && $/), "ABC", 're_tests 375/0 (485)');
is(("ABBC" ~~ rx:P5/(?i)ab*bc/ && $/), "ABBC", 're_tests 377/0 (487)');
is(("ABBBBC" ~~ rx:P5/(?i)ab*?bc/ && $/), "ABBBBC", 're_tests 379/0 (489)');
is(("ABBBBC" ~~ rx:P5/(?i)ab{0,}?bc/ && $/), "ABBBBC", 're_tests 381/0 (491)');
is(("ABBC" ~~ rx:P5/(?i)ab+?bc/ && $/), "ABBC", 're_tests 383/0 (493)');
ok((not ("ABC" ~~ rx:P5/(?i)ab+bc/)), 're_tests 385  (495)');
ok((not ("ABQ" ~~ rx:P5/(?i)ab+bc/)), 're_tests 387  (497)');
ok((not ("ABQ" ~~ rx:P5/(?i)ab{1,}bc/)), 're_tests 389  (499)');
is(("ABBBBC" ~~ rx:P5/(?i)ab+bc/ && $/), "ABBBBC", 're_tests 391/0 (501)');
is(("ABBBBC" ~~ rx:P5/(?i)ab{1,}?bc/ && $/), "ABBBBC", 're_tests 393/0 (503)');
is(("ABBBBC" ~~ rx:P5/(?i)ab{1,3}?bc/ && $/), "ABBBBC", 're_tests 395/0 (505)');
is(("ABBBBC" ~~ rx:P5/(?i)ab{3,4}?bc/ && $/), "ABBBBC", 're_tests 397/0 (507)');
ok((not ("ABBBBC" ~~ rx:P5/(?i)ab{4,5}?bc/)), 're_tests 399  (509)');
is(("ABBC" ~~ rx:P5/(?i)ab??bc/ && $/), "ABBC", 're_tests 401/0 (511)');
is(("ABC" ~~ rx:P5/(?i)ab??bc/ && $/), "ABC", 're_tests 403/0 (513)');
is(("ABC" ~~ rx:P5/(?i)ab{0,1}?bc/ && $/), "ABC", 're_tests 405/0 (515)');
ok((not ("ABBBBC" ~~ rx:P5/(?i)ab??bc/)), 're_tests 407  (517)');
is(("ABC" ~~ rx:P5/(?i)ab??c/ && $/), "ABC", 're_tests 409/0 (519)');
is(("ABC" ~~ rx:P5/(?i)ab{0,1}?c/ && $/), "ABC", 're_tests 411/0 (521)');
is(("ABC" ~~ rx:P5/(?i)^abc$/ && $/), "ABC", 're_tests 413/0 (523)');
ok((not ("ABCC" ~~ rx:P5/(?i)^abc$/)), 're_tests 415  (525)');
is(("ABCC" ~~ rx:P5/(?i)^abc/ && $/), "ABC", 're_tests 417/0 (527)');
ok((not ("AABC" ~~ rx:P5/(?i)^abc$/)), 're_tests 419  (529)');
is(("AABC" ~~ rx:P5/(?i)abc$/ && $/), "ABC", 're_tests 421/0 (531)');
is(("ABC" ~~ rx:P5/(?i)^/ && $/), "", 're_tests 423/0 (533)');
is(("ABC" ~~ rx:P5/(?i)$/ && $/), "", 're_tests 425/0 (535)');
is(("ABC" ~~ rx:P5/(?i)a.c/ && $/), "ABC", 're_tests 427/0 (537)');
is(("AXC" ~~ rx:P5/(?i)a.c/ && $/), "AXC", 're_tests 429/0 (539)');
is(("AXYZC" ~~ rx:P5/(?i)a.*?c/ && $/), "AXYZC", 're_tests 431/0 (541)');
ok((not ("AXYZD" ~~ rx:P5/(?i)a.*c/)), 're_tests 433  (543)');
ok((not ("ABC" ~~ rx:P5/(?i)a[bc]d/)), 're_tests 435  (545)');
is(("ABD" ~~ rx:P5/(?i)a[bc]d/ && $/), "ABD", 're_tests 437/0 (547)');
ok((not ("ABD" ~~ rx:P5/(?i)a[b-d]e/)), 're_tests 439  (549)');
is(("ACE" ~~ rx:P5/(?i)a[b-d]e/ && $/), "ACE", 're_tests 441/0 (551)');
is(("AAC" ~~ rx:P5/(?i)a[b-d]/ && $/), "AC", 're_tests 443/0 (553)');
is(("A-" ~~ rx:P5/(?i)a[-b]/ && $/), "A-", 're_tests 445/0 (555)');
is(("A-" ~~ rx:P5/(?i)a[b-]/ && $/), "A-", 're_tests 447/0 (557)');
is(("A]" ~~ rx:P5/(?i)a]/ && $/), "A]", 're_tests 449/0 (559)');
is(("A]B" ~~ rx:P5/(?i)a[]]b/ && $/), "A]B", 're_tests 451/0 (561)');
is(("AED" ~~ rx:P5/(?i)a[^bc]d/ && $/), "AED", 're_tests 453/0 (563)');
ok((not ("ABD" ~~ rx:P5/(?i)a[^bc]d/)), 're_tests 455  (565)');
is(("ADC" ~~ rx:P5/(?i)a[^-b]c/ && $/), "ADC", 're_tests 457/0 (567)');
ok((not ("A-C" ~~ rx:P5/(?i)a[^-b]c/)), 're_tests 459  (569)');
ok((not ("A]C" ~~ rx:P5/(?i)a[^]b]c/)), 're_tests 461  (571)');
is(("ADC" ~~ rx:P5/(?i)a[^]b]c/ && $/), "ADC", 're_tests 463/0 (573)');
is(("ABC" ~~ rx:P5/(?i)ab|cd/ && $/), "AB", 're_tests 465/0 (575)');
is(("ABCD" ~~ rx:P5/(?i)ab|cd/ && $/), "AB", 're_tests 467/0 (577)');
is(("DEF" ~~ rx:P5/(?i)()ef/ && $/), "EF", 're_tests 469/0 (579)');
is(("DEF" ~~ rx:P5/(?i)()ef/ && $0), "", 're_tests 469/1 (580)');
ok((not ("B" ~~ rx:P5/(?i)$b/)), 're_tests 471  (583)');
is(("A(B" ~~ rx:P5/(?i)a\(b/ && $/), "A(B", 're_tests 473/0 (585)');
is(("A(B" ~~ rx:P5/(?i)a\(b/ && $0), "", 're_tests 473/1 (586)');
is(("AB" ~~ rx:P5/(?i)a\(*b/ && $/), "AB", 're_tests 475/0 (589)');
is(("A((B" ~~ rx:P5/(?i)a\(*b/ && $/), "A((B", 're_tests 477/0 (591)');
is(("A\\B" ~~ rx:P5/(?i)a\\b/ && $/), "A\\B", 're_tests 479/0 (593)');
is(("A\\\\B" ~~ rx:P5/(?i)a\\*b/ && $/), "A\\\\B", 're_tests 479/0 (593)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_4.t0000664000175000017500000001756612224265625017627 0ustar  moritzmoritzuse v6;

use Test;

plan 100;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

is(~("ABC" ~~ rx:P5/(?i)((a))/ && $/), "A", 're_tests 481/0 (595)');
is(~("ABC" ~~ rx:P5/(?i)((a))/ && $0), "A", 're_tests 481/1 (596)');
is(~("ABC" ~~ rx:P5/(?i)((a))/ && $1), "A", 're_tests 481/2 (597)');
is(~("ABC" ~~ rx:P5/(?i)(a)b(c)/ && $/), "ABC", 're_tests 483/0 (601)');
is(~("ABC" ~~ rx:P5/(?i)(a)b(c)/ && $0), "A", 're_tests 483/1 (602)');
is(~("ABC" ~~ rx:P5/(?i)(a)b(c)/ && $1), "C", 're_tests 483/2 (603)');
is(~("AABBABC" ~~ rx:P5/(?i)a+b+c/ && $/), "ABC", 're_tests 485/0 (607)');
is(~("AABBABC" ~~ rx:P5/(?i)a{1,}b{1,}c/ && $/), "ABC", 're_tests 487/0 (609)');
is(~("ABCABC" ~~ rx:P5/(?i)a.+?c/ && $/), "ABC", 're_tests 489/0 (611)');
is(~("ABCABC" ~~ rx:P5/(?i)a.*?c/ && $/), "ABC", 're_tests 491/0 (613)');
is(~("ABCABC" ~~ rx:P5/(?i)a.{0,5}?c/ && $/), "ABC", 're_tests 493/0 (615)');
is(~("AB" ~~ rx:P5/(?i)(a+|b)*/ && $/), "AB", 're_tests 495/0 (617)');
is(~("AB" ~~ rx:P5/(?i)(a+|b)*/ && $0), "B", 're_tests 495/1 (618)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){0,}/ && $/), "AB", 're_tests 497/0 (621)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){0,}/ && $0), "B", 're_tests 497/1 (622)');
is(~("AB" ~~ rx:P5/(?i)(a+|b)+/ && $/), "AB", 're_tests 499/0 (625)');
is(~("AB" ~~ rx:P5/(?i)(a+|b)+/ && $0), "B", 're_tests 499/1 (626)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){1,}/ && $/), "AB", 're_tests 501/0 (629)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){1,}/ && $0), "B", 're_tests 501/1 (630)');
is(~("AB" ~~ rx:P5/(?i)(a+|b)?/ && $/), "A", 're_tests 503/0 (633)');
is(~("AB" ~~ rx:P5/(?i)(a+|b)?/ && $0), "A", 're_tests 503/1 (634)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){0,1}/ && $/), "A", 're_tests 505/0 (637)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){0,1}/ && $0), "A", 're_tests 505/1 (638)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){0,1}?/ && $/), "", 're_tests 507/0 (641)');
is(~("AB" ~~ rx:P5/(?i)(a+|b){0,1}?/ && $0), "", 're_tests 507/1 (642)');
is(~("CDE" ~~ rx:P5/(?i)[^ab]*/ && $/), "CDE", 're_tests 509/0 (645)');
ok((not ("" ~~ rx:P5/(?i)abc/)), 're_tests 511  (647)');
is(~("" ~~ rx:P5/(?i)a*/ && $/), "", 're_tests 513/0 (649)');
is(~("ABBBCD" ~~ rx:P5/(?i)([abc])*d/ && $/), "ABBBCD", 're_tests 515/0 (651)');
is(~("ABBBCD" ~~ rx:P5/(?i)([abc])*d/ && $0), "C", 're_tests 515/1 (652)');
is(~("ABCD" ~~ rx:P5/(?i)([abc])*bcd/ && $/), "ABCD", 're_tests 517/0 (655)');
is(~("ABCD" ~~ rx:P5/(?i)([abc])*bcd/ && $0), "A", 're_tests 517/1 (656)');
is(~("E" ~~ rx:P5/(?i)a|b|c|d|e/ && $/), "E", 're_tests 519/0 (659)');
is(~("EF" ~~ rx:P5/(?i)(a|b|c|d|e)f/ && $/), "EF", 're_tests 521/0 (661)');
is(~("EF" ~~ rx:P5/(?i)(a|b|c|d|e)f/ && $0), "E", 're_tests 521/1 (662)');
is(~("ABCDEFG" ~~ rx:P5/(?i)abcd*efg/ && $/), "ABCDEFG", 're_tests 523/0 (665)');
is(~("XABYABBBZ" ~~ rx:P5/(?i)ab*/ && $/), "AB", 're_tests 525/0 (667)');
is(~("XAYABBBZ" ~~ rx:P5/(?i)ab*/ && $/), "A", 're_tests 527/0 (669)');
is(~("ABCDE" ~~ rx:P5/(?i)(ab|cd)e/ && $/), "CDE", 're_tests 529/0 (671)');
is(~("ABCDE" ~~ rx:P5/(?i)(ab|cd)e/ && $0), "CD", 're_tests 529/1 (672)');
is(~("HIJ" ~~ rx:P5/(?i)[abhgefdc]ij/ && $/), "HIJ", 're_tests 531/0 (675)');
is(~("ABCDEF" ~~ rx:P5/(?i)(abc|)ef/ && $/), "EF", 're_tests 533/0 (677)');
is(~("ABCDEF" ~~ rx:P5/(?i)(abc|)ef/ && $0), "", 're_tests 533/1 (678)');
is(~("ABCD" ~~ rx:P5/(?i)(a|b)c*d/ && $/), "BCD", 're_tests 535/0 (681)');
is(~("ABCD" ~~ rx:P5/(?i)(a|b)c*d/ && $0), "B", 're_tests 535/1 (682)');
is(~("ABC" ~~ rx:P5/(?i)(ab|ab*)bc/ && $/), "ABC", 're_tests 537/0 (685)');
is(~("ABC" ~~ rx:P5/(?i)(ab|ab*)bc/ && $0), "A", 're_tests 537/1 (686)');
is(~("ABC" ~~ rx:P5/(?i)a([bc]*)c*/ && $/), "ABC", 're_tests 539/0 (689)');
is(~("ABC" ~~ rx:P5/(?i)a([bc]*)c*/ && $0), "BC", 're_tests 539/1 (690)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]*)(c*d)/ && $/), "ABCD", 're_tests 541/0 (693)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]*)(c*d)/ && $0), "BC", 're_tests 541/1 (694)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]*)(c*d)/ && $1), "D", 're_tests 541/2 (695)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]+)(c*d)/ && $/), "ABCD", 're_tests 543/0 (699)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]+)(c*d)/ && $0), "BC", 're_tests 543/1 (700)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]+)(c*d)/ && $1), "D", 're_tests 543/2 (701)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]*)(c+d)/ && $/), "ABCD", 're_tests 545/0 (705)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]*)(c+d)/ && $0), "B", 're_tests 545/1 (706)');
is(~("ABCD" ~~ rx:P5/(?i)a([bc]*)(c+d)/ && $1), "CD", 're_tests 545/2 (707)');
is(~("ADCDCDE" ~~ rx:P5/(?i)a[bcd]*dcdcde/ && $/), "ADCDCDE", 're_tests 547/0 (711)');
ok(~(not ("ADCDCDE" ~~ rx:P5/(?i)a[bcd]+dcdcde/)), 're_tests 549  (713)');
is(~("ABC" ~~ rx:P5/(?i)(ab|a)b*c/ && $/), "ABC", 're_tests 551/0 (715)');
is(~("ABC" ~~ rx:P5/(?i)(ab|a)b*c/ && $0), "AB", 're_tests 551/1 (716)');
is(~("ALPHA" ~~ rx:P5/(?i)[a-zA-Z_][a-zA-Z0-9_]*/ && $/), "ALPHA", 're_tests 553/0 (719)');
is(~("ABH" ~~ rx:P5/(?i)^a(bc+|b[eh])g|.h$/ && $/), "BH", 're_tests 555/0 (721)');
is(~("ABH" ~~ rx:P5/(?i)^a(bc+|b[eh])g|.h$/ && $0), "", 're_tests 555/1 (722)');
is(~("EFFGZ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $/), "EFFGZ", 're_tests 557/0 (725)');
is(~("EFFGZ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $0), "EFFGZ", 're_tests 557/1 (726)');
is(~("EFFGZ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $1), "", 're_tests 557/2 (727)');
is(~("IJ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $/), "IJ", 're_tests 559/0 (731)');
is(~("IJ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $0), "IJ", 're_tests 559/1 (732)');
is(~("IJ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $1), "J", 're_tests 559/2 (733)');
ok(~(not ("EFFG" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/)), 're_tests 561  (737)');
ok(~(not ("BCDD" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/)), 're_tests 563  (739)');
is(~("REFFGZ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $/), "EFFGZ", 're_tests 565/0 (741)');
is(~("REFFGZ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $0), "EFFGZ", 're_tests 565/1 (742)');
is(~("REFFGZ" ~~ rx:P5/(?i)(bc+d$|ef*g.|h?i(j|k))/ && $1), "", 're_tests 565/2 (743)');
is(~("A" ~~ rx:P5/(?i)((((((((((a))))))))))/ && $00), "A", 're_tests 567/10 (747)');
is(~("AA" ~~ rx:P5/(?i)((((((((((a))))))))))\10/ && $/), "AA", 're_tests 569/0 (749)');
ok((not ("AA" ~~ rx:P5/(?i)((((((((((a))))))))))$bang/)), 're_tests 571  (751)');
#?rakudo todo "variable interpolation"
is(~("A!" ~~ rx:P5/(?i)((((((((((a))))))))))$bang/ && $/), "A!", 're_tests 572/0 (752)');
is(~("A" ~~ rx:P5/(?i)(((((((((a)))))))))/ && $/), "A", 're_tests 573/0 (753)');
is(~("A" ~~ rx:P5/(?i)(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))/ && $0), "A", 're_tests 575/1 (755)');
is(~("C" ~~ rx:P5/(?i)(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))/ && $0), "C", 're_tests 577/1 (757)');
ok((not ("UH-UH" ~~ rx:P5/(?i)multiple words of text/)), 're_tests 579  (759)');
is(~("MULTIPLE WORDS, YEAH" ~~ rx:P5/(?i)multiple words/ && $/), "MULTIPLE WORDS", 're_tests 581/0 (761)');
is(~("ABCDE" ~~ rx:P5/(?i)(.*)c(.*)/ && $/), "ABCDE", 're_tests 583/0 (763)');
is(~("ABCDE" ~~ rx:P5/(?i)(.*)c(.*)/ && $0), "AB", 're_tests 583/1 (764)');
is(~("ABCDE" ~~ rx:P5/(?i)(.*)c(.*)/ && $1), "DE", 're_tests 583/2 (765)');
ok((not ("AB" ~~ rx:P5/(?i)[k]/)), 're_tests 585  (769)');
is(~("AC" ~~ rx:P5/(?i)a[-]?c/ && $/), "AC", 're_tests 587/0 (771)');
is(~("ABCABC" ~~ rx:P5/(?i)(abc)\1/ && $0), "ABC", 're_tests 589/1 (773)');
is(~("ABCABC" ~~ rx:P5/(?i)([a-c]*)\1/ && $0), "ABC", 're_tests 591/1 (775)');
is(~("abad" ~~ rx:P5/a(?!b)./ && $/), "ad", 're_tests 593/0 (777)');
is(~("abad" ~~ rx:P5/a(?=d)./ && $/), "ad", 're_tests 595/0 (779)');
is(~("abad" ~~ rx:P5/a(?=c|d)./ && $/), "ad", 're_tests 597/0 (781)');
is(~("ace" ~~ rx:P5/a(?:b|c|d)(.)/ && $0), "e", 're_tests 599/1 (783)');
is(~("ace" ~~ rx:P5/a(?:b|c|d)*(.)/ && $0), "e", 're_tests 601/1 (785)');
is(~("ace" ~~ rx:P5/a(?:b|c|d)+?(.)/ && $0), "e", 're_tests 603/1 (787)');
is(~("acdbcdbe" ~~ rx:P5/a(?:b|c|d)+?(.)/ && $0), "d", 're_tests 605/1 (789)');
is(~("acdbcdbe" ~~ rx:P5/a(?:b|c|d)+(.)/ && $0), "e", 're_tests 607/1 (791)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_5.t0000664000175000017500000001735212224265625017621 0ustar  moritzmoritzuse v6;

use Test;

plan 102;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){2}(.)/ && $0), "b", 're_tests 609/1 (793)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){4,5}(.)/ && $0), "b", 're_tests 611/1 (795)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){4,5}?(.)/ && $0), "d", 're_tests 613/1 (797)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){6,7}(.)/ && $0), "e", 're_tests 615/1 (799)');
#?rakudo.jvm todo "nigh"
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){6,7}?(.)/ && $0), "e", 're_tests 617/1 (801)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){5,6}(.)/ && $0), "e", 're_tests 619/1 (803)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){5,6}?(.)/ && $0), "b", 're_tests 621/1 (805)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){5,7}(.)/ && $0), "e", 're_tests 623/1 (807)');
is(("acdbcdbe" ~~ rx:P5/a(?:b|c|d){5,7}?(.)/ && $0), "b", 're_tests 625/1 (809)');
is(("AB" ~~ rx:P5/^(.+)?B/ && $0), "A", 're_tests 627/1 (811)');
is(("." ~~ rx:P5/^([^a-z])|(\^)$/ && $0), ".", 're_tests 629/1 (813)');
is(("<&OUT" ~~ rx:P5/^[<>]&/ && $/), "<&", 're_tests 631/0 (815)');
is(("aaaaaaaaaa" ~~ rx:P5/^(a\1?){4}$/ && $0), "aaaa", 're_tests 633/1 (817)');
ok((not ("aaaaaaaaa" ~~ rx:P5/^(a\1?){4}$/)), 're_tests 635  (819)');
ok((not ("aaaaaaaaaaa" ~~ rx:P5/^(a\1?){4}$/)), 're_tests 637  (821)');
#?rakudo todo "unknown issue"
is(("aaaaaaaaaa" ~~ rx:P5/^(a(?(1)\1)){4}$/ && $0), "aaaa", 're_tests 639/1 (823)');
ok((not ("aaaaaaaaa" ~~ rx:P5/^(a(?(1)\1)){4}$/)), 're_tests 641  (825)');
ok((not ("aaaaaaaaaaa" ~~ rx:P5/^(a(?(1)\1)){4}$/)), 're_tests 643  (827)');
is(("aaaaaaaaa" ~~ rx:P5/((a{4})+)/ && $0), "aaaaaaaa", 're_tests 645/1 (829)');
is(("aaaaaaaaaa" ~~ rx:P5/(((aa){2})+)/ && $0), "aaaaaaaa", 're_tests 647/1 (831)');
is(("aaaaaaaaaa" ~~ rx:P5/(((a{2}){2})+)/ && $0), "aaaaaaaa", 're_tests 649/1 (833)');
is(("ab" ~~ rx:P5/(?<=a)b/ && $/), "b", 're_tests 651/0 (835)');
ok((not ("cb" ~~ rx:P5/(?<=a)b/)), 're_tests 653  (837)');
ok((not ("b" ~~ rx:P5/(?<=a)b/)), 're_tests 655  (839)');
is(("ab" ~~ rx:P5/(?

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

is(("a\nb\nc\n" ~~ rx:P5/((?m)^b)/ && $0), "b", 're_tests 763/1 (959)');
#?pugs 2 skip 'reference to non-existent subpattern'
ok((not ("a" ~~ rx:P5/(?(1)a|b)/)), 're_tests 764  (960)');
is(("a" ~~ rx:P5/(?(1)b|a)/ && $/), "a", 're_tests 766/0 (962)');
ok((not ("a" ~~ rx:P5/(x)?(?(1)a|b)/)), 're_tests 768  (964)');
is(("a" ~~ rx:P5/(x)?(?(1)b|a)/ && $/), "a", 're_tests 770/0 (966)');
is(("a" ~~ rx:P5/()?(?(1)b|a)/ && $/), "a", 're_tests 772/0 (968)');
ok((not ("a" ~~ rx:P5/()(?(1)b|a)/)), 're_tests 774  (970)');
is(("a" ~~ rx:P5/()?(?(1)a|b)/ && $/), "a", 're_tests 776/0 (972)');
is(("(blah)" ~~ rx:P5/^(\()?blah(?(1)(\)))$/ && $1), ")", 're_tests 778/2 (974)');
ok((not ("blah)" ~~ rx:P5/^(\()?blah(?(1)(\)))$/)), 're_tests 780  (976)');
ok((not ("(blah" ~~ rx:P5/^(\()?blah(?(1)(\)))$/)), 're_tests 782  (978)');
is(("(blah)" ~~ rx:P5/^(\(+)?blah(?(1)(\)))$/ && $1), ")", 're_tests 784/2 (980)');
ok((not ("blah)" ~~ rx:P5/^(\(+)?blah(?(1)(\)))$/)), 're_tests 786  (982)');
ok((not ("(blah" ~~ rx:P5/^(\(+)?blah(?(1)(\)))$/)), 're_tests 788  (984)');
#?pugs 4 skip 'assertion expected after (?(")'
ok((not ("a" ~~ rx:P5/(?(?{0})a|b)/)), 're_tests 790  (986)');
is(("a" ~~ rx:P5/(?(?{0})b|a)/ && $/), "a", 're_tests 791/0 (987)');
ok((not ("a" ~~ rx:P5/(?(?{1})b|a)/)), 're_tests 792  (988)');
is(("a" ~~ rx:P5/(?(?{1})a|b)/ && $/), "a", 're_tests 793/0 (989)');
ok((not ("a" ~~ rx:P5/(?(?!a)a|b)/)), 're_tests 794  (990)');
is(("a" ~~ rx:P5/(?(?!a)b|a)/ && $/), "a", 're_tests 795/0 (991)');
ok((not ("a" ~~ rx:P5/(?(?=a)b|a)/)), 're_tests 796  (992)');
is(("a" ~~ rx:P5/(?(?=a)a|b)/ && $/), "a", 're_tests 797/0 (993)');
is(("aaab" ~~ rx:P5/(?=(a+?))(\1ab)/ && $1), "aab", 're_tests 798/2 (994)');
ok((not ("aaab" ~~ rx:P5/^(?=(a+?))\1ab/)), 're_tests 800  (996)');
is(("one:" ~~ rx:P5/(\w+:)+/ && $0), "one:", 're_tests 802/1 (998)');
is(("a" ~~ rx:P5/$(?<=^(a))/ && $0), "a", 're_tests 804/1 (1000)');
is(("aaab" ~~ rx:P5/(?=(a+?))(\1ab)/ && $1), "aab", 're_tests 806/2 (1002)');
ok((not ("aaab" ~~ rx:P5/^(?=(a+?))\1ab/)), 're_tests 808  (1004)');
ok((not ("abcd:" ~~ rx:P5/([\w:]+::)?(\w+)$/)), 're_tests 810  (1006)');
is(("abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $0), "", 're_tests 812/1 (1008)');
is(("abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $1), "abcd", 're_tests 812/2 (1009)');
is(("xy:z:::abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $0), "xy:z:::", 're_tests 814/1 (1012)');
is(("xy:z:::abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $1), "abcd", 're_tests 814/2 (1013)');
is(("aexycd" ~~ rx:P5/^[^bcd]*(c+)/ && $0), "c", 're_tests 816/1 (1016)');
is(("caab" ~~ rx:P5/(a*)b+/ && $0), "aa", 're_tests 818/1 (1018)');
ok((not ("abcd:" ~~ rx:P5/([\w:]+::)?(\w+)$/)), 're_tests 820  (1020)');
is(("abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $0), "", 're_tests 822/1 (1022)');
is(("abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $1), "abcd", 're_tests 822/2 (1023)');
is(("xy:z:::abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $0), "xy:z:::", 're_tests 824/1 (1026)');
is(("xy:z:::abcd" ~~ rx:P5/([\w:]+::)?(\w+)$/ && $1), "abcd", 're_tests 824/2 (1027)');
is(("aexycd" ~~ rx:P5/^[^bcd]*(c+)/ && $0), "c", 're_tests 826/1 (1030)');
ok((not ("aaab" ~~ rx:P5/(>a+)ab/)), 're_tests 828  (1032)');
ok(("aaab" ~~ rx:P5/(?>a+)b/), 're_tests 829  (1033)');
is(("a:[b]:" ~~ rx:P5/([[:]+)/ && $0), ":[", 're_tests 831/1 (1035)');
is(("a=[b]=" ~~ rx:P5/([[=]+)/ && $0), "=[", 're_tests 832/1 (1036)');
is(("a.[b]." ~~ rx:P5/([[.]+)/ && $0), ".[", 're_tests 833/1 (1037)');
is(("abc" ~~ rx:P5/[a[:]b[:c]/ && $/), "abc", 're_tests 834/0 (1038)');
is(("abc" ~~ rx:P5/[a[:]b[:c]/ && $/), "abc", 're_tests 835/0 (1039)');
is(("aaab" ~~ rx:P5/((?>a+)b)/ && $0), "aaab", 're_tests 836/1 (1040)');
is(("aaab" ~~ rx:P5/(?>(a+))b/ && $0), "aaa", 're_tests 838/1 (1042)');
is(("((abc(ade)ufh()()x" ~~ rx:P5/((?>[^()]+)|\([^()]*\))+/ && $/), "abc(ade)ufh()()x", 're_tests 840/0 (1044)');
is(("a\nb\n" ~~ rx:P5/\Z/ && $/.from), 3, 're_tests 842/0 (1046)');
is(("a\nb\n" ~~ rx:P5/\z/ && $/.from), 4, 're_tests 844/0 (1048)');
is(("a\nb\n" ~~ rx:P5/$/ && $/.from), 3, 're_tests 846/0 (1050)');
is(("b\na\n" ~~ rx:P5/\Z/ && $/.from), 3, 're_tests 847/0 (1051)');
is(("b\na\n" ~~ rx:P5/\z/ && $/.from), 4, 're_tests 849/0 (1053)');
is(("b\na\n" ~~ rx:P5/$/ && $/.from), 3, 're_tests 851/0 (1055)');
is(("b\na" ~~ rx:P5/\Z/ && $/.from), 3, 're_tests 852/0 (1056)');
is(("b\na" ~~ rx:P5/\z/ && $/.from), 3, 're_tests 854/0 (1058)');
is(("b\na" ~~ rx:P5/$/ && $/.from), 3, 're_tests 856/0 (1060)');
is(("a\nb\n" ~~ rx:P5/(?m)\Z/ && $/.from), 3, 're_tests 857/0 (1061)');
is(("a\nb\n" ~~ rx:P5/(?m)\z/ && $/.from), 4, 're_tests 858/0 (1062)');
is(("a\nb\n" ~~ rx:P5/(?m)$/ && $/.from), 1, 're_tests 859/0 (1063)');
is(("b\na\n" ~~ rx:P5/(?m)\Z/ && $/.from), 3, 're_tests 860/0 (1064)');
is(("b\na\n" ~~ rx:P5/(?m)\z/ && $/.from), 4, 're_tests 861/0 (1065)');
is(("b\na\n" ~~ rx:P5/(?m)$/ && $/.from), 1, 're_tests 862/0 (1066)');
is(("b\na" ~~ rx:P5/(?m)\Z/ && $/.from), 3, 're_tests 863/0 (1067)');
is(("b\na" ~~ rx:P5/(?m)\z/ && $/.from), 3, 're_tests 864/0 (1068)');
is(("b\na" ~~ rx:P5/(?m)$/ && $/.from), 1, 're_tests 865/0 (1069)');
ok((not ("a\nb\n" ~~ rx:P5/a\Z/)), 're_tests 866  (1070)');
ok((not ("a\nb\n" ~~ rx:P5/a\z/)), 're_tests 868  (1072)');
ok((not ("a\nb\n" ~~ rx:P5/a$/)), 're_tests 870  (1074)');
is(("b\na\n" ~~ rx:P5/a\Z/ && $/.from), 2, 're_tests 871/0 (1075)');
ok((not ("b\na\n" ~~ rx:P5/a\z/)), 're_tests 873  (1077)');
is(("b\na\n" ~~ rx:P5/a$/ && $/.from), 2, 're_tests 875/0 (1079)');
is(("b\na" ~~ rx:P5/a\Z/ && $/.from), 2, 're_tests 876/0 (1080)');
is(("b\na" ~~ rx:P5/a\z/ && $/.from), 2, 're_tests 878/0 (1082)');
is(("b\na" ~~ rx:P5/a$/ && $/.from), 2, 're_tests 880/0 (1084)');
ok((not ("a\nb\n" ~~ rx:P5/(?m)a\Z/)), 're_tests 881  (1085)');
ok((not ("a\nb\n" ~~ rx:P5/(?m)a\z/)), 're_tests 882  (1086)');
is(("a\nb\n" ~~ rx:P5/(?m)a$/ && $/.from), 0, 're_tests 883/0 (1087)');
is(("b\na\n" ~~ rx:P5/(?m)a\Z/ && $/.from), 2, 're_tests 884/0 (1088)');
ok((not ("b\na\n" ~~ rx:P5/(?m)a\z/)), 're_tests 885  (1089)');
is(("b\na\n" ~~ rx:P5/(?m)a$/ && $/.from), 2, 're_tests 886/0 (1090)');
is(("b\na" ~~ rx:P5/(?m)a\Z/ && $/.from), 2, 're_tests 887/0 (1091)');
is(("b\na" ~~ rx:P5/(?m)a\z/ && $/.from), 2, 're_tests 888/0 (1092)');
is(("b\na" ~~ rx:P5/(?m)a$/ && $/.from), 2, 're_tests 889/0 (1093)');
ok((not ("aa\nb\n" ~~ rx:P5/aa\Z/)), 're_tests 890  (1094)');
ok((not ("aa\nb\n" ~~ rx:P5/aa\z/)), 're_tests 892  (1096)');
ok((not ("aa\nb\n" ~~ rx:P5/aa$/)), 're_tests 894  (1098)');
is(("b\naa\n" ~~ rx:P5/aa\Z/ && $/.from), 2, 're_tests 895/0 (1099)');
ok((not ("b\naa\n" ~~ rx:P5/aa\z/)), 're_tests 897  (1101)');
is(("b\naa\n" ~~ rx:P5/aa$/ && $/.from), 2, 're_tests 899/0 (1103)');
is(("b\naa" ~~ rx:P5/aa\Z/ && $/.from), 2, 're_tests 900/0 (1104)');
is(("b\naa" ~~ rx:P5/aa\z/ && $/.from), 2, 're_tests 902/0 (1106)');
is(("b\naa" ~~ rx:P5/aa$/ && $/.from), 2, 're_tests 904/0 (1108)');
ok((not ("aa\nb\n" ~~ rx:P5/(?m)aa\Z/)), 're_tests 905  (1109)');
ok((not ("aa\nb\n" ~~ rx:P5/(?m)aa\z/)), 're_tests 906  (1110)');
is(("aa\nb\n" ~~ rx:P5/(?m)aa$/ && $/.from), 0, 're_tests 907/0 (1111)');
is(("b\naa\n" ~~ rx:P5/(?m)aa\Z/ && $/.from), 2, 're_tests 908/0 (1112)');
ok((not ("b\naa\n" ~~ rx:P5/(?m)aa\z/)), 're_tests 909  (1113)');
is(("b\naa\n" ~~ rx:P5/(?m)aa$/ && $/.from), 2, 're_tests 910/0 (1114)');
is(("b\naa" ~~ rx:P5/(?m)aa\Z/ && $/.from), 2, 're_tests 911/0 (1115)');
is(("b\naa" ~~ rx:P5/(?m)aa\z/ && $/.from), 2, 're_tests 912/0 (1116)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_7.t0000664000175000017500000001512112224265625017613 0ustar  moritzmoritzuse v6;

use Test;

plan 100;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

is(("b\naa" ~~ rx:P5/(?m)aa$/ && $/.from), 2, 're_tests 913/0 (1117)');
ok((not ("ac\nb\n" ~~ rx:P5/aa\Z/)), 're_tests 914  (1118)');
ok((not ("ac\nb\n" ~~ rx:P5/aa\z/)), 're_tests 916  (1120)');
ok((not ("ac\nb\n" ~~ rx:P5/aa$/)), 're_tests 918  (1122)');
ok((not ("b\nac\n" ~~ rx:P5/aa\Z/)), 're_tests 919  (1123)');
ok((not ("b\nac\n" ~~ rx:P5/aa\z/)), 're_tests 921  (1125)');
ok((not ("b\nac\n" ~~ rx:P5/aa$/)), 're_tests 923  (1127)');
ok((not ("b\nac" ~~ rx:P5/aa\Z/)), 're_tests 924  (1128)');
ok((not ("b\nac" ~~ rx:P5/aa\z/)), 're_tests 926  (1130)');
ok((not ("b\nac" ~~ rx:P5/aa$/)), 're_tests 928  (1132)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)aa\Z/)), 're_tests 929  (1133)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)aa\z/)), 're_tests 930  (1134)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)aa$/)), 're_tests 931  (1135)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)aa\Z/)), 're_tests 932  (1136)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)aa\z/)), 're_tests 933  (1137)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)aa$/)), 're_tests 934  (1138)');
ok((not ("b\nac" ~~ rx:P5/(?m)aa\Z/)), 're_tests 935  (1139)');
ok((not ("b\nac" ~~ rx:P5/(?m)aa\z/)), 're_tests 936  (1140)');
ok((not ("b\nac" ~~ rx:P5/(?m)aa$/)), 're_tests 937  (1141)');
ok((not ("ca\nb\n" ~~ rx:P5/aa\Z/)), 're_tests 938  (1142)');
ok((not ("ca\nb\n" ~~ rx:P5/aa\z/)), 're_tests 940  (1144)');
ok((not ("ca\nb\n" ~~ rx:P5/aa$/)), 're_tests 942  (1146)');
ok((not ("b\nca\n" ~~ rx:P5/aa\Z/)), 're_tests 943  (1147)');
ok((not ("b\nca\n" ~~ rx:P5/aa\z/)), 're_tests 945  (1149)');
ok((not ("b\nca\n" ~~ rx:P5/aa$/)), 're_tests 947  (1151)');
ok((not ("b\nca" ~~ rx:P5/aa\Z/)), 're_tests 948  (1152)');
ok((not ("b\nca" ~~ rx:P5/aa\z/)), 're_tests 950  (1154)');
ok((not ("b\nca" ~~ rx:P5/aa$/)), 're_tests 952  (1156)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)aa\Z/)), 're_tests 953  (1157)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)aa\z/)), 're_tests 954  (1158)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)aa$/)), 're_tests 955  (1159)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)aa\Z/)), 're_tests 956  (1160)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)aa\z/)), 're_tests 957  (1161)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)aa$/)), 're_tests 958  (1162)');
ok((not ("b\nca" ~~ rx:P5/(?m)aa\Z/)), 're_tests 959  (1163)');
ok((not ("b\nca" ~~ rx:P5/(?m)aa\z/)), 're_tests 960  (1164)');
ok((not ("b\nca" ~~ rx:P5/(?m)aa$/)), 're_tests 961  (1165)');
ok((not ("ab\nb\n" ~~ rx:P5/ab\Z/)), 're_tests 962  (1166)');
ok((not ("ab\nb\n" ~~ rx:P5/ab\z/)), 're_tests 964  (1168)');
ok((not ("ab\nb\n" ~~ rx:P5/ab$/)), 're_tests 966  (1170)');
is(("b\nab\n" ~~ rx:P5/ab\Z/ && $/.from), 2, 're_tests 967/0 (1171)');
ok((not ("b\nab\n" ~~ rx:P5/ab\z/)), 're_tests 969  (1173)');
is(("b\nab\n" ~~ rx:P5/ab$/ && $/.from), 2, 're_tests 971/0 (1175)');
is(("b\nab" ~~ rx:P5/ab\Z/ && $/.from), 2, 're_tests 972/0 (1176)');
is(("b\nab" ~~ rx:P5/ab\z/ && $/.from), 2, 're_tests 974/0 (1178)');
is(("b\nab" ~~ rx:P5/ab$/ && $/.from), 2, 're_tests 976/0 (1180)');
ok((not ("ab\nb\n" ~~ rx:P5/(?m)ab\Z/)), 're_tests 977  (1181)');
ok((not ("ab\nb\n" ~~ rx:P5/(?m)ab\z/)), 're_tests 978  (1182)');
is(("ab\nb\n" ~~ rx:P5/(?m)ab$/ && $/.from), 0, 're_tests 979/0 (1183)');
is(("b\nab\n" ~~ rx:P5/(?m)ab\Z/ && $/.from), 2, 're_tests 980/0 (1184)');
ok((not ("b\nab\n" ~~ rx:P5/(?m)ab\z/)), 're_tests 981  (1185)');
is(("b\nab\n" ~~ rx:P5/(?m)ab$/ && $/.from), 2, 're_tests 982/0 (1186)');
is(("b\nab" ~~ rx:P5/(?m)ab\Z/ && $/.from), 2, 're_tests 983/0 (1187)');
is(("b\nab" ~~ rx:P5/(?m)ab\z/ && $/.from), 2, 're_tests 984/0 (1188)');
is(("b\nab" ~~ rx:P5/(?m)ab$/ && $/.from), 2, 're_tests 985/0 (1189)');
ok((not ("ac\nb\n" ~~ rx:P5/ab\Z/)), 're_tests 986  (1190)');
ok((not ("ac\nb\n" ~~ rx:P5/ab\z/)), 're_tests 988  (1192)');
ok((not ("ac\nb\n" ~~ rx:P5/ab$/)), 're_tests 990  (1194)');
ok((not ("b\nac\n" ~~ rx:P5/ab\Z/)), 're_tests 991  (1195)');
ok((not ("b\nac\n" ~~ rx:P5/ab\z/)), 're_tests 993  (1197)');
ok((not ("b\nac\n" ~~ rx:P5/ab$/)), 're_tests 995  (1199)');
ok((not ("b\nac" ~~ rx:P5/ab\Z/)), 're_tests 996  (1200)');
ok((not ("b\nac" ~~ rx:P5/ab\z/)), 're_tests 998  (1202)');
ok((not ("b\nac" ~~ rx:P5/ab$/)), 're_tests 1000  (1204)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)ab\Z/)), 're_tests 1001  (1205)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)ab\z/)), 're_tests 1002  (1206)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)ab$/)), 're_tests 1003  (1207)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)ab\Z/)), 're_tests 1004  (1208)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)ab\z/)), 're_tests 1005  (1209)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)ab$/)), 're_tests 1006  (1210)');
ok((not ("b\nac" ~~ rx:P5/(?m)ab\Z/)), 're_tests 1007  (1211)');
ok((not ("b\nac" ~~ rx:P5/(?m)ab\z/)), 're_tests 1008  (1212)');
ok((not ("b\nac" ~~ rx:P5/(?m)ab$/)), 're_tests 1009  (1213)');
ok((not ("ca\nb\n" ~~ rx:P5/ab\Z/)), 're_tests 1010  (1214)');
ok((not ("ca\nb\n" ~~ rx:P5/ab\z/)), 're_tests 1012  (1216)');
ok((not ("ca\nb\n" ~~ rx:P5/ab$/)), 're_tests 1014  (1218)');
ok((not ("b\nca\n" ~~ rx:P5/ab\Z/)), 're_tests 1015  (1219)');
ok((not ("b\nca\n" ~~ rx:P5/ab\z/)), 're_tests 1017  (1221)');
ok((not ("b\nca\n" ~~ rx:P5/ab$/)), 're_tests 1019  (1223)');
ok((not ("b\nca" ~~ rx:P5/ab\Z/)), 're_tests 1020  (1224)');
ok((not ("b\nca" ~~ rx:P5/ab\z/)), 're_tests 1022  (1226)');
ok((not ("b\nca" ~~ rx:P5/ab$/)), 're_tests 1024  (1228)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)ab\Z/)), 're_tests 1025  (1229)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)ab\z/)), 're_tests 1026  (1230)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)ab$/)), 're_tests 1027  (1231)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)ab\Z/)), 're_tests 1028  (1232)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)ab\z/)), 're_tests 1029  (1233)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)ab$/)), 're_tests 1030  (1234)');
ok((not ("b\nca" ~~ rx:P5/(?m)ab\Z/)), 're_tests 1031  (1235)');
ok((not ("b\nca" ~~ rx:P5/(?m)ab\z/)), 're_tests 1032  (1236)');
ok((not ("b\nca" ~~ rx:P5/(?m)ab$/)), 're_tests 1033  (1237)');
ok((not ("abb\nb\n" ~~ rx:P5/abb\Z/)), 're_tests 1034  (1238)');
ok((not ("abb\nb\n" ~~ rx:P5/abb\z/)), 're_tests 1036  (1240)');
ok((not ("abb\nb\n" ~~ rx:P5/abb$/)), 're_tests 1038  (1242)');
is(("b\nabb\n" ~~ rx:P5/abb\Z/ && $/.from), 2, 're_tests 1039/0 (1243)');
ok((not ("b\nabb\n" ~~ rx:P5/abb\z/)), 're_tests 1041  (1245)');
is(("b\nabb\n" ~~ rx:P5/abb$/ && $/.from), 2, 're_tests 1043/0 (1247)');
is(("b\nabb" ~~ rx:P5/abb\Z/ && $/.from), 2, 're_tests 1044/0 (1248)');
is(("b\nabb" ~~ rx:P5/abb\z/ && $/.from), 2, 're_tests 1046/0 (1250)');
is(("b\nabb" ~~ rx:P5/abb$/ && $/.from), 2, 're_tests 1048/0 (1252)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_8.t0000664000175000017500000002042412224265625017616 0ustar  moritzmoritzuse v6;

use Test;

plan 103;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

# force_todo(73..75); # PCRE hard parsefails

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

ok((not ("abb\nb\n" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1049  (1253)');
ok((not ("abb\nb\n" ~~ rx:P5/(?m)abb\z/)), 're_tests 1050  (1254)');
is(("abb\nb\n" ~~ rx:P5/(?m)abb$/ && $/.from), 0, 're_tests 1051/0 (1255)');
is(("b\nabb\n" ~~ rx:P5/(?m)abb\Z/ && $/.from), 2, 're_tests 1052/0 (1256)');
ok((not ("b\nabb\n" ~~ rx:P5/(?m)abb\z/)), 're_tests 1053  (1257)');
is(("b\nabb\n" ~~ rx:P5/(?m)abb$/ && $/.from), 2, 're_tests 1054/0 (1258)');
is(("b\nabb" ~~ rx:P5/(?m)abb\Z/ && $/.from), 2, 're_tests 1055/0 (1259)');
is(("b\nabb" ~~ rx:P5/(?m)abb\z/ && $/.from), 2, 're_tests 1056/0 (1260)');
is(("b\nabb" ~~ rx:P5/(?m)abb$/ && $/.from), 2, 're_tests 1057/0 (1261)');
ok((not ("ac\nb\n" ~~ rx:P5/abb\Z/)), 're_tests 1058  (1262)');
ok((not ("ac\nb\n" ~~ rx:P5/abb\z/)), 're_tests 1060  (1264)');
ok((not ("ac\nb\n" ~~ rx:P5/abb$/)), 're_tests 1062  (1266)');
ok((not ("b\nac\n" ~~ rx:P5/abb\Z/)), 're_tests 1063  (1267)');
ok((not ("b\nac\n" ~~ rx:P5/abb\z/)), 're_tests 1065  (1269)');
ok((not ("b\nac\n" ~~ rx:P5/abb$/)), 're_tests 1067  (1271)');
ok((not ("b\nac" ~~ rx:P5/abb\Z/)), 're_tests 1068  (1272)');
ok((not ("b\nac" ~~ rx:P5/abb\z/)), 're_tests 1070  (1274)');
ok((not ("b\nac" ~~ rx:P5/abb$/)), 're_tests 1072  (1276)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1073  (1277)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)abb\z/)), 're_tests 1074  (1278)');
ok((not ("ac\nb\n" ~~ rx:P5/(?m)abb$/)), 're_tests 1075  (1279)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1076  (1280)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)abb\z/)), 're_tests 1077  (1281)');
ok((not ("b\nac\n" ~~ rx:P5/(?m)abb$/)), 're_tests 1078  (1282)');
ok((not ("b\nac" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1079  (1283)');
ok((not ("b\nac" ~~ rx:P5/(?m)abb\z/)), 're_tests 1080  (1284)');
ok((not ("b\nac" ~~ rx:P5/(?m)abb$/)), 're_tests 1081  (1285)');
ok((not ("ca\nb\n" ~~ rx:P5/abb\Z/)), 're_tests 1082  (1286)');
ok((not ("ca\nb\n" ~~ rx:P5/abb\z/)), 're_tests 1084  (1288)');
ok((not ("ca\nb\n" ~~ rx:P5/abb$/)), 're_tests 1086  (1290)');
ok((not ("b\nca\n" ~~ rx:P5/abb\Z/)), 're_tests 1087  (1291)');
ok((not ("b\nca\n" ~~ rx:P5/abb\z/)), 're_tests 1089  (1293)');
ok((not ("b\nca\n" ~~ rx:P5/abb$/)), 're_tests 1091  (1295)');
ok((not ("b\nca" ~~ rx:P5/abb\Z/)), 're_tests 1092  (1296)');
ok((not ("b\nca" ~~ rx:P5/abb\z/)), 're_tests 1094  (1298)');
ok((not ("b\nca" ~~ rx:P5/abb$/)), 're_tests 1096  (1300)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1097  (1301)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)abb\z/)), 're_tests 1098  (1302)');
ok((not ("ca\nb\n" ~~ rx:P5/(?m)abb$/)), 're_tests 1099  (1303)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1100  (1304)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)abb\z/)), 're_tests 1101  (1305)');
ok((not ("b\nca\n" ~~ rx:P5/(?m)abb$/)), 're_tests 1102  (1306)');
ok((not ("b\nca" ~~ rx:P5/(?m)abb\Z/)), 're_tests 1103  (1307)');
ok((not ("b\nca" ~~ rx:P5/(?m)abb\z/)), 're_tests 1104  (1308)');
ok((not ("b\nca" ~~ rx:P5/(?m)abb$/)), 're_tests 1105  (1309)');
is(("ca" ~~ rx:P5/(^|x)(c)/ && $1), "c", 're_tests 1106/2 (1310)');
ok((not ("x" ~~ rx:P5/a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz/)), 're_tests 1108  (1312)');
#?rakudo todo '(?>...) not implemented'
is(("_I(round(xs * sz),1)" ~~ rx:P5/round\(((?>[^()]+))\)/ && $0), "xs * sz", 're_tests 1110/1 (1314)');
ok(("foo.bart" ~~ rx:P5/foo.bart/), 're_tests 1112  (1316)');
ok(("abcd\ndxxx" ~~ rx:P5/(?m)^d[x][x][x]/), 're_tests 1114  (1318)');
#?rakudo 18 skip 'expensive quantifier'
#?pugs todo "pugs regression"
ok(("bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+X/), 're_tests 1115  (1319)');
#?pugs todo "pugs regression"
ok(("bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+XX/), 're_tests 1117  (1321)');
#?pugs todo "pugs regression"
ok(("bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.XX(.+)+X/), 're_tests 1119  (1323)');
ok((not ("bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+X/)), 're_tests 1121  (1325)');
ok((not ("bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+XX/)), 're_tests 1123  (1327)');
ok((not ("bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.XX(.+)+X/)), 're_tests 1125  (1329)');
#?pugs 3 todo 'bug'
ok(("bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+[X]/), 're_tests 1127  (1331)');
ok(("bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+[X][X]/), 're_tests 1129  (1333)');
ok(("bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.XX(.+)+[X]/), 're_tests 1131  (1335)');
ok((not ("bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+[X]/)), 're_tests 1133  (1337)');
ok((not ("bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.X(.+)+[X][X]/)), 're_tests 1135  (1339)');
ok((not ("bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.XX(.+)+[X]/)), 're_tests 1137  (1341)');
#?pugs 3 todo 'bug'
ok(("bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.[X](.+)+[X]/), 're_tests 1139  (1343)');
ok(("bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.[X](.+)+[X][X]/), 're_tests 1141  (1345)');
ok(("bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.[X][X](.+)+[X]/), 're_tests 1143  (1347)');
ok((not ("bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.[X](.+)+[X]/)), 're_tests 1145  (1349)');
ok((not ("bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.[X](.+)+[X][X]/)), 're_tests 1147  (1351)');
ok((not ("bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ~~ rx:P5/.[X][X](.+)+[X]/)), 're_tests 1149  (1353)');
ok(("xxxtt" ~~ rx:P5/tt+$/), 're_tests 1151  (1355)');
#?rakudo 6 skip 'character classes in enumerated range'
is(("za-9z" ~~ rx:P5/([a-\d]+)/ && $0), "a-9", 're_tests 1153/1 (1357)');
is(("a0-za" ~~ rx:P5/([\d-z]+)/ && $0), "0-z", 're_tests 1155/1 (1359)');
is(("a0- z" ~~ rx:P5/([\d-\s]+)/ && $0), "0- ", 're_tests 1157/1 (1361)');
#?pugs skip "PCRE hard parsefail"
is(("za-9z" ~~ rx:P5/([a-[:digit:]]+)/ && $0), "a-9", 're_tests 1159/1 (1363)');
is(("=0-z=" ~~ rx:P5/([[:digit:]-z]+)/ && $0), "0-z", 're_tests 1160/1 (1364)');
is(("=0-z=" ~~ rx:P5/([[:digit:]-[:alpha:]]+)/ && $0), "0-z", 're_tests 1161/1 (1365)');
#?rakudo skip '\G'
ok((not ("aaaXbX" ~~ rx:P5/\GX.*X/)), 're_tests 1162  (1366)');
is(("3.1415926" ~~ rx:P5/(\d+\.\d+)/ && $0), "3.1415926", 're_tests 1163/1 (1367)');
is(("have a web browser" ~~ rx:P5/(\ba.{0,10}br)/ && $0), "a web br", 're_tests 1165/1 (1369)');
ok((not ("Changes" ~~ rx:P5/(?i)\.c(pp|xx|c)?$/)), 're_tests 1167  (1371)');
ok(("IO.c" ~~ rx:P5/(?i)\.c(pp|xx|c)?$/), 're_tests 1169  (1373)');
is(("IO.c" ~~ rx:P5/(?i)(\.c(pp|xx|c)?$)/ && $0), ".c", 're_tests 1171/1 (1375)');
ok((not ("C:/" ~~ rx:P5/^([a-z]:)/)), 're_tests 1173  (1377)');
ok(("\nx aa" ~~ rx:P5/(?m)^\S\s+aa$/), 're_tests 1175  (1379)');
ok(("ab" ~~ rx:P5/(^|a)b/), 're_tests 1176  (1380)');
ok((not ("abcab" ~~ rx:P5/(\w)?(abc)\1b/)), 're_tests 1178  (1382)');
ok(("a,b,c" ~~ rx:P5/^(?:.,){2}c/), 're_tests 1180  (1384)');
is(("a,b,c" ~~ rx:P5/^(.,){2}c/ && $0), "b,", 're_tests 1182/1 (1386)');
ok(("a,b,c" ~~ rx:P5/^(?:[^,]*,){2}c/), 're_tests 1184  (1388)');
is(("a,b,c" ~~ rx:P5/^([^,]*,){2}c/ && $0), "b,", 're_tests 1186/1 (1390)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]*,){3}d/ && $0), "c,", 're_tests 1188/1 (1392)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]*,){3,}d/ && $0), "c,", 're_tests 1190/1 (1394)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]*,){0,3}d/ && $0), "c,", 're_tests 1192/1 (1396)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{1,3},){3}d/ && $0), "c,", 're_tests 1194/1 (1398)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{1,3},){3,}d/ && $0), "c,", 're_tests 1196/1 (1400)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{1,3},){0,3}d/ && $0), "c,", 're_tests 1198/1 (1402)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{1,},){3}d/ && $0), "c,", 're_tests 1200/1 (1404)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{1,},){3,}d/ && $0), "c,", 're_tests 1202/1 (1406)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{1,},){0,3}d/ && $0), "c,", 're_tests 1204/1 (1408)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{0,3},){3}d/ && $0), "c,", 're_tests 1206/1 (1410)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{0,3},){3,}d/ && $0), "c,", 're_tests 1208/1 (1412)');
is(("aaa,b,c,d" ~~ rx:P5/^([^,]{0,3},){0,3}d/ && $0), "c,", 're_tests 1210/1 (1414)');
ok(("" ~~ rx:P5/(?i)/), 're_tests 1212  (1416)');
ok(("a\nxb\n" ~~ rx:P5/(?m)(?!\A)x/), 're_tests 1214  (1418)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/perl5_9.t0000664000175000017500000001543312224265625017623 0ustar  moritzmoritzuse v6;

use Test;

plan 84;

#L

unless "a" ~~ rx:P5/a/ {
  skip_rest "skipped tests - P5 regex support appears to be missing";
  exit;
}

force_todo(18,67); # PCRE hard parsefails

my $b = 'x';
my $backspace = "\b";
my $bang = '!';

ok(("123\nabcabcabcabc\n" ~~ rx:P5/(?m)^.{9}abc.*\n/), 're_tests 1215  (1419)');
ok((not ("a" ~~ rx:P5/^(a)?(?(1)a|b)+$/)), 're_tests 1216  (1420)');
#?pugs todo
is(("aaaaaa" ~~ rx:P5/^(a\1?){4}$/ && $0), "aa", 're_tests 1218/1 (1422)');
ok(("x1" ~~ rx:P5/^(0+)?(?:x(1))?/), 're_tests 1220  (1424)');
ok(("012cxx0190" ~~ rx:P5/^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))?/), 're_tests 1222  (1426)');
is(("bbbac" ~~ rx:P5/^(b+?|a){1,2}c/ && $0), "a", 're_tests 1224/1 (1428)');
is(("bbbbac" ~~ rx:P5/^(b+?|a){1,2}c/ && $0), "a", 're_tests 1226/1 (1430)');
ok(("aaaacccc" ~~ rx:P5/((?:aaaa|bbbb)cccc)?/), 're_tests 1228  (1432)');
ok(("bbbbcccc" ~~ rx:P5/((?:aaaa|bbbb)cccc)?/), 're_tests 1230  (1434)');
is(("a" ~~ rx:P5/(a)?(a)+/ && $0), "", 're_tests 1232/1 (1436)');
is(("a" ~~ rx:P5/(a)?(a)+/ && $1), "a", 're_tests 1232/2 (1437)');
is(("ab" ~~ rx:P5/(ab)?(ab)+/ && $0), "", 're_tests 1234/1 (1440)');
is(("ab" ~~ rx:P5/(ab)?(ab)+/ && $1), "ab", 're_tests 1234/2 (1441)');
is(("abc" ~~ rx:P5/(abc)?(abc)+/ && $0), "", 're_tests 1236/1 (1444)');
is(("abc" ~~ rx:P5/(abc)?(abc)+/ && $1), "abc", 're_tests 1236/2 (1445)');
ok((not ("a\nb\n" ~~ rx:P5/(?m)b\s^/)), 're_tests 1238  (1448)');
ok(("a" ~~ rx:P5/\ba/), 're_tests 1239  (1449)');
#?pugs skip "PCRE hard parsefail"
is(("ab" ~~ rx:P5/^(a(??{"(?!)"})|(a)(?{1}))b/ && $1), "a", 're_tests 1241/2 (1451)');
ok((not ("AbCd" ~~ rx:P5/ab(?i)cd/)), 're_tests 1242  (1452)');
ok(("abCd" ~~ rx:P5/ab(?i)cd/), 're_tests 1244  (1454)');
is(("CD" ~~ rx:P5/(A|B)*(?(1)(CD)|(CD))/ && $1), "", 're_tests 1246/2 (1456)');
is(("CD" ~~ rx:P5/(A|B)*(?(1)(CD)|(CD))/ && $2), "CD", 're_tests 1246/3 (1457)');
is(("ABCD" ~~ rx:P5/(A|B)*(?(1)(CD)|(CD))/ && $1), "CD", 're_tests 1248/2 (1460)');
is(("ABCD" ~~ rx:P5/(A|B)*(?(1)(CD)|(CD))/ && $2), "", 're_tests 1248/3 (1461)');
is(("CD" ~~ rx:P5/(A|B)*?(?(1)(CD)|(CD))/ && $1), "", 're_tests 1250/2 (1464)');
is(("CD" ~~ rx:P5/(A|B)*?(?(1)(CD)|(CD))/ && $2), "CD", 're_tests 1250/3 (1465)');
is(("ABCD" ~~ rx:P5/(A|B)*?(?(1)(CD)|(CD))/ && $1), "CD", 're_tests 1252/2 (1468)');
is(("ABCD" ~~ rx:P5/(A|B)*?(?(1)(CD)|(CD))/ && $2), "", 're_tests 1252/3 (1469)');
ok((not ("Oo" ~~ rx:P5/(?i)^(o)(?!.*\1)/)), 're_tests 1254  (1472)');
is(("abc12bc" ~~ rx:P5/(.*)\d+\1/ && $0), "bc", 're_tests 1256/1 (1474)');
is(("foo\n bar" ~~ rx:P5/(?m:(foo\s*$))/ && $0), "foo", 're_tests 1258/1 (1476)');
is(("abcd" ~~ rx:P5/(.*)c/ && $0), "ab", 're_tests 1259/1 (1477)');
is(("abcd" ~~ rx:P5/(.*)(?=c)/ && $0), "ab", 're_tests 1261/1 (1479)');
is(("abcd" ~~ rx:P5/(.*)(?=c)c/ && $0), "ab", 're_tests 1263/1 (1481)');
is(("abcd" ~~ rx:P5/(.*)(?=b|c)/ && $0), "ab", 're_tests 1265/1 (1483)');
is(("abcd" ~~ rx:P5/(.*)(?=b|c)c/ && $0), "ab", 're_tests 1267/1 (1485)');
is(("abcd" ~~ rx:P5/(.*)(?=c|b)/ && $0), "ab", 're_tests 1269/1 (1487)');
is(("abcd" ~~ rx:P5/(.*)(?=c|b)c/ && $0), "ab", 're_tests 1271/1 (1489)');
is(("abcd" ~~ rx:P5/(.*)(?=[bc])/ && $0), "ab", 're_tests 1273/1 (1491)');
is(("abcd" ~~ rx:P5/(.*)(?=[bc])c/ && $0), "ab", 're_tests 1275/1 (1493)');
is(("abcd" ~~ rx:P5/(.*)(?<=b)/ && $0), "ab", 're_tests 1277/1 (1495)');
is(("abcd" ~~ rx:P5/(.*)(?<=b)c/ && $0), "ab", 're_tests 1279/1 (1497)');
is(("abcd" ~~ rx:P5/(.*)(?<=b|c)/ && $0), "abc", 're_tests 1281/1 (1499)');
is(("abcd" ~~ rx:P5/(.*)(?<=b|c)c/ && $0), "ab", 're_tests 1283/1 (1501)');
is(("abcd" ~~ rx:P5/(.*)(?<=c|b)/ && $0), "abc", 're_tests 1285/1 (1503)');
is(("abcd" ~~ rx:P5/(.*)(?<=c|b)c/ && $0), "ab", 're_tests 1287/1 (1505)');
is(("abcd" ~~ rx:P5/(.*)(?<=[bc])/ && $0), "abc", 're_tests 1289/1 (1507)');
is(("abcd" ~~ rx:P5/(.*)(?<=[bc])c/ && $0), "ab", 're_tests 1291/1 (1509)');
is(("abcd" ~~ rx:P5/(.*?)c/ && $0), "ab", 're_tests 1293/1 (1511)');
is(("abcd" ~~ rx:P5/(.*?)(?=c)/ && $0), "ab", 're_tests 1295/1 (1513)');
is(("abcd" ~~ rx:P5/(.*?)(?=c)c/ && $0), "ab", 're_tests 1297/1 (1515)');
is(("abcd" ~~ rx:P5/(.*?)(?=b|c)/ && $0), "a", 're_tests 1299/1 (1517)');
is(("abcd" ~~ rx:P5/(.*?)(?=b|c)c/ && $0), "ab", 're_tests 1301/1 (1519)');
is(("abcd" ~~ rx:P5/(.*?)(?=c|b)/ && $0), "a", 're_tests 1303/1 (1521)');
is(("abcd" ~~ rx:P5/(.*?)(?=c|b)c/ && $0), "ab", 're_tests 1305/1 (1523)');
is(("abcd" ~~ rx:P5/(.*?)(?=[bc])/ && $0), "a", 're_tests 1307/1 (1525)');
is(("abcd" ~~ rx:P5/(.*?)(?=[bc])c/ && $0), "ab", 're_tests 1309/1 (1527)');
is(("abcd" ~~ rx:P5/(.*?)(?<=b)/ && $0), "ab", 're_tests 1311/1 (1529)');
is(("abcd" ~~ rx:P5/(.*?)(?<=b)c/ && $0), "ab", 're_tests 1313/1 (1531)');
is(("abcd" ~~ rx:P5/(.*?)(?<=b|c)/ && $0), "ab", 're_tests 1315/1 (1533)');
is(("abcd" ~~ rx:P5/(.*?)(?<=b|c)c/ && $0), "ab", 're_tests 1317/1 (1535)');
is(("abcd" ~~ rx:P5/(.*?)(?<=c|b)/ && $0), "ab", 're_tests 1319/1 (1537)');
is(("abcd" ~~ rx:P5/(.*?)(?<=c|b)c/ && $0), "ab", 're_tests 1321/1 (1539)');
is(("abcd" ~~ rx:P5/(.*?)(?<=[bc])/ && $0), "ab", 're_tests 1323/1 (1541)');
is(("abcd" ~~ rx:P5/(.*?)(?<=[bc])c/ && $0), "ab", 're_tests 1325/1 (1543)');
is(("2" ~~ rx:P5/2(]*)?$\1/ && $/), "2", 're_tests 1327/0 (1545)');
#?pugs skip "PCRE hard parsefail"
ok(("x" ~~ rx:P5/(??{})/), 're_tests 1329  (1547)');
is(("foobarbar" ~~ rx:P5/^.{3,4}(.+)\1\z/ && $0), "bar", 're_tests 1330/1 (1548)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){3,4}(.+)\1\z/ && $0), "bar", 're_tests 1332/1 (1550)');
is(("foobarbar" ~~ rx:P5/^.{3,4}((?:b|a|r)+)\1\z/ && $0), "bar", 're_tests 1334/1 (1552)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){3,4}((?:b|a|r)+)\1\z/ && $0), "bar", 're_tests 1336/1 (1554)');
is(("foobarbar" ~~ rx:P5/^.{3,4}(.+?)\1\z/ && $0), "bar", 're_tests 1338/1 (1556)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){3,4}(.+?)\1\z/ && $0), "bar", 're_tests 1340/1 (1558)');
is(("foobarbar" ~~ rx:P5/^.{3,4}((?:b|a|r)+?)\1\z/ && $0), "bar", 're_tests 1342/1 (1560)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){3,4}((?:b|a|r)+?)\1\z/ && $0), "bar", 're_tests 1344/1 (1562)');
is(("foobarbar" ~~ rx:P5/^.{2,3}?(.+)\1\z/ && $0), "bar", 're_tests 1346/1 (1564)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){2,3}?(.+)\1\z/ && $0), "bar", 're_tests 1348/1 (1566)');
is(("foobarbar" ~~ rx:P5/^.{2,3}?((?:b|a|r)+)\1\z/ && $0), "bar", 're_tests 1350/1 (1568)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){2,3}?((?:b|a|r)+)\1\z/ && $0), "bar", 're_tests 1352/1 (1570)');
is(("foobarbar" ~~ rx:P5/^.{2,3}?(.+?)\1\z/ && $0), "bar", 're_tests 1354/1 (1572)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){2,3}?(.+?)\1\z/ && $0), "bar", 're_tests 1356/1 (1574)');
is(("foobarbar" ~~ rx:P5/^.{2,3}?((?:b|a|r)+?)\1\z/ && $0), "bar", 're_tests 1358/1 (1576)');
is(("foobarbar" ~~ rx:P5/^(?:f|o|b){2,3}?((?:b|a|r)+?)\1\z/ && $0), "bar", 're_tests 1360/1 (1578)');
ok((not ("......abef" ~~ rx:P5/.*a(?!(b|cd)*e).*f/)), 're_tests 1362  (1580)');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/pos.t0000664000175000017500000000725012224265625017143 0ustar  moritzmoritzuse v6;
use Test;

=begin origin

This file was originally derived from the perl5 CPAN module Perl6::Rules,
version 0.3 (12 Apr 2004), file t/continue.t.

=end origin

plan 40;

# L

for ("abcdef") {
    ok(m:pos/abc/, "Matched 1: '$/'" );
    #?pugs todo
    is($/.to, 3, 'Interim position correct');
    ok(m:pos/ghi|def/, "Matched 2: '$/'" );
    #?pugs todo
    is($/.to, 6, 'Final position correct');
}

{
    $_ = "foofoofoo foofoofoo";
    my $/;
    ok(s:global:pos/foo/FOO/, 'Globally contiguous substitution');
    #?pugs todo
    #?rakudo todo "s:pos/// NYI"
    is($_, "FOOFOOFOO foofoofoo", 'Correctly substituted contiguously');
}

#?pugs todo
{
    my $str = "abcabcabc";
    my $/;
    ok($str ~~ m:p/abc/, 'Continued match');

    ok($/.to == 3, 'Continued match pos');

    # since match positions are now part of the match (and not the string),
    # assigning to the string doesn't reset anything
    $str = "abcabcabc";
    my $x = $str ~~ m:i:p/abc/;
    ok($/.to == 6, 'Insensitive continued match pos');

    $x = $str ~~ m:i:p/abc/;
    ok($/.to == 9, 'Insensitive recontinued match pos');
}

#?niecza skip ':i'
{
    my $str = "abcabcabc";
    my @x = $str ~~ m:i:g:p/abc/;
    #?pugs todo
    #?rakudo todo 'm:g'
    is("@x", "abc abc abc", 'Insensitive repeated continued match');
    #?pugs todo
    ok($/.to == 9, 'Insensitive repeated continued match pos');

    ok ($str !~~ m:i:p/abc/, 'no more match, string exhausted');
}

#?niecza skip ':i'
#?pugs todo
{
    my $str = "abcabcabc";
    my @x = ?($str ~~ m:p:i:g/abc/);
    # XXX is that correct?
    #?rakudo todo "m:p:i:g// NYI"
    is($/.to,  3, 'Insensitive scalar repeated continued match pos');
}

#?pugs skip 'Cannot parse regex'
{
   my $str = "abcabcabc";
   my $match = $str.match(/abc/, :p(0));
   ok $match.Bool, "Match anchored to 0";
   is $match.from, 0, "and the match is in the correct position";
   nok $str.match(/abc/, :p(1)).Bool, "No match anchored to 1";
   nok $str.match(/abc/, :p(2)).Bool, "No match anchored to 2";

   $match = $str.match(/abc/, :p(3));
   ok $match.Bool, "Match anchored to 3";
   is $match.from, 3, "and the match is in the correct position";
   nok $str.match(/abc/, :p(4)).Bool, "No match anchored to 4";
   
   $match = $str.match(/abc/, :p(6));
   ok $match.Bool, "Match anchored to 6";
   is $match.from, 6, "and the match is in the correct position";
   nok $str.match(/abc/, :p(7)).Bool, "No match anchored to 7";
   nok $str.match(/abc/, :p(8)).Bool, "No match anchored to 8";
   nok $str.match(/abc/, :p(9)).Bool, "No match anchored to 9";
   nok $str.match(/abc/, :p(10)).Bool, "No match anchored to 10";
}

{
   my $str = "abcabcabc";
   my $match = $str.match(/abc/, :pos(0));
   #?pugs todo
   ok $match.Bool, "Match anchored to 0";
   is $match.from, 0, "and the match is in the correct position";
   nok $str.match(/abc/, :pos(1)).Bool, "No match anchored to 1";
   nok $str.match(/abc/, :pos(2)).Bool, "No match anchored to 2";

   $match = $str.match(/abc/, :pos(3));
   #?pugs todo
   ok $match.Bool, "Match anchored to 3";
   #?pugs todo
   is $match.from, 3, "and the match is in the correct position";
   nok $str.match(/abc/, :pos(4)).Bool, "No match anchored to 4";
   
   $match = $str.match(/abc/, :pos(6));
   #?pugs todo
   ok $match.Bool, "Match anchored to 6";
   #?pugs todo
   is $match.from, 6, "and the match is in the correct position";
   nok $str.match(/abc/, :pos(7)).Bool, "No match anchored to 7";
   nok $str.match(/abc/, :pos(8)).Bool, "No match anchored to 8";
   nok $str.match(/abc/, :pos(9)).Bool, "No match anchored to 9";
   nok $str.match(/abc/, :pos(10)).Bool, "No match anchored to 10";
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/ratchet.t0000664000175000017500000000147112224265625017773 0ustar  moritzmoritzuse v6;
use Test;

#L
# for other tests see
# t/spec/S05-mass/rx.t

# backtracking
regex aplus { a+ };

ok 'aaaa'  ~~ m/ ^  a $ /, 'normal regexes backtrack into subrules';
ok 'aaaa' !~~ m/ :ratchet ^  a $ /, ' ... but not with :ratchet';

# what follows now might make your head twitch. Don't worry about that, it's
# normal. See http://irclog.perlgeek.de/perl6/2009-10-12#i_1595951 for a
# discussion

ok 'aaaa' !~~ m/ :ratchet ^ [ :!ratchet  ] a /,
   'if the failing atom is outside the :!ratchet group: no backtracking';
ok 'aaaa'  ~~ m/ :ratchet ^ [ :!ratchet  a ]  /,
   'if the failing atom is inside the :!ratchet group: backtracking';

ok 'aaaa'  ~~ m/ ^ :!ratchet  :ratchet a  /,
   'Same if not grouped';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/repetition-exhaustive.t0000664000175000017500000000144412224265625022706 0ustar  moritzmoritzuse v6;
use Test;

plan 5;

=begin description

The C<:ex> and C<:x($count)> modifiers are orthogonal, and therefore 
can be combined.

Still lacking are tests for C<$/>, since the specs are not clear 
how the C<$/> looks like with the C<:x($count)> modifier.

=end description

#L
#L

my $str = "abbb";
regex rx { a b+ };

ok($str  ~~ m:ex:x(2)//, "Simple combination of :x(2) and :exhaustive");
is(~$/[0],  "ab", 'First entry of prev. genenerated $/');
is(~$/[1], "abb", 'Second entry of prev. genenerated $/');
ok($str  ~~ m:ex:x(3)//, "Simple combination of :x(3) and :exhaustive");
ok($str !~~ m:ex:x(4)//, "Simple combination of :x(4) and :exhaustive");


# vim: syn=perl6 sw=4 ts=4 expandtab
rakudo-2013.12/t/spec/S05-modifier/repetition.t0000664000175000017500000000210012224265625020511 0ustar  moritzmoritzuse v6;
use Test;

plan 12;

#L

#?pugs emit skip_rest("Not yet implemented");

#?rakudo todo ':2x'
ok('abab' ~~ m:2x/ab/,  ':2x (repetition) modifier (+)');
nok('ab'  ~~ m:2x/ab/, ':2x (repetition) modifier (-)');

#?rakudo todo ':x(2)'
ok('abab' ~~ m:x(2)/ab/, ':2x (repetition) modifier (+)');
nok('ab'  ~~ m:x(2)/ab/, ':2x (repetition) modifier (-)');

{
    ok 'ababc'.match(rx/ab/, :x(2)), ':x(2) with .match method (+)';
    nok  'abc'.match(rx/ab/, :x(2)), ':x(2) with .match method (-)';

    ok 'ababc'.match(rx/./, :x(3)), ':x(3) with .match method (bool)';
    is 'ababc'.match(rx/./, :x(3)).join('|'), 'a|b|a', ':x(3) with .match method (result)';
}

{
    ok 'abacad'.match(rx/a./, :x(1..3)), ':x(Range)';
    nok 'abcabc'.match(rx/a./, :x(3..4)), ':x(Range) > number of matches';
    is 'abacadae'.match(rx/a./, :x(1..3)).join('|'), 'ab|ac|ad', ':x(Range) (upper bound)';
    is 'abacad'.match(rx/a./, :x(2..5)).join('|'), 'ab|ac|ad', ':x(Range) (takes as much as it can)';
}

# vim: syn=perl6 sw=4 ts=4 expandtab
rakudo-2013.12/t/spec/S05-modifier/samemark.t0000664000175000017500000000157212224265625020143 0ustar  moritzmoritzuse v6;
use Test;
plan 8;

=begin description

Testing the C<:mm> or C<:samemark> modifier - as always, need more tests

# L

=end description

#?pugs 999 skip feature
{
    my $s = 'äaä';
    ok $s ~~ s:mm/aaa/ooo/, ':mm implies :m';
    is $s, 'öoö', 
       ':mm transported mark information from source to destination';
}

{
    my $s = 'äa';
    ok $s ~~ s:mm/a+/oooo/, ':mm works with quantified atoms';
    is $s, 'öooo', ':mm transported case information to longer substitution string';
}

{
    my $s = 'aä';
    ok $s ~~ s:mm/a+/oooo/, ':mm works with quantified atoms';
    is $s, 'oööö', ':mm transported case information to longer substitution string';
}

{
    my $s = 'aäää oööö';
    ok $s ~~ s:mm:s/a+ o+/OOO UU/, 'combined :mm and :s match';
    is $s, 'OÖÖ UÜ', ':mm :s carry marks on a word-by-word base';
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S05-modifier/sigspace.t0000664000175000017500000000214112237474612020134 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

Parts of this file were originally derived from the perl5 CPAN module
Perl6::Rules, version 0.3 (12 Apr 2004), file t/word.t.

=end pod

plan 12;

ok(!( "abc  def" ~~ m/abc  def/ ), 'Literal space nonmatch' );
#?pugs todo
ok(   "abcdef"   ~~ m/abc  def/, 'Nonspace match' );
#?pugs todo
ok(   "abc  def" ~~ m:s/abc  def/, 'Word space match' );
#?pugs todo
ok(   'abc  def' ~~ ms/abc def/, 'word space match with ms//');
#?pugs todo
ok(   "abc\ndef" ~~ m:sigspace/abc  def/, 'Word newline match' );
ok(!( "abcdef"   ~~ m:sigspace/abc  def/ ), 'Word nonspace nonmatch' );
#?pugs todo
ok(   "abc  def" ~~ m:sigspace/abc <.ws> def/, 'Word explicit space match');

#?pugs todo
ok 'abc def'     ~~ m/:s abc def/,  'inline :s (+)';
#?pugs todo
ok 'zabc def'   ~~  m/:s'abc' def/, "inline :s (+)";
ok 'zabc def'   ~~ m/:s abc def/,   "inline :s doesn't imply <.ws> immediately (-)";


# L

#?pugs todo
ok 'abc def' ~~ ms/c d/, 'ms// works, implies :s (+)';
ok 'abcdef' !~~ ms/c d/, 'ms// works, implies :s (-)';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-nonstrings/basic.t0000664000175000017500000000235712224265625020034 0ustar  moritzmoritzuse v6;

use Test;

plan 5;

# L

# String-like things...

my $fh = open($?FILE);
regex monster { dr\wgon }; # contrived pattern which does not match itself; we're going to look for it in this file
regex cheese { camembert | cheddar  };
my $stream:= cat $fh.lines;

#?pugs todo 'matching against Cat objects'
ok($stream ~~ //, 'rules on streams, positive'); # should match
ok($stream !~~ //, 'rules on streams, negative'); # shouldn't match

# And arrays...

class Dog {...}
class Cat {...}
class Fish {...}

my Dog $a;
my Cat $b;
my Fish $c;

my @array = ($a, $b, $c);
regex canine { <.isa(Dog)> }
regex herbivore { <.isa(::Antelope)> }; 

# does that work? ord does it need a Cat?
ok(@array ~~ //, 'rules on an array - positive');
ok(@array !~~ //, 'rules on an array - negative');
# These seem to be failing for some sort of scoping error rather than a problem with the 
# regex matching itself.

# And matching against each element of an array... a different topic really, but it's still in
# that bit of the synopsis.

my @names = ('zaphod', 'ford', 'arthur', 'slartibartfast');
my $arrr = regex { ar };
is(+(@names>>.match($arrr)), 2, 'matching with hyper-operator');

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-substitution/match.t0000664000175000017500000000160612224265625020413 0ustar  moritzmoritzuse v6;

use Test;

plan 13;

# L

my $str = 'hello';

#?pugs todo
ok $str.match(/h/),         'We can use match';
is $str,  'hello',          '.. it does not do side effect';
ok $str.match(/h/)~~Match,  '.. it returns a Match object';

#?DOES 6
{
    for ('a'..'f') {
        my $r = eval("rx/$_/");
        is $str.match($r), $str~~$r, ".. works as ~~ matching '$str' with /$_/";
    }
}

# it should work for everything that can be tied to a Str, according to S05
# but possibly it should just be defined in object as an exact alias to ~~ ?

$str = 'food';
my $m = $str.match(/$=[f](o+)/);
ok $m ~~ Match,             'is a Match object';
#?pugs todo
is $m,    'foo',            'match object stringifies OK';
#?pugs todo
is $m, 'f',              'match object indexes as a hash';
#?pugs todo
is $m[0], 'oo',             'match object indexes as an array';

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-substitution/subst.t0000664000175000017500000003341512241704255020456 0ustar  moritzmoritzuse v6;

use Test;

plan 141;

# L

my $str = 'hello';

is $str.subst(/h/,'f'),       'fello', 'We can use subst';
is $str,                      'hello', '.. withouth side effect';

is $str.subst('h','f'),       'fello', '.. or using Str as pattern';
is $str.subst('.','f'),       'hello', '.. with literal string matching';

my $i=0;
is $str.subst(/l/,{$i++}),    'he0lo', 'We can have a closure as replacement';
is $str.=subst(/l/,'i'),      'heilo', '.. and with the .= modifier';
is $str,                      'heilo', '.. it changes the receiver';

# not sure about this. Maybe '$1$0' should work.

is 'a'.subst(/(.)/,"$1$0"), '',       '.. and it can not access captures from strings';
is 'a'.subst(/(.)/,{$0~$0}),'aa',     '.. you must wrap it in a closure';
is '12'.subst(/(.)(.)/,{$()*2}),'24', '.. and do nifty things in closures';

# RT #116224
#?niecza skip "Cannot assign to \$/"
{
    $/ = '-';
    is 'a'.subst("a","b"), 'b', '"a".subst("a", "b") is "b"';
    is $/,                 '-', '$/ is left untouched';

    is 'a'.subst(/a/,"b"), 'b', '"a".subst(/a/, "b") is "b"';
    is $/,                 'a', '$/ matched "a"';

    is 'a'.subst(/x/,"y"), 'a', '"a".subst(/x/, "y") is "a"';
    nok $/,                     '$/ is a falsey';

    $_ = 'a';
    is s/a/b/,             'b', '$_ = "a"; s/a/b/ is "b"';
    is $/,                 'a', '$/ matched "a"';

    $_ = 'a';
    is s/x/y/,             'a', '$_ = "a"; s/x/y/ is "a"';
    nok $/,                     '$/ is a falsey';
}

{
    is 'a b c d'.subst(/\w/, 'x', :g),      'x x x x', '.subst and :g';
    is 'a b c d'.subst(/\w/, 'x', :global), 'x x x x', '.subst and :global';
    is 'a b c d'.subst(/\w/, 'x', :x(0)),   'a b c d', '.subst and :x(0)';
    is 'a b c d'.subst(/\w/, 'x', :x(1)),   'x b c d', '.subst and :x(1)';
    is 'a b c d'.subst(/\w/, 'x', :x(2)),   'x x c d', '.subst and :x(2)';
    is 'a b c d'.subst(/\w/, 'x', :x(3)),   'x x x d', '.subst and :x(3)';
    is 'a b c d'.subst(/\w/, 'x', :x(4)),   'x x x x', '.subst and :x(4)';
    is 'a b c d'.subst(/\w/, 'x', :x(5)),   'a b c d', '.subst and :x(5)';
    is 'a b c d'.subst(/\w/, 'x', :x(*)),   'x x x x', '.subst and :x(*)';

    is 'a b c d'.subst(/\w/, 'x', :x(0..1)), 'x b c d', '.subst and :x(0..1)';
    is 'a b c d'.subst(/\w/, 'x', :x(1..3)), 'x x x d', '.subst and :x(0..3)';
    is 'a b c d'.subst(/\w/, 'x', :x(3..5)), 'x x x x', '.subst and :x(3..5)';
    is 'a b c d'.subst(/\w/, 'x', :x(5..6)), 'a b c d', '.subst and :x(5..6)';
    is 'a b c d'.subst(/\w/, 'x', :x(3..2)), 'a b c d', '.subst and :x(3..2)';

    # string pattern versions
    is 'a a a a'.subst('a', 'x', :g),      'x x x x', '.subst (str pattern) and :g';
    is 'a a a a'.subst('a', 'x', :x(0)),   'a a a a', '.subst (str pattern) and :x(0)';
    is 'a a a a'.subst('a', 'x', :x(1)),   'x a a a', '.subst (str pattern) and :x(1)';
    is 'a a a a'.subst('a', 'x', :x(2)),   'x x a a', '.subst (str pattern) and :x(2)';
    is 'a a a a'.subst('a', 'x', :x(3)),   'x x x a', '.subst (str pattern) and :x(3)';
    is 'a a a a'.subst('a', 'x', :x(4)),   'x x x x', '.subst (str pattern) and :x(4)';
    is 'a a a a'.subst('a', 'x', :x(5)),   'a a a a', '.subst (str pattern) and :x(5)';
    is 'a a a a'.subst('a', 'x', :x(*)),   'x x x x', '.subst (str pattern) and :x(*)';

    is 'a a a a'.subst('a', 'x', :x(0..1)), 'x a a a', '.subst (str pattern) and :x(0..1)';
    is 'a a a a'.subst('a', 'x', :x(1..3)), 'x x x a', '.subst (str pattern) and :x(0..3)';
    is 'a a a a'.subst('a', 'x', :x(3..5)), 'x x x x', '.subst (str pattern) and :x(3..5)';
    is 'a a a a'.subst('a', 'x', :x(5..6)), 'a a a a', '.subst (str pattern) and :x(5..6)';
    is 'a a a a'.subst('a', 'x', :x(3..2)), 'a a a a', '.subst (str pattern) and :x(3..2)';
}


# :nth
{
    is 'a b c d'.subst(/\w/, 'x', :nth(0)), 'a b c d', '.subst and :nth(0)';
    is 'a b c d'.subst(/\w/, 'x', :nth(1)), 'x b c d', '.subst and :nth(1)';
    is 'a b c d'.subst(/\w/, 'x', :nth(2)), 'a x c d', '.subst and :nth(2)';
    is 'a b c d'.subst(/\w/, 'x', :nth(3)), 'a b x d', '.subst and :nth(3)';
    is 'a b c d'.subst(/\w/, 'x', :nth(4)), 'a b c x', '.subst and :nth(4)';
    is 'a b c d'.subst(/\w/, 'x', :nth(5)), 'a b c d', '.subst and :nth(5)';

    # string pattern versions
    is 'a a a a'.subst('a', 'x', :nth(0)), 'a a a a', '.subst (str pattern) and :nth(0)';
    is 'a a a a'.subst('a', 'x', :nth(1)), 'x a a a', '.subst (str pattern) and :nth(1)';
    is 'a a a a'.subst('a', 'x', :nth(2)), 'a x a a', '.subst (str pattern) and :nth(2)';
    is 'a a a a'.subst('a', 'x', :nth(3)), 'a a x a', '.subst (str pattern) and :nth(3)';
    is 'a a a a'.subst('a', 'x', :nth(4)), 'a a a x', '.subst (str pattern) and :nth(4)';
    is 'a a a a'.subst('a', 'x', :nth(5)), 'a a a a', '.subst (str pattern) and :nth(5)';
}

# combining :nth with :x
{
    is 'a b c d e f g h'.subst(/\w/, 'x', :nth(1,2,3,4), :x(3)),
       'x x x d e f g h',
       '.subst with :nth(1,2,3,4)) and :x(3)';

    is 'a b c d e f g h'.subst(/\w/, 'x', :nth(2,4,6,8), :x(2)),
       'a x c x e f g h',
       '.subst with :nth(2,4,6,8) and :x(2)';

    is 'a b c d e f g h'.subst(/\w/, 'x', :nth(2, 4, 1, 6), :x(3)),
       'a x c x e x g h',
       '.subst with :nth(2) and :x(3)';
}

{
    # :p
    is 'a b c d e f g h'.subst(/\w/, 'x', :p(0)),
       'x b c d e f g h',
       '.subst with :p(0)';

    is 'a b c d e f g h'.subst(/\w/, 'x', :p(1)),
       'a b c d e f g h',
       '.subst with :p(1)';

    is 'a b c d e f g h'.subst(/\w/, 'x', :p(2)),
       'a x c d e f g h',
       '.subst with :p(2)';
       
    # :p and :g
    #?niecza todo 
    is 'a b c d e f g h'.subst(/\w/, 'x', :p(0), :g),
       'x x x x x x x x',
       '.subst with :p(0) and :g';

    is 'a b c d e f g h'.subst(/\w/, 'x', :p(1), :g),
       'a b c d e f g h',
       '.subst with :p(1) and :g';

    #?niecza todo 
    is 'a b c d e f g h'.subst(/\w/, 'x', :p(2), :g),
       'a x x x x x x x',
       '.subst with :p(2) and :g';
}

{
    # :c
    is 'a b c d e f g h'.subst(/\w/, 'x', :c(0)),
       'x b c d e f g h',
       '.subst with :c(0)';

    is 'a b c d e f g h'.subst(/\w/, 'x', :c(1)),
       'a x c d e f g h',
       '.subst with :c(1)';

    is 'a b c d e f g h'.subst(/\w/, 'x', :c(2)),
       'a x c d e f g h',
       '.subst with :c(2)';
       
    # :c and :g
    is 'a b c d e f g h'.subst(/\w/, 'x', :c(0), :g),
       'x x x x x x x x',
       '.subst with :c(0) and :g';

    is 'a b c d e f g h'.subst(/\w/, 'x', :c(1), :g),
       'a x x x x x x x',
       '.subst with :c(1) and :g';

    is 'a b c d e f g h'.subst(/\w/, 'x', :c(2), :g),
       'a x x x x x x x',
       '.subst with :c(2) and :g';

    # :c and :nth(3, 4)
    #?niecza 3 todo ":nth(3, 4) NYI"
    is 'a b c d e f g h'.subst(/\w/, 'x', :c(0), :nth(3, 4)),
       'a b x x e f g h',
       '.subst with :c(0) and :nth(3, 4)';
    
    is 'a b c d e f g h'.subst(/\w/, 'x', :c(1), :nth(3, 4)),
       'a b c x x f g h',
       '.subst with :c(1) and :nth(3, 4)';
    
    is 'a b c d e f g h'.subst(/\w/, 'x', :c(2), :nth(3, 4)),
       'a b c x x f g h',
       '.subst with :c(2) and :nth(3, 4)';
}

{
    my $s = "ZBC";
    my @a = ("A", 'ZBC');

    $_ = q{Now I know my abc's};

    s:global/Now/Wow/;
    is($_, q{Wow I know my abc's}, 'Constant substitution');

    s:global/abc/$s/;
    is($_, q{Wow I know my ZBC's}, 'Scalar substitution');

{
    s:g/BC/@a[]/;
    is($_, q{Wow I know my ZA ZBC's}, 'List substitution');
}

    dies_ok { 'abc' ~~ s/b/g/ },
            "can't modify string literal (only variables)";
}

# L
#?niecza skip "Action method quote:ss not yet implemented"
{
    $_ = "a\nb\tc d";
    ok ss/a b c d/w x y z/, 'successful substitution returns True';
    #?rakudo todo "RT #120526"
    is $_, "w\nx\ty z", 'ss/.../.../ preserves whitespace';

    dies_ok {"abc" ~~ ss/a b c/ x y z/}, 'Cannot ss/// string literal';
}

#L
{
    my $a = 'abc';
    ok $a ~~ s[b] = 'de', 's[...] = ... returns true on success';
    is $a, 'adec', 'substitution worked';

    $a = 'abc';
    nok $a ~~ s[d] = 'de', 's[...] = ... returns false on failure';
    is $a, 'abc', 'failed substitutions leaves string unchanged';
}

{
    eval_dies_ok '$_ = "a"; s:unkonwn/a/b/', 's/// dies on unknown adverb';
    eval_dies_ok '$_ = "a"; s:overlap/a/b/', ':overlap does not make sense on s///';
}

# note that when a literal is passed to 'given', $_ is bound read-only
{
    given my $x = 'abc' {
        ok (s[b] = 'de'), 's[...] = ... returns true on success';
        is $_, 'adec', 'substitution worked';
    }

    given my $y = 'abc' {
        s[d] = 'foo';
        is $_, 'abc', 'failed substitutions leaves string unchanged';
    }
}

{
    my $x = 'foobar';
    ok ($x ~~ s:g[o] = 'u'), 's:g[..] = returns True';
    is $x, 'fuubar', 'and the substition worked';
}

{
    $_ = 'a b c';
    s[\w] = uc($/);
    is $_, 'A b c', 'can use $/ on the RHS';

    $_ = 'a b c';
    s[(\w)] = uc($0);
    is $_, 'A b c', 'can use $0 on the RHS';

    $_ = 'a b c';
    s:g[ (\w) ] = $0 x 2;
    is $_, 'aa bb cc', 's:g[...] and captures work together well';
}

{
    my $x = 'ABCD';
    $x ~~ s:x(2)/<.alpha>/x/;
    is $x, 'xxCD', 's:x(2)';
}

# s///
{
    my $x = 'ooooo';
    ok $x ~~ s:1st/./X/,    's:1st return value';
    is $x,  'Xoooo',        's:1st side effect';

    $x    = 'ooooo';
    ok $x ~~ s:2nd/./X/,    's:2nd return value';
    is $x,  'oXooo',        's:2nd side effect';

    $x    = 'ooooo';
    ok $x ~~ s:3rd/./X/,    's:3rd return value';
    is $x,  'ooXoo',        's:3rd side effect';

    $x    = 'ooooo';
    ok $x ~~ s:4th/./X/,    's:4th return value';
    is $x,  'oooXo',        's:4th side effect';

    $x    = 'ooooo';
    ok $x ~~ s:nth(5)/./X/, 's:nth(5) return value';
    is $x,  'ooooX',        's:nth(5) side effect';

    $x    = 'ooooo';
    nok $x ~~ s:nth(6)/./X/, 's:nth(6) return value';
    is $x,  'ooooo',        's:nth(6) no side effect';
}

# s///
{
    my $x = 'ooooo';
    $x ~~ s:x(2):nth(1,3)/o/A/;
    is $x,  'AoAoo', 's:x(2):nth(1,3) works in combination';

    $x = 'ooooo';
    $x ~~ s:2x:nth(1,3)/o/A/;
    is $x,  'AoAoo', 's:2x:nth(1,3) works in combination';
}

# RT #83484
# s// with other separators 
{
    my $x = 'abcde';
    $x ~~ s!bc!zz!;
    is $x, 'azzde', '! separator';
}

#L
#?rakudo skip 's[...] op= RHS'
#?niecza skip 's[...] op= RHS'
{
    given 'a 2 3' {
        ok (s[\d] += 5), 's[...] += 5 returns True';
        is $_, 'a 7 3', 's[...] += 5 gave right result';
    }
    given 'a b c' {
        s:g[\w] x= 2;
        is $_, 'aa bb cc', 's:g[..] x= 2 worked';
    }
}

#?rakudo skip 's:g[...] ='
#?niecza skip 's:g[...] ='
{
    multi sub infix:(Match $a, Int $b) {
        $a.from + $b
    }

    given 'a b c' {
        ok (s:g[\w] fromplus= 3), 's:g[...] customop= returned True';
        is $_, '3 5 7', '... and got right result';
    }
}

# RT #69044
{
    sub s { 'sub s' }
    $_ = "foo";
    ok s,foo,bar, , 'bare s is always substititution';
    is s(), 'sub s', 'can call sub s as "s()"';
    $_ = "foo";
    ok s (foo) = 'bar', 'bare s is substitution before whitespace then parens';
}

# Test for :samecase
#?niecza skip ":samecase NYI"
{
    is 'The foo and the bar'.subst('the', 'that', :samecase), 'The foo and that bar', '.substr and :samecase (1)';
    is 'The foo and the bar'.subst('the', 'That', :samecase), 'The foo and that bar', '.substr and :samecase (2)';
    is 'The foo and the bar'.subst(/:i the/, 'that', :samecase), 'That foo and the bar', '.substr (string pattern) and :    samecase (1)';
    is 'The foo and the bar'.subst(/:i The/, 'That', :samecase), 'That foo and the bar', '.substr (string pattern) and :    samecase (2)';
    is 'The foo and the bar'.subst(/:i the/, 'that', :g, :samecase), 'That foo and that bar', '.substr (string pattern)     and :g and :samecase (1)';
    is 'The foo and the bar'.subst(/:i The/, 'That', :g, :samecase), 'That foo and that bar', '.substr (string pattern)     and :g and :samecase (2)';

    my $str = "that";
    is 'The foo and the bar'.subst(/:i the/, {++$str}, :samecase), 'Thau foo and the bar', '.substr and samecase, worked with block replacement';
    is 'The foo and the bar'.subst(/:i the/, {$str++}, :g, :samecase), 'Thau foo and thav bar', '.substr and :g and :samecase, worked with block replacement';
}

#?niecza skip "Regex modifiers ii and samecase NYI"
{
    $_ = 'foObar';
    s:ii/oo/au/;
    is $_, 'faUbar', ':ii implies :i';

    $_ = 'foObar';
    s:samecase/oo/au/;
    is $_, 'faUbar', ':samecase implies :i';

}

# RT #66816
#?niecza todo
{
    my $str = "a\nbc\nd";
    is $str.subst(/^^/, '# ', :g), "# a\n# bc\n# d",
        'Zero-width substitution does not make the GC recurse';
}

{
    #?niecza todo "Niecza works when it shouldn't?"
    eval_dies_ok q[ $_ = "abc"; my $i = 1; s:i($i)/a/b/ ],
        'Value of :i must be known at compile time';
    #?rakudo todo 'be smarter about constant detection'
    eval_lives_ok q[ $_ = "abc";s:i(1)/a/b/ ],
        ':i(1) is OK';
}

{
    $_ = 'foo';
    s/f(.)/b$0/;
    is $_, 'boo', 'can use $0 in RHS of s///';
}

# RT #76664
{
    class SubstInsideMethod {
        method ro($_ ) { s/c// }
    }
    
    dies_ok { SubstInsideMethod.new.ro('ccc') }, '(sanely) dies when trying to s/// a read-only variable';
}

# RT #83552
#?niecza skip 'Unable to resolve method postcircumfix:<( )> in type Any'
#?DOES 3
{
    use lib "t/spec/packages";
    use Test::Util;

    $_ = "foo"; s[f] = 'bar';
    is $_, "baroo", 's[f] is parsed as a substitution op';
    throws_like q{$_ = "foo"; s[] = "bar";}, X::Syntax::Regex::NullRegex;
}

# RT #119201
{
    my $RT119201_s = 'abcdef';
    my $RT119201_m = '';
    $RT119201_s   .= subst(/(\w)/, { $RT119201_m = $/[0] });
    is($RT119201_m, 'a', 'get match variable in replacement of subst-mutator');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-syntactic-categories/new-symbols.t0000664000175000017500000000165012224265625023145 0ustar  moritzmoritzuse v6;
use MONKEY_TYPING;

use Test;
plan 8;

# L

{
    augment slang Regex {
        token backslash:sym { YY };
    }
    eval_dies_ok  '/foo \y/', 
        'can not compile regex with unknown backslash rule';
    eval_lives_ok '/fuu \Y/', 'can compile a regex with new backslash rule';
    ok 'YY'  ~~ /^\Y$/, 'can use that rule (positive)';
    ok 'yX' !~~ /^\Y$/, 'can use that rule (negative)';
}
eval_dies_ok '/\Y/', 'backslash rules are lexically scoped';

{
    # nothing in the spec says that backslash rules need to be one char
    # only, and we have LTM after all
    # I feel so evil today... ;-)
    augment slang Regex {
        token backslash: { 'Hax' };
    }
    eval_lives_ok '/\moep/', 'can compile regex with multi char backslash rule';
    ok 'Haxe' ~~ m/^\moep/, '... it matches';
    ok 'Haxe' ~~ m/^\moepe$/, '... with correct end of escape sequence';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-transliteration/79778.t0000664000175000017500000000021212224265625020462 0ustar  moritzmoritzuse v6;

use Test;

is "this sentence no verb".trans( / \s+ / => " " ), 'this sentence no verb',"RT #79778 got expected string"  ;

done;
rakudo-2013.12/t/spec/S05-transliteration/trans.t0000664000175000017500000002201712224265625021113 0ustar  moritzmoritzuse v6;

use Test;

=begin pod

String transliteration

=end pod

# L

plan 60;

is("ABC".trans( ('A'=>'a'), ('B'=>'b'), ('C'=>'c') ),
    "abc",
    "Each side can be individual characters");

is("XYZ".trans( ('XYZ' => 'xyz') ),
    "xyz",
    "The two sides of the any pair can be strings interpreted as tr/// would multichar");

is("ABC".trans( ('A..C' => 'a..c') ),
    "abc",
    "The two sides of the any pair can be strings interpreted as tr/// would range");

is("ABC-DEF".trans(("- AB..Z" => "_ a..z")),
    "abc_def",
    "If the first character is a dash it isn't part of a range");

is("ABC-DEF".trans(("A..YZ-" => "a..z_")),
    "abc_def",
    "If the last character is a dash it isn't part of a range");

is("ABCDEF".trans( ('AB..E' => 'ab..e') ),
    "abcdeF",
    "The two sides can consists of both chars and ranges");

is("ABCDEFGH".trans( ('A..CE..G' => 'a..ce..g') ),
    "abcDefgH",
    "The two sides can consist of multiple ranges");

is("ABCXYZ".trans( (['A'..'C'] => ['a'..'c']), ( => ) ),
    "abcxyz",
    "The two sides of each pair may also be array references" );

is("abcde".trans( ('a..e' => 'A'..'E') ), "ABCDE",
	   "Using string range on one side and array reference on the other");

is("ABCDE".trans( (['A' .. 'E'] => "a..e") ), "abcde",
	   "Using array reference on one side and string range on the other");

#?pugs todo
is(" <>&".trans( ([' ', '<', '>', '&'] =>
    [' ',      '<',    '>',    '&'     ])),
    " <>&","The array version can map one characters to one-or-more characters");

is(" <>&".trans( ([' ',      '<',    '>',    '&'    ] => 
                  [' ', '<', '>', '&' ])),
                  " <>&",
    "The array version can map one-or-more characters to one-or-more characters");
    
#?pugs todo
is(" <>&".trans( ([' ', ' <', '<', '>', '&'] =>
                                 [' ',      'AB',         '<',    '>',    '&'    ])),
                                "AB>&",
    "The array version can map one characters to one-or-more characters, using leftmost longest match");
    
is("Whfg nabgure Crey unpxre".trans('a'..'z' => ['n'..'z','a'..'m'], 'A'..'Z' => ['N'..'Z','A'..'M']),
    "Just another Perl hacker",
    "Ranges can be grouped");

is("Whfg nabgure Crey unpxre".trans('a..z' => 'n..za..m', 'A..Z' => 'N..ZA..M'),
    "Just another Perl hacker",
    "Multiple ranges interpreted in string");

# Per S05 changes
#?pugs todo
{
is("Whfg nabgure Crey unpxre".trans(' a..z' => '_n..za..m', 'A..Z' => 'N..ZA..M'),
    "Just_another_Perl_hacker",
    "Spaces in interpreted ranges are not skipped (all spaces are important)");
is("Whfg nabgure Crey unpxre".trans('a .. z' => 'n .. za .. m', 'A .. Z' => 'N .. ZA .. M'),
    "Whfg nnbgure Crey unpxre",
    "Spaces in interpreted ranges are not skipped (all spaces are important)");
};

my $a = "abcdefghijklmnopqrstuvwxyz";

my $b = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";

is($a.trans('a..z' => 'A..Z'), $b);

is($b.trans('A..Z' => 'a..z'), $a);

is($a.trans('b..y' => 'B..Y'), 'aBCDEFGHIJKLMNOPQRSTUVWXYz');

is("I\xcaJ".trans('I..J' => 'i..j'), "i\xcaj");

is("\x12c\x190".trans("\x12c" => "\x190"), "\x190\x190");

# should these be combined?
#?rakudo todo 'disambiguate ranges'
#?niecza todo
#?pugs todo
is($b.trans('A..H..Z' => 'a..h..z'), $a,
    'ambiguous ranges combined');

#?pugs todo
is($b.trans('..H..Z' => '__h..z'),
    'ABCDEFGhijklmnopqrstuvwxyz',
    'leading ranges interpreted as string');

is($b.trans('A..H..' => 'a..h__'), 'abcdefghIJKLMNOPQRSTUVWXYZ',
    'trailing ranges interpreted as string');

#?pugs todo
is($b.trans('..A..H..' => '__a..h__'), 'abcdefghIJKLMNOPQRSTUVWXYZ',
    'leading, trailing ranges interpreted as string');

# added as a consequence of RT #76720
#?pugs todo
is("hello".trans("l" => ""), "heo", "can replace with empty string");

# complement, squeeze/squash, delete

#?niecza 2 skip 'trans flags NYI'
#?pugs todo
#?rakudo todo 'flags'
is('bookkeeper'.trans(:s, 'a..z' => 'a..z'), 'bokeper',
    ':s flag (squash)');

#?pugs todo
is('bookkeeper'.trans(:d, 'ok' => ''), 'beeper',
    ':d flag (delete)');
    
#?pugs todo
is('ABC123DEF456GHI'.trans('A..Z' => 'x'), 'xxx123xxx456xxx',
    'no flags');

#?rakudo 4 todo 'flags'
#?niecza 4 skip 'trans flags NYI'
#?pugs todo
is('ABC123DEF456GHI'.trans(:c, 'A..Z' => 'x'),'ABCxxxDEFxxxGHI',
    '... with :c');

#?pugs todo
is('ABC111DEF222GHI'.trans(:s, '0..9' => 'x'),'ABCxDEFxGHI',
    '... with :s');

#?pugs todo
is('ABC111DEF222GHI'.trans(:c, :s, 'A..Z' => 'x'),'ABCxDEFxGHI',
    '... with :s and :c');

#?pugs todo
is('ABC111DEF222GHI'.trans(:c, :d, 'A..Z' => ''),'ABCDEFGHI',
    '... with :d and :c');

#?pugs todo
is('Good&Plenty'.trans('len' => 'x'), 'Good&Pxxxty',
    'no flags');

#?rakudo 5 todo 'flags'
#?niecza 5 skip 'trans flags NYI'
#?pugs todo
is('Good&Plenty'.trans(:s, 'len' => 'x',), 'Good&Pxty',
    'squashing depends on replacement repeat, not searchlist repeat');

#?pugs todo
is('Good&Plenty'.trans(:s, 'len' => 't'), 'Good&Ptty',
    'squashing depends on replacement repeat, not searchlist repeat');

# also checks that :c uses the first element in array (or first char in string)
#?pugs todo
is(" <>&".trans(:c, ([' ', '>', '&'] =>
    ['???',      'AB',     '>',    '&'    ])),
    ' ????????????>&',
    'array, many-to-many transliteration, complement');

# fence-post issue with complement
#?pugs todo
is(" <>&".trans(:c, ([' ', '>'] =>
    ['???',      'AB'])),
    ' ????????????>???????????????',
    'fence-post issue (make sure to replace end bits as well)');
   
#?pugs todo 
is(" <>&".trans(:c, :s, ([' ', '>', '&'] =>
    ['???'])),
    ' ???>&',
    '... and now complement and squash');

#?pugs skip 'Not a keyed value: VRule'
{
# remove vowel and character after
    is('abcdefghij'.trans(/<[aeiou]> \w/ => ''), 'cdgh', 'basic regex works');
    is( # vowels become 'y' and whitespace becomes '_'
        "ab\ncd\tef gh".trans(/<[aeiou]>/ => 'y', /\s/ => '_'),
        'yb_cd_yf_gh',
        'regexes pairs work',
    );

    my $i = 0;
    is('ab_cd_ef_gh'.trans('_' => {$i++}), 'ab0cd1ef2gh', 'basic closure');

    $i = 0;
    my $j = 0;
    is(
        'a_b/c_d/e_f'.trans('_' => {$i++}, '/' => {$j++}),
        'a0b0c1d1e2f',
        'closure pairs work',
    );
};

#?rakudo skip 'closures and regexes'
#?niecza skip 'closures and regexes'
#?pugs skip 'Not a keyed value: VRule'
{
    # closures and regexes!
    is(
        '[36][38][43]'.trans(/\[(\d+)\]/ => {chr($0)}),
        '$&+',
        'closure and regex'
    );

    is(
        '"foo  &   bar"'.trans(
            /(' '+)/ => {' ' ~ (' ' x ($0.chars - 1))},
            /\W/ => sub {"&#{ord($0)};"}
        ),
        '"foo  &   bar"',
        'pairs of regexes and closures',
    );
}

#?rakudo skip 'tr///, feed operator not implemented'
#?niecza skip 'Action method quote:tr not yet implemented'
{
    #?pugs todo
    is(eval('"abc".trans(<== "a" => "A")'), "Abc",
        "you're allowed to leave off the (...) named arg parens when you use <==");

    # Make sure the tr/// version works, too.  

    $_ = "ABC";
    tr/ABC/abc/;
    is($_, 'abc', 'tr/// on $_ with explicit character lists');

    $_ = "abc";
    tr|a..c|A..C|;
    is($_, 'ABC', 'tr||| on $_ with character range');

    my $japh = "Whfg nabgure Crey unpxre";
    $japh ~~ tr[a..z A..Z][n..z a..m  N..Z A..M];
    is($japh, "Just another Perl hacker", 'tr[][] on lexical var via ~~');

    $_ = '$123';
    tr/$123/X\x20\o40\t/;
    is($_, "X  \t", 'tr/// on $_ with explicit character lists');
}

# y/// is dead
eval_dies_ok('$_ = "axbycz"; y/abc/def/', 'y/// does not exist any longer');

# RT #71088
{
    lives_ok { "".subst(/x/, "").trans() },
        'trans on subst output lives';
}

#?pugs todo
is('aaaaabbbbb'.trans(['aaa', 'aa', 'bb', 'bbb'] => ['1', '2', '3', '4']),
   '1243',
   'longest constant token preferred, regardless of declaration order');
  
#?pugs skip 'Not a keyed value: VRule'
is('foobar'.trans(/\w+/ => 'correct', /foo/ => 'RONG'), 'correct',
   'longest regex token preferred, regardless of declaration order');

#?pugs skip 'Not a keyed value: VRule'
is('aaaa'.trans(/a/ => '1', /\w/ => '2', /./ => '3'), '1111',
   'in case of a tie between regex lengths, prefer the first one');

#?pugs todo
is('ababab'.trans([/ab/, 'aba', 'bab', /baba/] =>
                   ['1',  '2',   '3',   '4'   ]),
   '23',
   'longest token still holds, even between constant strings and regexes');

# RT #83674
#?niecza todo 'Not sure what is supposed to be going on here'
#?pugs todo
lives_ok { my @a = 1..2; @a>>.trans((1..2) => (14..15,1..2)); }, 'trans works with Cool signature';

# RT #83766
#?niecza 2 skip "Nominal type check failed for scalar store; got Int, needed Str or subtype"
#?pugs 2 skip 'trans'
is((1, 2)>>.trans((1..26) => (14..26,1..13)), <14 15>, '.trans with a pair of parcels using postfix hypermetaoperator works');
is ("!$_!" for (1, 2)>>.trans((1..26) => (14..26,1..13))), , "same with explicit for";

# vim: ft=perl6
rakudo-2013.12/t/spec/S05-transliteration/with-closure.t0000664000175000017500000000426512224265625022416 0ustar  moritzmoritzuse v6;
use Test;
plan 16;

# L

my $x = 0;

is 'aXbXcXd'.trans('X' => { ++$x }), 'a1b2c3d', 'Can use a closure on the RHS';
#?rakudo todo 'nom regression'
#?niecza todo 'Closure executed three times'
is $x, 3,                                       'Closure executed three times';

$x = 0;
my $y = 0;
my $s = 'aXbYcYdX';
my %matcher = (
    X   => { ++$x },
    Y   => { ++$y },
);

is $s.trans(%matcher.pairs),        'a1b1c2d2', 'Can use two closures in trans';
is $s,                              'aXbYcYdX', 'Source string unchanged';

#?rakudo todo 'nom regression'
#?niecza todo 'can use closures in pairs'
is $s.trans([] => [{++$x},{++$y}]), 'a3b3c4d4', 'can use closures in pairs of arrays';
is $s,                              'aXbYcYdX', 'Source string unchanged';

$x = 0;
$y = 0;

my $s2 = 'ABC111DEF111GHI';

is $s2.trans([<1 111>] => [{++$x},{++$y}]), 'ABC1DEF2GHI', 'can use closures in pairs of arrays';
is $s2,                              'ABC111DEF111GHI', 'Source string unchanged';
is $x, 0,                            'Closure not invoked (only longest match used)';
#?rakudo todo 'nom regression'
#?niecza todo 'Closure invoked twice'
is $y, 2,                            'Closure invoked twice (once per replacement)';

{
    # combined regex / closure
    my $count = 0;
    is 'hello'.trans(/l/ => { ++$count }), 'he12o', 'regex and closure mix';
    #?rakudo todo 'nom regression'
    #?niecza todo 'regex and closure mix (with $/ as topic)'
    is 'hello'.trans(/l/ => { $_ x 2 }), 'hellllo', 'regex and closure mix (with $/ as topic)';
    my $x = 'hello';
    #?rakudo todo 'nom regression'
    #?niecza todo 'regex and closure mix (with $/ as topic and capture)'
    is $x.trans(/(l)/ => { $_[0] x 2 }), 'hellllo', 'regex and closure mix (with $/ as topic and capture)';
    is $x, 'hello', 'Original string not modified';
}

my $orig = 'hello'; 
#?rakudo skip 'Unable to resolve method ord in class Any'
#?niecza skip 'Unable to resolve method ord in class Any'
is $orig.trans(/(l)/ => { $_[0].ord }), 'he108108o', 'capturing regex + closure with .ord on $_';
is $orig, 'hello', 'original string unchanged';

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/caller.t0000664000175000017500000000513112224265625017550 0ustar  moritzmoritzuse v6;

use Test;



# L and C functions>

# caller.subname
sub a_sub { b_sub() }
sub b_sub { try { caller.subname } }
#?pugs todo "feature"
#?niecza todo "try interferes with caller counting"
is ~a_sub(), "a_sub", "caller.sub works";

# caller.file
#?pugs todo "feature"
ok index(~(try { caller.file }), "caller") >= 0, "caller.file works";

# caller.line (XXX: make sure to edit the expected line number!)
#?pugs 2 todo "feature"
sub call_line { caller.line };
is call_line(), 23, "caller.line works";

# pugs: caller exposes a bug in the MMD mechanism where directly using autogenerated
# accessors on an object returned by a factory, rather than storing the object
# in an intermediate variable, works only when you chain methods with an
# explicit () between them: caller().subname - ok; caller.subname - error.

sub try_it {
    my ($code, $expected, $desc) = @_;
    is($code(), $expected, $desc);
}
sub try_it_caller { try_it(@_) }                                # (line 33.)
class A { method try_it_caller_A { &Main::try_it_caller(@_) } }
sub try_it_caller_caller { A.try_it_caller_A(@_) }
class B { method try_it_caller_B { &Main::try_it_caller_caller(@_) } }

#?DOES 1
sub chain { B.try_it_caller_B(@_) }

# pugs: must use parentheses after caller

# basic tests of caller object
#?niecza skip "NYI"
{
    chain({ WHAT(caller()).gist }, "Control::Caller()", "caller object type");
    chain({ caller().package }, "Main", "caller package");
    chain({ caller().file },    $?FILE, "caller filename");
    chain({ caller().line },    "32", "caller line");
    chain({ caller().subname }, "&Main::try_it_caller", "caller subname");
    chain({ caller().subtype }, "SubRoutine", "caller subtype"); # specme
    chain({ caller().sub },     &try_it_caller, "caller sub (code)");
}

# select by code type
#?niecza skip "NYI"
{
    chain({ caller(Any).subname },    "&Main::try_it_caller", "code type - Any");
    chain({ caller("Any").subname },  "&Main::try_it_caller", "code type - Any (string)");
    chain({ caller(Method).subname }, "&A::try_it_caller_A", "code type - Method");
    chain({ caller("Moose") },         Mu, "code type - not found");
    chain({ caller(:skip<1>).subname }, "&A::try_it_caller_A", ":skip<1>");
    chain({ caller(:skip<128>) },       Mu, ":skip<128> - not found");
    chain({ caller(Sub, :skip<1>).subname }, "&Main::try_it_caller_caller", "Sub, :skip<1>");
    chain({ caller(Sub, :skip<2>).subname }, "&Main::chain", "Sub, :skip<2>");
    chain({ caller(Method, :skip<1>).subname }, "&B::try_it_caller_B", "Method, :skip<1>");
}

# WRITEME: label tests

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/callframe.t0000664000175000017500000000262212224265625020236 0ustar  moritzmoritzuse v6;
use Test;

#?niecza emit plan 8; #
plan 9;

# this test file contains tests for line numbers, among other things
# so it's extremely important not to randomly insert or delete lines.

my $baseline = 10;

isa_ok callframe(), CallFrame, 'callframe() returns a CallFrame';

sub f() {
    #?rakudo.jvm todo "nigh"
    is callframe().line, $baseline + 5, 'callframe().line';
    ok callframe().file ~~ /« callframe »/, '.file';

    #?rakudo skip 'Unable to resolve method inline in type CallFrame'
    #?niecza skip 'Unable to resolve method inline in type CallFrame'
    nok callframe().inline, 'explicitly entered block (.inline)';

    # Note:  According to S02, these should probably fail unless
    # $x is marked 'is dynamic'.  We allow it for now since there's
    # still some uncertainty in the spec in S06, though.
    #?niecza skip 'Unable to resolve method my in type CallFrame'
    is callframe(1).my.<$x>, 42, 'can access outer lexicals via .my';
    #?niecza emit #
    callframe(1).my.<$x> = 23;

    #?niecza skip 'Unable to resolve method my in type CallFrame'
    is callframe(1).my.<$y>, 353, 'can access outer lexicals via .my';
    #?niecza emit #
    dies_ok { callframe(1).my.<$y> = 768 }, 'cannot mutate without is dynamic';;
}

my $x is dynamic = 42;
my $y = 353;

f();

#?niecza todo 'needs .my'
is $x,  23, '$x successfully modified';
is $y, 353, '$y not modified';

done();

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/callsame.t0000664000175000017500000000111412224265625020064 0ustar  moritzmoritzuse v6;
use Test;

# RT 71754
{
    my @called;
    multi rt71754( Numeric $x ) {    #OK not used
        push @called, 'Numeric';
    }
    multi rt71754( Int $x ) {    #OK not used
        push @called, 'Int';
        callsame;
    }
    lives_ok { rt71754( 71754 ) }, 'Can call multi that uses "callsame"';
    is @called, , 'multi with "callsame" worked';
}

# RT 69314
#?niecza todo
{
    sub rt69314($n) { 
        if $n { 
            callsame;
        }
    }; 
    
    lives_ok {rt69314(1)}, 'Calling callsame directly from a sub works';

}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/lexical-subs.t0000664000175000017500000000256012224265625020704 0ustar  moritzmoritzuse v6;

use Test;

plan 11;

{
    sub f() {
        my sub g(){"g"}; my sub h(){g()}; h();
    };
    is(f(), 'g', 'can indirectly call lexical sub');
    eval_dies_ok('g', 'lexical sub not visible outside current scope');
}

{
    sub foo($x) { $x + 1 }

    sub callit(&foo) {
        foo(1);
    }

    is(foo(1), 2, 'calls subs passed as &foo parameter');
    is(callit({ $^x + 2 }), 3, "lexical subs get precedence over package subs");
}

#?rakudo skip 'cannot parse operator names yet'
{
    sub infix:<@@> ($x, $y) { $x + $y }

    sub foo2(&infix:<@@>) {
        2 @@ 3;
    }

    is(2 @@ 3, 5);
    is(foo2({ $^a * $^b }), 6);
}

{
    my sub test_this {     #OK not used
        ok 1, "Could call ok from within a lexical sub";
        return 1;
    }
    eval 'test_this()';
    if ($!) {
        ok 0, "Could call ok from within a lexical sub";
    }
}

# used to be http://rt.perl.org/rt3/Ticket/Display.html?id=65498
{
    sub a { 'outer' };
    {
        my sub a { 'inner' };
        is a(), 'inner', 'inner lexical hides outer sub of same name';
    }
    is a(), 'outer', '... but only where it is visisble';
}

{
    package TestScope {
        sub f { };
    }
    #?pugs todo
    dies_ok { TestScope::f }, 'subs without scoping modifiers are not entered in the namespace';
}

# RT #57788
{
    #?pugs todo
    eval_dies_ok 'sub a { }; sub a { }';
}

# vim: ft=perl6 :
rakudo-2013.12/t/spec/S06-advanced/recurse.t0000664000175000017500000000705512224265625017765 0ustar  moritzmoritzuse v6;

use Test;

plan 13;

# Mostly copied from Perl 5.8.4 s t/op/recurse.t

sub gcd {
    return gcd(@_[0] - @_[1], @_[1]) if (@_[0] > @_[1]);
    return gcd(@_[0], @_[1] - @_[0]) if (@_[0] < @_[1]);
    @_[0];
}

sub factorial {
    @_[0] < 2 ?? 1 !! @_[0] * factorial(@_[0] - 1);
}

sub fibonacci {
    @_[0] < 2 ?? 1 !! &?ROUTINE(@_[0] - 2) + &?ROUTINE(@_[0] - 1);
}

# Highly recursive, highly aggressive.
# Kids, do not try this at home.
#
# For example ackermann(4,1) will take quite a long time.
# It will simply eat away your memory. Trust me.

sub ackermann {
    return @_[1] + 1               if (@_[0] == 0);
    return ackermann(@_[0] - 1, 1) if (@_[1] == 0);
    ackermann(@_[0] - 1, ackermann(@_[0], @_[1] - 1));
}

# Highly recursive, highly boring.

sub takeuchi {
    # for the script failure here, see Parser.hs:589
    @_[1] < @_[0] ??
        takeuchi(takeuchi(@_[0] - 1, @_[1], @_[2]),
                 takeuchi(@_[1] - 1, @_[2], @_[0]),
                 takeuchi(@_[2] - 1, @_[0], @_[1]))
            !! @_[2];
}

is(gcd(1147, 1271), 31, 'gcd 1');
is(gcd(1908, 2016),  36, 'gcd 2');
ok(factorial(10) == 3628800, 'simple factorial');
is(factorial(factorial(3)), 720, 'nested factorial');
is(fibonacci(10), 89, 'recursion via &?ROUTINE');

# ok(fibonacci(fibonacci(7)) == 17711);
# takes too long
# skip("Takes too long to wait for");

# dunno if these could use some shorter/simpler sub names, but I'm not
# thinking of anything offhand.

# what the silly sub names mean:
#  - 'mod' means it makes a local copy of the variable, modified as
#    necessary
#  - 'nomod' means it passes the modified value directly to the next call
#  - 'named' means it uses named parameters
#  - 'unnamed' means it uses @_ for parameters

sub countup_nomod_unnamed {
    my $num = @_.shift;
    return $num if $num <= 0;
    return countup_nomod_unnamed($num-1), $num;
}

sub countdown_nomod_unnamed {
    my $num = @_.shift;
    return $num if $num <= 0;
    return $num, countdown_nomod_unnamed($num-1);
}

sub countup_nomod_named ($num) {
    return $num if $num <= 0;
    return countup_nomod_named($num-1), $num;
}

sub countdown_nomod_named ($num) {
    return $num if $num <= 0;
    return $num, countdown_nomod_named($num-1);
}

sub countup_mod_unnamed {
    my $num = @_.shift;
    my $n = $num - 1;
    return $num if $num <= 0;
    return countup_mod_unnamed($n), $num;
}

sub countdown_mod_unnamed {
    my $num = @_.shift;
    my $n = $num - 1;
    return $num if $num <= 0;
    return $num, countdown_mod_unnamed($n);
}

sub countup_mod_named ($num) {
    my $n = $num - 1;
    return $num if $num <= 0;
    return countup_mod_named($n), $num;
}

sub countdown_mod_named ($num) {
    my $n = $num - 1;
    return $num if $num <= 0;
    return $num, countdown_mod_named($n);
}


is(  countup_nomod_named(5).join,   "012345", "recursive count up: named param, no modified value");
is(countdown_nomod_named(5).join,   "543210", "recursive count down: named param, no modified value");
is(  countup_nomod_unnamed(5).join, "012345", "recursive count up: unnamed param, no modified value");
is(countdown_nomod_unnamed(5).join, "543210", "recursive count down: unnamed param, no modified value");
is(  countup_mod_named(5).join,     "012345", "recursive count up: named param, modified value");
is(countdown_mod_named(5).join,     "543210", "recursive count down: named param, modified value");
is(  countup_mod_unnamed(5).join,   "012345", "recursive count up: unnamed param, modified value");
is(countdown_mod_unnamed(5).join,   "543210", "recursive count down: unnamed param, modified value");

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/return_function.t0000664000175000017500000000111712224265625021532 0ustar  moritzmoritzuse Test; plan 4;

# L function/prints 1 via named argument>

{
    sub f () { return :x<1> }
    sub g ($x) { $x }

    my $x := |(f);  # binds 1 to $x, via a named argument
    #?pugs todo 'bug'
    is $x, 1, 'binds 1 to $x, via a named argument';
    is( g(|(f)), 1, "prints 1, via a named argument");
}

{
  # return two positional Pair objects
  sub t2 () { return( (:x<1>), (:y<2>) ) }
  my ($rv1, $rv2);
  try { ($rv1, $rv2) := |(t2) };
  #?pugs 2 todo 'bug'
  is($rv1, Pair, "returned Pair object 1");
  is($rv2, Pair, "returned Pair object 2");
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/return.t0000664000175000017500000002360712224265625017635 0ustar  moritzmoritzuse v6;
use Test;

=begin desc

This tests proper return of values from subroutines.

# L function">

See also t/blocks/return.t, which overlaps in scope.

=end desc

# NOTE: the smart link above actually doesn't go to a good
# reference for the spec for 'return', but I couldn't find
# one either. 

plan 79;

# These test the returning of values from a subroutine.
# We test each data-type with 4 different styles of return.
#
# The datatypes are:
#     Scalar
#     Array
#     Array-ref (aka List)
#     Hash
#     Hash-ref
#
# The 4 return styles are:
#     create a variable, and return it with the return statement
#     create a variable, and make it the last value in the sub (implied return)
#     create the value inline and return it with the return statement
#     create the value inline and make it the last value in the sub (implied return)
#
# NOTE:
# we do not really check return context here. That should be
# in it's own test file

# TODO-NOTE:
# Currently the Hash and Hash-ref tests are not complete, becuase hashes seem to be
# broken in a number of ways. I will get back to those later.

## void
# ok(eval('sub ret { return }; 1'), "return without value parses ok");

sub bare_return { return };

ok(! bare_return(), "A bare return is a false value");

my @l = ;
@l = bare_return();
is( @l, [], "A bare return is an empty list in array/list context");

my $s = "hello";
$s = bare_return();

nok($s.defined, "A bare return is undefined in scalar context");

## scalars

sub foo_scalar {
    my $foo = 'foo';
    return $foo;
}
is(foo_scalar(), 'foo', 'got the right return value');

# ... w/out return statement

sub foo_scalar2 {
    my $foo = 'foo';
    $foo;
}
is(foo_scalar2(), 'foo', 'got the right return value');

# ... returning constant

sub foo_scalar3 {
    return 'foo';
}
is(foo_scalar3(), 'foo', 'got the right return value');

# ... returning constant w/out return statement

sub foo_scalar4 {
    'foo';
}
is(foo_scalar4(), 'foo', 'got the right return value');

## arrays

sub foo_array {
    my @foo = ('foo', 'bar', 'baz');
    return @foo;
}
my @foo_array_return = foo_array();
isa_ok(@foo_array_return, Array);
is(+@foo_array_return, 3, 'got the right number of return value');
is(@foo_array_return[0], 'foo', 'got the right return value');
is(@foo_array_return[1], 'bar', 'got the right return value');
is(@foo_array_return[2], 'baz', 'got the right return value');

# ... without the last return statement

sub foo_array2 {
    my @foo = ('foo', 'bar', 'baz');
    @foo;
}
my @foo_array_return2 = foo_array2();
isa_ok(@foo_array_return2, Array);
is(+@foo_array_return2, 3, 'got the right number of return value');
is(@foo_array_return2[0], 'foo', 'got the right return value');
is(@foo_array_return2[1], 'bar', 'got the right return value');
is(@foo_array_return2[2], 'baz', 'got the right return value');

# ... returning an Array constructed "on the fly"

sub foo_array3 {
    return ('foo', 'bar', 'baz');
}
my @foo_array_return3 = foo_array3();
isa_ok(@foo_array_return3, Array);
is(+@foo_array_return3, 3, 'got the right number of return value');
is(@foo_array_return3[0], 'foo', 'got the right return value');
is(@foo_array_return3[1], 'bar', 'got the right return value');
is(@foo_array_return3[2], 'baz', 'got the right return value');

# ... returning an Array constructed "on the fly" w/out return statement

sub foo_array4 {
    ('foo', 'bar', 'baz');
}
my @foo_array_return4 = foo_array4();
isa_ok(@foo_array_return4, Array);
is(+@foo_array_return4, 3, 'got the right number of return value');
is(@foo_array_return4[0], 'foo', 'got the right return value');
is(@foo_array_return4[1], 'bar', 'got the right return value');
is(@foo_array_return4[2], 'baz', 'got the right return value');

## Array Refs aka - Lists

sub foo_array_ref {
   my $foo = ['foo', 'bar', 'baz'];
   return $foo;
}
my $foo_array_ref_return = foo_array_ref();
isa_ok($foo_array_ref_return, Array);
is(+$foo_array_ref_return, 3, 'got the right number of return value');
is($foo_array_ref_return[0], 'foo', 'got the right return value');
is($foo_array_ref_return[1], 'bar', 'got the right return value');
is($foo_array_ref_return[2], 'baz', 'got the right return value');

# ... w/out the return statement

sub foo_array_ref2 {
   my $foo = ['foo', 'bar', 'baz'];
   $foo;
}
my $foo_array_ref_return2 = foo_array_ref2();
isa_ok($foo_array_ref_return2, Array);
is(+$foo_array_ref_return2, 3, 'got the right number of return value');
is($foo_array_ref_return2[0], 'foo', 'got the right return value');
is($foo_array_ref_return2[1], 'bar', 'got the right return value');
is($foo_array_ref_return2[2], 'baz', 'got the right return value');

# ... returning list constructed "on the fly"

sub foo_array_ref3 {
   return ['foo', 'bar', 'baz'];
}
my $foo_array_ref_return3 = foo_array_ref3();
isa_ok($foo_array_ref_return3, Array);
is(+$foo_array_ref_return3, 3, 'got the right number of return value');
is($foo_array_ref_return3[0], 'foo', 'got the right return value');
is($foo_array_ref_return3[1], 'bar', 'got the right return value');
is($foo_array_ref_return3[2], 'baz', 'got the right return value');

# ... returning list constructed "on the fly" w/out return statement

sub foo_array_ref4 {
   ['foo', 'bar', 'baz'];
}
my $foo_array_ref_return4 = foo_array_ref4();
isa_ok($foo_array_ref_return4, Array);
is(+$foo_array_ref_return4, 3, 'got the right number of return value');
is($foo_array_ref_return4[0], 'foo', 'got the right return value');
is($foo_array_ref_return4[1], 'bar', 'got the right return value');
is($foo_array_ref_return4[2], 'baz', 'got the right return value');

## hashes

sub foo_hash {
    my %foo = ('foo', 1, 'bar', 2, 'baz', 3);
    return %foo;
}

my %foo_hash_return = foo_hash();
ok(%foo_hash_return ~~ Hash);
is(+%foo_hash_return.keys, 3, 'got the right number of return value');
is(%foo_hash_return, 1, 'got the right return value');
is(%foo_hash_return, 2, 'got the right return value');
is(%foo_hash_return, 3, 'got the right return value');

my $keys;
lives_ok({ $keys = +(foo_hash().keys) },
    "can call method on return value (hashref)");
is($keys, 3, "got right result");
lives_ok({ foo_hash() },
    "can hash de-ref return value (hashref)");

# now hash refs

sub foo_hash_ref {
    my $foo = { 'foo' => 1, 'bar' => 2, 'baz' => 3 };
    return $foo;
}

my $foo_hash_ref_return = foo_hash_ref();
ok($foo_hash_ref_return ~~ Hash);
is(+$foo_hash_ref_return.keys, 3, 'got the right number of return value');
is($foo_hash_ref_return, 1, 'got the right return value');
is($foo_hash_ref_return, 2, 'got the right return value');
is($foo_hash_ref_return, 3, 'got the right return value');

lives_ok({ $keys = +(foo_hash_ref().keys) },
    "can call method on return value (hashref)");
is($keys, 3, "got right result");
lives_ok({ foo_hash_ref() },
    "can hash de-ref return value (hashref)");

# from return2.t
{
  sub userdefinedcontrol_a (&block) { block(); return 24 }
  sub official_a {
    userdefinedcontrol_a { return 42 };
  }
  is official_a(), 42, "bare blocks are invisible to return";
}

{
  sub userdefinedcontrol_b (&block) { block(); return 24 }
  sub official_b {
    {
        {
            userdefinedcontrol_b { return 42 };
        }
    }
  }
  is official_b(), 42, "nested bare blocks are invisible to return";
}

{
  sub userdefinedcontrol_c ($value, &block) { block($value); return 24 }
  sub official_c($value) {
    {
        userdefinedcontrol_c $value, -> $x { return $x };
    }
  }
  is official_c(42), 42, "pointy blocks are invisible to return";
}

# return should desugar to &?ROUTINE.leave, where &?ROUTINE is lexically scoped
#    to mean the current "official" subroutine or method.

#?niecza todo
{
  sub userdefinedcontrol3 (&block) { block(); return 36 }
  sub userdefinedcontrol2 (&block) { userdefinedcontrol3(&block); return 24 }
  sub userdefinedcontrol1 (&block) { userdefinedcontrol2(&block); return 12 }
  sub official_d {
    userdefinedcontrol1 { return 42 };
  }
  #?pugs todo 'bug'
  is official_d(), 42,
    "subcalls in user-defined control flow are invisible to return";
}

class Foo {
  method userdefinedcontrol3 (&block) { block(); 36 }
  submethod userdefinedcontrol2 (&block) { self.userdefinedcontrol3(&block); 24 }
  method userdefinedcontrol1 (&block) { self.userdefinedcontrol2(&block); 12 }
  method officialmeth {
    self.userdefinedcontrol1({ return 42 });
  }
  submethod officialsubmeth {
    self.userdefinedcontrol1({ return 43 });
  }
  our sub official {
    Foo.new.userdefinedcontrol1({ return 44 });
  }
}

#?pugs 3 todo 'return(), blocks and methods'
#?niecza 3 todo
is Foo.new.officialmeth(), 42,
    "return correctly from official method only";
is Foo.new.officialsubmeth(), 43,
    "return correctly from official submethod only";
is Foo::official(), 44,
    "return correctly from official sub only";

# RT #75118
#?rakudo skip 'RT 75118'
#?niecza skip "Excess arguments to return, unused named c"
{
    sub named() {
        return 1, 2, :c(3);
    }
    is named().elems, 3,       'return with named arguments';
    is named().[2].key, 'c',   ' ... correct key';
    #?rakudo todo 'named argument to return()'
    is named().[2].value, '3', ' ... correct value';
}

# RT #61732
#?niecza todo
{
    sub rt61732_c { 1; CATCH {} }
    #?rakudo todo 'RT 61732'
    is rt61732_c(), 1, 'sub with empty catch block returns value before block';
}

#?niecza todo
{
    sub rt61732_d { 1;; }
    is rt61732_d(), 1, 'get right value from sub with double ;';
}

# RT #63912
{
    sub rt63912 { return 1, 2; }
    lives_ok { rt63912() }, 'can call sub that returns two things (no parens)';
}

# RT #72836
{
    class RT72836 {
        method new() { }
    }
    lives_ok {my $c = RT72836.new},
        'can use value returned from empty routine';
}

# RT #61126
#?niecza skip "eager NYI"
{
    sub bar61126($code) { $code() }; sub foo61126 { bar61126 { return 1 }; return 2; };
    #?pugs todo
    is foo61126, 1;

    sub baz61126 { eager map { return 1 }, 1; return 2 };
    is baz61126, 1;

}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/stub.t0000664000175000017500000000205512224265625017265 0ustar  moritzmoritzuse v6;
use Test;

plan 10;

# L

lives_ok({sub thunder {...}}, 'sub foo {...} works');

eval_dies_ok('sub foo;', 'old Perl 5 "sub foo;" syntax is dead');

{
    sub lightning {...}
    # Maybe should be warns_ok
    eval_dies_ok('lightning()', 'executing stub subroutine dies');
    sub lightning {42}
    is(lightning(), 42, 'redefining stub subroutine works without extra syntax');

    sub hail {???}
    # Should be warns_ok
    lives_ok({hail()}, 'executing stub subroutine lives (should warn here)');
    sub hail {47}
    is(hail(), 47, 'redefining stub subroutine works without extra syntax');

    sub wind {!!!}
    eval_dies_ok('wind()', 'executing stub subroutine dies');
    sub wind {17}
    is(wind(), 17, 'redefining stub subroutine works without extra syntax');

}

{
    use MONKEY_TYPING;
    sub hail {26}
    # Maybe should be warns_ok
    eval_dies_ok('sub hail {10}', 'redefining existing subroutine dies');
    supersede sub hail {8}
    is(hail(), 8, 'redefining non-stub subroutine with supersede');
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-advanced/wrap.t0000664000175000017500000001321712224265625017263 0ustar  moritzmoritzuse v6;

use Test;
use soft;

# L

# TODO
# nextsame, nextwith, callsame
# unwrap with no args pops the top most (is this spec?)
#
# mutating wraps -- those should be "deep", as in not touching coderefs
# but actually mutating how the coderef works.

plan 69;

my @log;

sub foo {
    push @log, "foo";
}

sub wrapper {
    push @log, "wrapper before";
    try { callwith() };
    push @log, "wrapper after";
}

sub other_wrapper () {
    push @log, "wrapper2";
    try { callwith() };
}

foo();
is(+@log, 1, "one event logged");
is(@log[0], "foo", "it's foo");

dies_ok { &foo.unwrap() }, 'cannot upwrap a never-wrapped sub.';

@log = ();

wrapper();
is(+@log, 2, "two events logged");
is(@log[0], "wrapper before", "wrapper before");
is(@log[1], "wrapper after", "wrapper after");

@log = ();

my $wrapped = &foo.wrap(&wrapper);

foo();

is @log.join('|'), 'wrapper before|foo|wrapper after', 'logged the correct events';

@log = ();

my $doublywrapped = &foo.wrap(&other_wrapper);
foo();

is(+@log, 4, "four events");
is(@log[0], "wrapper2", "additional wrapping takes effect");
is(@log[1], "wrapper before", "... on top of initial wrapping");

@log = ();

&foo.unwrap($doublywrapped);
foo();

is(+@log, 3, "old wrapped sub was not destroyed");
is(@log[0], "wrapper before", "the original wrapper is still in effect");

@log = ();

&foo.unwrap($wrapped);
foo();

is(+@log, 1, "one events for unwrapped (should be back to original now)");
is(@log[0], "foo", "got execpted value");

@log = ();

$wrapped = &foo.wrap(&wrapper);
$doublywrapped = &foo.wrap(&other_wrapper);
&foo.unwrap($wrapped);
foo();
is(+@log, 2, "out of order unwrapping gave right number of results");
is(@log[0], "wrapper2", "got execpted value from remaining wrapper");
is(@log[1], "foo", "got execpted value from original sub");

dies_ok { &foo.unwrap($wrapped) }, "can't re-unwrap an already unwrapped sub";



# from wrapping.t

#First level wrapping
sub hi { "Hi" };
is( hi, "Hi", "Basic sub." );
my $handle;
lives_ok( { $handle = &hi.wrap({ callsame() ~ " there" }) }, 
        "Basic wrapping works ");

ok( $handle, "Recieved handle for unwrapping." );
is( hi, "Hi there", "Function produces expected output after wrapping" );

#unwrap the handle
lives_ok { $handle = &hi.unwrap( $handle )}, "unwrap the function";

is( hi, "Hi", "Function is no longer wrapped." );

#Check 10 levels of wrapping
#useless function.
sub levelwrap($n) {
    return $n;
}

# Make sure useless function does it's job.
is( levelwrap( 1 ), 1, "Sanity test." );
is( levelwrap( 2 ), 2, "Sanity test." );

#?rakudo todo 'callwith'
lives_ok { &levelwrap.callwith( 1 )},
    "Check that functions have a 'callwith' that works. ";

#?DOES 20
{
    for (1..10) -> $num {
        lives_ok {
                &levelwrap.wrap({ 
                    callwith( $^t + 1 );
                }),
                " Wrapping #$num"
        }, "wrapping $num";
        is( levelwrap( 1 ), 1 + $num, "Checking $num level wrapping" );
    }
}

#Check removal of wrap in the middle by handle.
sub functionA {
    return 'z';
}
is( functionA(), 'z', "Sanity." );
my $middle;
lives_ok { $middle = &functionA.wrap(sub { return 'y' ~ callsame })}, 
        "First wrapping lived";
is( functionA(), "yz", "Middle wrapper sanity." );
lives_ok { &functionA.wrap(sub { return 'x' ~ callsame })}, 
         'Second wraping lived';
is( functionA(), "xyz", "three wrappers sanity." );
lives_ok { &functionA.unwrap( $middle )}, 'unwrap the middle wrapper.';
is( functionA(), "xz", "First wrapper and final function only, middle removed." );

#temporization (end scope removal of wrapping)
sub functionB {
   return 'xxx';
}
{
    is( functionB, "xxx", "Sanity" );
    {
        try {
            temp &functionB.wrap({ return 'yyy' });
        };
        is( functionB, 'yyy', 'Check that function is wrapped.' );
    }
    #?rakudo todo 'temp and wrap'
    is( functionB, 'xxx', "Wrap is now out of scope, should be back to normal." );
}
#?rakudo todo 'temp and wrap'
is( functionB, 'xxx', "Wrap is now out of scope, should be back to normal." );

#?rakudo todo 'RT 70267: call to nextsame with nowhere to go'
dies_ok { {nextsame}() }, '{nextsame}() dies properly';

# RT #66658
#?niecza skip "undefined undefined"
{
    sub meet(  $person ) { return "meet $person"  }
    sub greet( $person ) { return "greet $person" }

    my $wrapped;

    for &greet, &meet -> $wrap {
        my $name = $wrap.name;
        $wrap.wrap({ $wrapped = $name; callsame; });
    }

    ok ! $wrapped.defined, 'wrapper test variable is undefined';
    is greet('japhb'), 'greet japhb', 'wrapped greet() works';
    is $wrapped, 'greet', 'wrapper sees lexical from time of wrap (greet)';

    undefine $wrapped;

    ok ! $wrapped.defined, 'wrapper test variable is undefined';
    is meet('masak'), 'meet masak', 'wrapped meet() works';
    is $wrapped, 'meet', 'wrapper sees lexical from time of wrap (meet)';
}

{
    sub foo() { 1 }
    my $h = &foo.wrap(-> { 1 + callsame });
    is foo(), 2, 'wrap worked (sanity)';
    $h.restore();
    is foo(), 1, 'could unwrap by calling .restore on the handle';
}

# RT #69312
#?rakudo.jvm skip "control operator crossed continuation barrier"
{
    my @t = gather {
        sub triangle { take '=' x 3; }
        for reverse ^3 -> $n {
            &triangle.wrap({
                take '=' x $n;
                callsame;
                take '=' x $n;
            });
        }
        triangle();
    }
    is @t.join("\n"), "\n=\n==\n===\n==\n=\n", 'multiple wrappings in a loop';
}

# RT #77472
{
    multi multi-to-wrap($x) {
        $x * 2;
    };
    &multi-to-wrap.wrap({
        2 * callsame;
    });
    #?rakudo todo 'RT 77472'
    is multi-to-wrap(5), 20, 'can wrap a multi';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-currying/assuming-and-mmd.t0000664000175000017500000000130312224265625021541 0ustar  moritzmoritzuse v6;

use Test;

plan 6;

multi testsub (Str $x, $y) { "Str" }    #OK not used
multi testsub (Int $x, $y) { "Int" }    #OK not used

is testsub("a_str", 42), "Str", "basic MMD works (1)";
is testsub(23,      42), "Int", "basic MMD works (2)";

is &testsub("a_str", 42), "Str", "basic MMD works with subrefs (1)";
is &testsub(23,      42), "Int", "basic MMD works with subrefs (2)";

#?pugs todo 'bug'
#?niecza skip 'Unable to resolve method assuming in class Code'
is &testsub.assuming("a_str")(42), "Str", "basic MMD works with assuming (1)";
#?niecza skip 'Unable to resolve method assuming in class Code'
is &testsub.assuming(23)\   .(42), "Int", "basic MMD works with assuming (2)";

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-currying/mixed.t0000775000175000017500000000450212224265625017515 0ustar  moritzmoritzuse v6;

use Test;

=begin description

Tests curried subs as defined by 

= TODO

* assuming on a use statement

=end description

# L

plan 14;

sub foo ($x?, $y?, $z = 'd') {
    "x=$x y=$y z=$z";
}

is(foo(1, 2), "x=1 y=2 z=d", "uncurried sub has good output");
is(foo(x => 1, y => 2), "x=1 y=2 z=d", "uncurried sub with pair notation");

is((&foo.assuming(y => 2))(x => 1), foo(1, 2), "curried sub with named params");

is((&foo.assuming(y => 2))(1), foo(1, 2), "curried sub, mixed notation");

is((&foo.assuming(x => 1))(2), foo(1, 2), "same thing, but the other way around");

is((&foo.assuming(:x(1)))(2), foo(1, 2), "curried sub, use colon style");

#?niecza skip 'Multi colonpair syntax not yet understood'
is((&foo.assuming(:x(1) :y(2)))(), foo(1, 2), "same thing, but more colon");

#?niecza skip 'Unable to resolve method assuming:x in class Sub'
is((&foo.assuming:x(1))(2), foo(1, 2), "curried sub, another colon style");

#?niecza skip 'Unable to resolve method assuming:x in class Sub'
is((&foo.assuming:x(1):y(2))(), foo(1, 2), "same thing, but more pre colon");

#?niecza todo
#?pugs skip 'Named argument found where no matched parameter expected'
ok(!(try { &foo.assuming(f => 3) }), "can't curry nonexistent named param");

# L
#?niecza todo
#?pugs todo
eval_lives_ok q'
    (use t::packages::PackageTest) // {}).assuming(arg1 => "foo");
    die "not working" unless
        dummy_sub_with_params(arg2 => "bar") } eq "[foo] [bar]",
', "(use ...).assuming works";

sub __hyper (@a, @b, $op?) {
  my @ret;
  for 0..(@a.end, @b.end).max -> $i {
    if $i > @a.end {
      push @ret, @b[$i];
    }
    elsif $i > @b.end {
      push @ret, @a[$i];
    }
    else {
      push @ret, $op(@a[$i], @b[$i]);
    }
  }
  return @ret;
}

my @x = (1,2,23);
is( try { &__hyper.assuming(op => &infix:<+>)(@x, @x) },
    (2,4,46), 'currying functions with array arguments' );
is( try { &__hyper.assuming(op => &infix:<+>)(a => @x, b => @x) },
    (2,4,46), 'currying functions with named array arguments' );

#?pugs skip 'No such subroutine: "&FortyTwo"'
{
  # tests RT #70890
  my $out = "";
  my sub foo($a, $b) { $a-1; $out~='\o/'; $b == 42 };
  subset FortyTwo of Int where &foo.assuming(0);
  $out ~= 42 ~~ FortyTwo;
  is $out, '\o/True', 'where interaction with .assuming';
}
# vim: ft=perl6
rakudo-2013.12/t/spec/S06-currying/named.t0000664000175000017500000000071412224265625017471 0ustar  moritzmoritzuse v6;
use Test;

# L
plan 3;

sub tester(:$a, :$b, :$c) {
    "a$a b$b c$c";
}

{
    my $w = &tester.assuming(b => 'x');
    is $w(a => 'w', c => 'y'), 'aw bx cy', 'currying one named param';
}

{
    my $w = &tester.assuming(b => 'b');
    my $v =  $w.assuming(c => 'c');
    is $v(a => 'x'), 'ax bb cc', 'can curry on an already curried sub';
    is $w(a => 'x', c => 'd'), 'ax bb cd', '... and the old one still works';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-macros/errors.t0000664000175000017500000000045712224265625017347 0ustar  moritzmoritzuse v6;

use Test;

#L

plan 2;

#RT #115506
eval_lives_ok
    'macro pathological { AST.new }; pathological();',
    "macro returning AST.new doesn't blow up";

#RT #115504
{
    try eval 'macro ma { die 1 }; ma';
    is $!, 1, "die-ing inside a macro dies normally.";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-macros/opaque-ast.t0000664000175000017500000000233112224265625020103 0ustar  moritzmoritzuse v6;

use Test;

=begin pod
=head1 DESCRIPTION

Tests for macros which return quasi but do not do splicing

See L.

=end pod

plan 7;

# L
macro four () { quasi { 2+2 } } 

is(four, 4, "macro returning quasi");

#?rakudo skip ':COMPILING flag'
{
    macro hi () { quasi :COMPILING { "hello $s" } } 

    macro hey () { ({ "hello $^s" }.body) } 

    my $s="world"; 
    is(hi(),"hello world","macros can bind in caller's lexical env");

    $s="paradise"; 
    is(hi(),"hello paradise","macros but it's a binding only");
    is(hey(),"hello paradise","macros but it's a binding only");
}

{
    my $x;
    macro noop ()  { $x = "Nothing happened"; quasi { } } 
    noop();

    is($x,"Nothing happened", "Macros can return noops");
}


{
    macro hygienic ($ast) {
        my $x = 3;
        quasi { $x + {{{ $ast }}} }
    }
    my $x = 4;
    is hygienic($x), 7, 'lexical vars in macros are not visible to the AST vars';
}

#?rakudo skip 'return from macro'
{
    macro outside-declaration ( $ast ) {
        my $COMPILING::x = 4;
        return quasi { {{{ $ast }}} }
    }
    is outside-declaration( { $x * 2 } ), 8, 
       'A macro can declare lexicals that are visible where called';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-macros/postfix.t0000664000175000017500000000030012224265625017512 0ustar  moritzmoritzuse v6;

use Test;

plan 1;

# L

macro postfix: (Int $n) {
    my $factorial = [*] 1..$n;
    return "$factorial + 0";
}

is 3!, 6, "macro postfix: works";

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-macros/quasi-blocks.t0000664000175000017500000000444112224265625020425 0ustar  moritzmoritzuse v6;

use Test;
plan 12;

# Just to avoid tedium, the macros in this file are
# named after Santa's reindeers.

{ # macro called like a sub
    my $macro_visits;

    macro dasher() {
        $macro_visits++;
        quasi {}
    }

    dasher();
    is $macro_visits, 2, "calls to macro are at parse time";
    dasher();

    my $total_args;
    macro dancer($a, $b?) {
        $total_args++ if defined $a;
        $total_args++ if defined $b;
        quasi {}
    }

    dancer(17);
    is $total_args, 3, "macro call with arguments works";
    dancer(15, 10);
}

{ # macro called like a list prefix
    my $macro_visits;

    macro prancer() {
        $macro_visits++;
        quasi {}
    }

    prancer;
    is $macro_visits, 2, "macro calls without parens work";
    prancer;

    my $total_args;
    macro vixen($a, $b?) {
        $total_args++ if defined $a;
        $total_args++ if defined $b;
        quasi {}
    }

    vixen 17;
    is $total_args, 3, "macro call with arguments works";
    vixen 15, 10;
}

# macro defined as an operator, and used as one

{
    macro infix:($rhs, $lhs) {   #OK not used
        quasi { "comet!" }
    }

    my $result = 1 comet 2;
    is $result, "comet!", "can define an entirely new operator";
}

{
    macro infix:<+>($rhs, $lhs) {
        quasi { "chickpeas" }
    }

    my $result = "grasshopper" + "motor oil";
    is $result, "chickpeas", "can shadow an existing operator";
}

#?pugs skip 'undeclared variable'
{
    macro cupid {
        my $a = "I'm cupid!";

        quasi { $a }
    }

    my $result = cupid;
    is $result, "I'm cupid!", "lexical lookup from quasi to macro works";
}

#?rakudo.jvm skip "Method 'succ' not found"
{
    my $counter = 0;

    macro donner {
        quasi { ++$counter }
    }

    is donner, 1, "lexical lookup from quasi to outside macro works";
    is donner, 2, "...twice";
}

#?pugs skip 'undeclared variable'
{
    macro blitzen($param) {
        quasi { $param }
    }

    ok blitzen("onwards") ~~ AST,
        "lexical lookup from quasi to macro params works";
}

#?pugs skip 'No such subroutine: "&x"'
{
    macro id($param) { $param };
    is id('x'), 'x', 'macro can return its param';
}

#?pugs skip 'Nil'
{
    macro funny_nil { quasi { {;}() } }
    is funny_nil(), Nil, 'Nil from an empty block turns into no code';
}
rakudo-2013.12/t/spec/S06-macros/returning-closure.t0000664000175000017500000000102412224265625021511 0ustar  moritzmoritzuse v6;

use Test;

#L

plan 4;

{
  my $z = 3;
  my $in_macro;
  my $in_macro_clos;
  macro returns_a_closure {
    my $x = 42;
    $in_macro = 1;
    return { $in_macro_clos++; 100 + $x + $z };
  }

  is $in_macro,           1, "macro was executed during compile time";
  ok !$in_macro_clos,        "macro closure was not executed during compile time";
  #?pugs todo
  is returns_a_closure, 145, "closure returning macro";
  is $in_macro_clos,      1, "macro closure was executed during runtime";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-macros/returning-string.t0000664000175000017500000000204712224265625021351 0ustar  moritzmoritzuse v6;

use Test;

# L

plan 8;

{
  my $was_in_macro;
  macro dollar_foo { $was_in_macro = 1; '$COMPILING::foo' }
  is $was_in_macro, 1, "string returning macro was called at compile time";
  my $foo = 42;
  #?pugs todo
  is dollar_foo, $foo, "simple string returning macro (1)";
  dollar_foo() = 23;
  #?pugs todo
  is $foo, 23, "simple string returning macro (2)";
}

{
  my $ret = eval '
    macro plus_3 { "+ 3" }
    42 plus_3;
  ';
  #?pugs todo 'feature'
  is $ret, 45, "simple string returning macro (3)";
};

{
  macro four { '4' }
  my $foo = 100 + four;
  is $foo, 104, "simple string returning macro (4)";
}

{
  macro prefix_1000 (Int $x) { "1000$x" }
  is prefix_1000(42), 100042, "simple string returning macro (5)";
}

{
  my $was_in_macro;
  macro prefix_2000 (Int $x) { $was_in_macro = 1; "2000$x" }
  is $was_in_macro, 1,
    "simple string returning macro without argparens is parsed correctly (1)";
  is (prefix_2000 42), 200042,
    "simple string returning macro without argparens is parsed correctly (2)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-macros/unquoting.t0000664000175000017500000000344112224265625020060 0ustar  moritzmoritzuse v6;

use lib 't/spec/packages';
use Test::Util;

use Test;
plan 10;

# editorial note:
# macros in this file have been named after 20th-century physicists.

{ # simplest possible unquote splicing
    my $unquote_splicings;
    BEGIN { $unquote_splicings = 0 }; # so it's not Any() if it doesn't work

    macro planck($x) {
        quasi { {{{$unquote_splicings++; $x}}} }
    }

    planck "length";
    is $unquote_splicings, 1, "spliced code runs at parse time";
}

#{ # building an AST from smaller ones
#    macro bohr() {
#        my $q1 = quasi { 6 };
#        my $q2 = quasi { 6 * 10 };
#        my $q3 = quasi { 100 + 200 + 300 };
#        quasi { {{{$q1}}} + {{{$q2}}} + {{{$q3}}} }
#    }
#
#    is bohr(), 666, "building quasis from smaller quasis works";
#}

{ # building an AST incrementally
    macro einstein() {
        my $q = quasi { 2 };
        $q = quasi { 1 + {{{$q}}} };
        $q = quasi { 1 + {{{$q}}} };
        $q;
    }

    is einstein(), 4, "can build ASTs incrementally";
}

{ # building an AST incrementally in a for loop
    macro podolsky() {
        my $q = quasi { 2 };
        $q = quasi { 1 + {{{$q}}} } for ^2;
        $q;
    }

    is podolsky(), 4, "can build ASTs in a for loop";
}

{ # using the mainline context from an unquote
    macro rosen($code) {
        my $paradox = "this shouldn't happen";
        quasi {
            {{{$code}}}();
        }
    }

    my $paradox = "EPR";
    is rosen(sub { $paradox }), "EPR", "unquotes retain their lexical context";
}

{ # unquotes must evaluate to ASTs
    #?does 5
    throws_like 'macro bohm() { quasi { {{{"not an AST"}}} } }; bohm',
                X::TypeCheck::Splice,
                got      => Str,
                expected => AST,
                action   => 'unquote evaluation',
                line     => 1;
}
rakudo-2013.12/t/spec/S06-multi/by-trait.t0000664000175000017500000000112312224265625017423 0ustar  moritzmoritzuse v6;
use Test;

# RT 66588
{
    my $ro_call = 0;
    my $rw_call = 0;
    multi sub uno_mas( Int $ro       ) { $ro_call++; return 1 + $ro }
    multi sub uno_mas( Int $rw is rw ) { $rw_call++; return ++$rw }

    is uno_mas(42), 43, 'multi works with constant';
    is $ro_call, 1, 'read-only multi was called';

    my $x = 99;
    #?niecza skip 'Ambiguous dispatch for &uno_mas'
    is uno_mas( $x ), 100, 'multi works with variable';
    #?niecza todo
    is $x, 100, 'variable was modified';
    #?niecza todo
    is $rw_call, 1, 'read-write multi was called';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-multi/lexical-multis.t0000664000175000017500000000342212224265625020630 0ustar  moritzmoritzuse v6;

use Test;

plan 15;

# basic test that multi is lexical
{
    {
        my multi foo() { 42 }
        is(foo(), 42, 'can call lexically scoped multi');
    }
    eval_dies_ok(q{ foo() }, 'lexical multi not callable outside of lexical scope');
}

# test that lexical multis in inner scopes add to those in outer scopes
{
    {
        my multi bar() { 1 }
    
        {
            my multi bar($x) { 2 }    #OK not used
		    
            is(bar(),      1, 'outer lexical multi callable');
            is(bar('syr'), 2, 'new inner lexical multi callable');
        }

        is(bar(), 1, 'in outer scope, can call the multi that is in scope');
        dies_ok { eval("bar('pivo')") }, 'multi variant from inner scope not callable in outer';
    }

    dies_ok { eval q{ bar() }},    'no multi variants callable outside of lexical scope';
    dies_ok { eval q{ bar('kava')} }, 'no multi variants callable outside of lexical scope';
}

# an inner multi with a signature matching an outer will hide it
{
    my multi baz() { 1 }
    {
        my multi baz() { 2 }   #OK not used
        #?rakudo todo 'lexical scope as tie breaker'
        lives_ok({ baz() }, 'inner multi conflicts with outer one');
    }
    is(baz(), 1, 'in outer scope, no inner multi, so no conflict');
}

# lexical multi can add to package multi if no outer lexical ones
multi waz() { 1 }
{
    my multi waz($x) { 2 }   #OK not used
    is(waz(),       1, 'got multi from package');
    is(waz('slon'), 2, 'lexical multi also callable');
}
is(waz(), 1,             'multi from package still callable outside the inner scope...');
dies_ok { eval("waz('vtak')") }, '...but lexical multi no longer callable';

# RT #78208
{
    dies_ok { multi foo() { }; multi foo($x) { }; +&foo }, 'RT #78208';   #OK not used
}

# vim: ft=perl6 :
rakudo-2013.12/t/spec/S06-multi/positional-vs-named.t0000664000175000017500000000726512224265625021576 0ustar  moritzmoritzuse v6;
use Test;
plan 27;

# check the subroutine with the closest matching signature is called
#
#L
#L

# the single parameter cases named and positional below - part of RT 53814

multi earth (:$me!)                 {"me $me"};
multi earth (:$him!)                {"him $him"};
multi earth (:$me!, :$him!)         {"me $me him $him"};
multi earth (:$me!, :$him!, :$her!) {"me $me him $him her $her"};
multi earth ($me)                   {"pos $me"};
multi earth ($me, :$you!)           {"pos $me you $you"};
multi earth ($me, :$her!)           {"pos $me her $her"};
multi earth ($me, $you)             {"pos $me pos $you"};
multi earth ($me, $you, :$her!)     {"pos $me pos $you her $her"};

is( earth(me => 1),                     'me 1',             'named me');
is( earth(him => 2),                    'him 2',            'named you');
is( earth(me => 1, him => 2),           'me 1 him 2',       'named me, named him');
is( earth(him => 2, me => 1),           'me 1 him 2',       'named him, named me');
is( earth(me => 1, him => 2, her => 3), 'me 1 him 2 her 3', 'named me named him named her');
is( earth(him => 2, me => 1, her => 3), 'me 1 him 2 her 3', 'named him named me named her');
is( earth(her => 3, me => 1, him => 2), 'me 1 him 2 her 3', 'named her named me named him');
is( earth(her => 3, him => 2, me => 1), 'me 1 him 2 her 3', 'named her named him named me');

is( earth('b', you => 4),      'pos b you 4',       'pos, named you');
is( earth('c', her => 3),      'pos c her 3',       'pos, named her');
is( earth('d', 'e'),           'pos d pos e',       'pos, pos');
is( earth('f', 'g', her => 3), 'pos f pos g her 3', 'pos, pos, named');


# ensure we get the same results when the subroutines are 
# defined in reverse order
#

multi wind ($me, $you, :$her!)     {"pos $me pos $you her $her"};
multi wind ($me, $you)             {"pos $me pos $you"};
multi wind ($me, :$her!)           {"pos $me her $her"};
multi wind ($me, :$you!)           {"pos $me you $you"};
multi wind (:$me!, :$him!, :$her!) {"me $me him $him her $her"};
multi wind (:$me!, :$him!)         {"me $me him $him"};
multi wind (:$him)                 {"him $him"};
multi wind (:$me)                  {"me $me"};

is( wind(me => 1),                     'me 1',             'named me');
is( wind(him => 2),                    'him 2',            'named you');
is( wind(me => 1, him => 2),           'me 1 him 2',       'named me, named him');
is( wind(him => 2, me => 1),           'me 1 him 2',       'named him, named me');
is( wind(me => 1, him => 2, her => 3), 'me 1 him 2 her 3', 'named me named him named her');
is( wind(him => 2, me => 1, her => 3), 'me 1 him 2 her 3', 'named him named me named her');
is( wind(her => 3, me => 1, him => 2), 'me 1 him 2 her 3', 'named her named me named him');
is( wind(her => 3, him => 2, me => 1), 'me 1 him 2 her 3', 'named her named him named me');

is( wind('b', you => 4),      'pos b you 4',       'pos, named you');
is( wind('c', her => 3),      'pos c her 3',       'pos, named her');
is( wind('d', 'e'),           'pos d pos e',       'pos, pos');
is( wind('f', 'g', her => 3), 'pos f pos g her 3', 'pos, pos, named');

{
    # a nom bug
    multi catch(*@all            ) { 1 }   #OK not used
    multi catch(*@all, :$really! ) { 2 }   #OK not used
    #?rakudo 2 skip 'slurpy and named interaction'
    is catch(0, 5),           1, 'slurpy and named interact well (1)';
    is catch(0, 5, :!really), 2, 'slurpy and named interact well (2)';
}

# RT #78738
{
    multi zero()       { 'no args' };
    multi zero(:$foo!) { 'named'   };
    is zero(), 'no args',
        'presence of mandatory named multi does not corrupt calling a nullary'
}


# vim: ft=perl6
rakudo-2013.12/t/spec/S06-multi/proto.t0000664000175000017500000000777412224265625017055 0ustar  moritzmoritzuse v6;
use Test;
plan 28;

# Test for proto definitions
class A { }
class B { }
proto foo($x) { * }    #OK not used
multi foo(A $x) { 2 }  #OK not used
multi foo(B $x) { 3 }  #OK not used
multi foo($x)   { 1 }  #OK not used
is(foo(A.new), 2, 'dispatch on class worked');
is(foo(B.new), 3, 'dispatch on class worked');
is(foo(42),    1, 'dispatch with no possible candidates fell back to proto');

#?rakudo skip "redeclaration of routine 'bar'"
#?niecza skip "Illegal redeclaration of routine 'bar'"
{
    # Test that proto makes all further subs in the scope also be multi.
    proto bar() { "proto" }
    sub bar($x) { 1 }    #OK not used
    multi bar($x, $y) { 2 }    #OK not used
    multi sub bar($x, $y, $z) { 3 }    #OK not used
    sub bar($x, $y, $z, $a) { 4 }    #OK not used
    is bar(),  "proto", "called the proto";
    is bar(1),       1, "sub defined without multi has become one";
    is bar(1,2),     2, "multi ... still works, though";
    is bar(1,2,3),   3, "multi sub ... still works too";
    is bar(1,2,3,4), 4, "called another sub as a multi candidate, made a multi by proto";
}

# L
{
    proto prefix:<[+]> (*@args) {
        my $accum = 0;
        $accum += $_ for @args;
        return $accum * 2; # * 2 is intentional here
    }

    #?rakudo todo 'operator protos'
    #?niecza todo
    is ([+] 1,2,3), 12, "[+] overloaded by proto definition";
}

# more similar tests
{
    proto prefix: ($arg) { $arg + 1 }
    is (moose 3), 4, "proto definition of prefix: works";
}

#?niecza skip '>>>Stub code executed'
{
    proto prefix: ($arg) { * }
    multi prefix: ($arg) { $arg + 1 }
    is (elk 3), 4, "multi definition of prefix: works";
}

eval_dies_ok 'proto rt68242($a){};proto rt68242($c,$d){};',
    'attempt to define two proto subs with the same name dies';

# RT #65322
{
    my $rt65322 = q[
        multi sub rt65322( Int $n where 1 ) { 1 }
              sub rt65322( Int $n ) { 2 }
    ];
    eval_dies_ok $rt65322, "Can't define sub and multi sub without proto";
}

{
    eval_dies_ok q[
        multi sub i1(Int $x) {}
        sub i1(Int $x, Str $y) {} 
    ], 'declaring a multi and a single routine dies';

    eval_dies_ok q[
        sub i2(Int $x, Str $y) {1}
        sub i2(Int $x, Str $y) {2}
    ], 'declaring two only-subs with same name dies';



}

# RT #68242
{
    eval_dies_ok 'proto foo($bar) {}; proto foo($baz, $quux) {}';
}

# RT #111454
#?niecza skip "System.NullReferenceException: Object reference not set to an instance of an object"
{
    my package Cont {
        our proto sub ainer($) {*}
        multi sub ainer($a) { 2 * $a };
    }
    is Cont::ainer(21), 42, 'our proto can be accessed from the ouside';
}

#?niecza skip 'Unhandled exception: Cannot use value like Block as a number'
{
    my proto f($) {
        2 * {*} + 5
    }
    multi f(Str) { 1 }
    multi f(Int) { 3 }

    is f('a'), 7, 'can use {*} in an expression in a proto (1)';
    is f(1),  11, 'can use {*} in an expression in a proto (2)';

    # RT #114882
    my $called_with = '';
    proto cached($a) {
        state %cache;
        %cache{$a} //= {*}
    }
    multi cached($a) {
        $called_with ~= $a;
        $a x 2;
    }
    is cached('a'), 'aa', 'caching proto (1)';
    is cached('b'), 'bb', 'caching proto (2)';
    is cached('a'), 'aa', 'caching proto (3)';
    is $called_with, 'ab', 'cached value did not cause extra call';

    proto maybe($a) {
        $a > 0 ?? {*} !! 0;
    }
    multi maybe($a) { $a };

    is maybe(8),  8, 'sanity';
    is maybe(-5), 0, "It's ok not to dispatch to the multis";
}

#RT #76298
{
    eval_lives_ok q{
        class TestA { has $.b; proto method b {} };
    }, 'proto method after same-named attribute';
    eval_lives_ok q{
        class TestB { proto method b {}; has $.b };
    }, 'proto method before same-named attribute';
}

# RT #116164
#?niecza todo
{
    eval_dies_ok q[
        proto f(Int $x) {*}; multi f($) { 'default' }; f 'foo'
    ], 'proto signature is checked, not just that of the candidates';
}
done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-multi/redispatch.t0000664000175000017500000000273112224265625020024 0ustar  moritzmoritzuse v6;
use Test;

plan 10;

# it doesn't seem to be explicit in S06, but {next,call}{same,with}
# work with multi subs too, not just with methods


{
    my $tracker = '';
    multi a($)     { $tracker ~= 'Any' };
    multi a(Int $) { $tracker ~= 'Int'; nextsame; $tracker ~= 'Int' };

    lives_ok { a(3) },      'can call nextsame inside a multi sub';
    is $tracker, 'IntAny', 'called in the right order';
}

{
    my $tracker = '';
    multi b($)     { $tracker ~= 'Any' };
    multi b(Int $) { $tracker ~= 'Int'; callsame; $tracker ~= 'Int' };

    lives_ok { b(3) },        'can call callsame inside a multi sub';
    is $tracker, 'IntAnyInt', 'called in the right order';
}

{
    my $tracker = '';
    multi c($x)     { $tracker ~= 'Any' ~ $x };
    multi c(Int $x) { $tracker ~= 'Int'; nextwith($x+1); $tracker ~= 'Int' };

    lives_ok { c(3) },      'can call nextwith inside a multi sub';
    is $tracker, 'IntAny4', 'called in the right order';
}

{
    my $tracker = '';
    multi d($x)     { $tracker ~= 'Any' ~ $x };
    multi d(Int $x) { $tracker ~= 'Int'; callwith($x+1); $tracker ~= 'Int' };

    lives_ok { d(3) },         'can call callwith inside a multi sub';
    is $tracker, 'IntAny4Int', 'called in the right order';
}

# RT #75008
{
    multi e() { nextsame };
    lives_ok &e, "It's ok to call nextsame in the last/only candidate";
}

# RT 76328
{
    try { nextsame };
    isa_ok $!, X::NoDispatcher, 'nextsame in main block dies due to lack of dispatcher';
}

done;rakudo-2013.12/t/spec/S06-multi/syntax.t0000664000175000017500000001447012224265625017227 0ustar  moritzmoritzuse v6;

use Test;

plan 41;

# L
# L

# multi sub with signature
multi sub foo() { "empty" }
multi sub foo($a) { "one" }    #OK not used
is(foo(), "empty", "multi sub with empty signature");
is(foo(42), "one", "multi sub with parameter list");

# multi sub without signature
multi sub bar { "empty" }
multi sub bar($a) { "one" }    #OK not used
#?niecza skip 'No candidates for dispatch to &bar'
is(bar(), "empty", "multi sub with no signature");
#?niecza skip 'Ambiguous dispatch for &bar'
#?pugs todo 
is(bar(42), "one", "multi sub with parameter list");

# multi without a routine type
multi baz { "empty" }
multi baz($a) { "one" }    #OK not used
#?niecza skip 'No candidates for dispatch to &baz'
is(baz(), "empty", "multi with no signature");
#?niecza skip 'Ambiguous dispatch for &baz'
#?pugs todo 
is(baz(42), "one", "multi with parameter list");

# multi without a routine type with signature
multi foobar() { "empty" }
multi foobar($a) { "one" }    #OK not used
is(foobar(), "empty", "multi with empty signature");
is(foobar(42), "one", "multi with parameter list");

# multi with some parameters not counting in dispatch (;;) - note that if the
# second parameter is counted as part of the dispatch, then invoking with 2
# ints means they are tied candidates as one isn't narrower than the other.
# (Note Int is narrower than Num - any two types where one is narrower than
# the other will do it, though.)
class T { }
class S is T { }
multi foo(S $a, T $b) { 1 }    #OK not used
multi foo(T $a, S $b) { 2 }    #OK not used
multi bar(S $a;; T $b) { 1 }    #OK not used
multi bar(T $a;; S $b) { 2 }    #OK not used
my $lived = 0;
try { foo(S,S); $lived = 1 }
#?pugs todo 
is($lived, 0, "dispatch tied as expected");
#?niecza skip 'Ambiguous dispatch for &bar'
#?pugs skip 'missing invocant'
is(bar(S,S), 1, "not tied as only first type in the dispatch");

# not allowed to declare anonymous routines with only, multi or proto.
#?niecza todo
eval_dies_ok 'only sub {}', 'anonymous only sub is an error';
eval_dies_ok 'multi sub {}', 'anonymous multi sub is an error';
eval_dies_ok 'proto sub {}', 'anonymous proto sub is an error';
#?niecza todo
eval_dies_ok 'only {}', 'anonymous only is an error';
eval_dies_ok 'multi {}', 'anonymous multi is an error';
eval_dies_ok 'proto {}', 'anonymous proto is an error';
#?niecza todo
eval_dies_ok 'class A { only method {} }', 'anonymous only method is an error';
eval_dies_ok 'class B { multi method {} }', 'anonymous multi method is an error';
eval_dies_ok 'class C { proto method {} }', 'anonymous proto method is an error';

#?pugs skip 'Callable'
ok(&foo ~~ Callable, 'a multi does Callable');
#?niecza todo
#?pugs skip 'parsefail'
ok(~&foo ~~ /foo/,  'a multi stringifies sensibly');

# note - example in ticket [perl #58948] a bit more elaborate
{
    multi sub max($a, $b, $c) {return 9}    #OK not used

    lives_ok { max(1, 2, 3) }, 'use multi method to override builtin lives';
    #?pugs todo
    is eval('max(1, 2, 3)'), 9, 'use multi method to override builtin';
}

# named and slurpy interaction - there have been bugs in the past on this front
{
    multi nsi_1(Int $x, Bool :$flag, *@vals) { "nsi 1" };    #OK not used
    is nsi_1(1),             'nsi 1', 'interaction between named and slurpy (1)';
    is nsi_1(1, 2, 3, 4, 5), 'nsi 1', 'interaction between named and slurpy (2)';

    multi nsi_2(Bool :$baz = Bool::False, *@vals) { "nsi 2" };    #OK not used
    is nsi_2(:baz(Bool::True), 1, 2, 3), 'nsi 2', 'interaction between named and slurpy (3)';
    is nsi_2(1, 2, 3),                   'nsi 2', 'interaction between named and slurpy (4)';
}

# RT #68234
{
    multi rt68234(:$key!) { 'with key' };    #OK not used
    multi rt68234(*%_)    { 'unknown' };    #OK not used
    #?pugs todo
    is rt68234(:key), 'with key', 'can find multi method with key';
    #?pugs skip 'Named argument found where no matched parameter expected'
    is rt68234(:unknown), 'unknown', 'can find multi method with slurpy';
}

# RT #68158
#?pugs skip 'todo flipflops the first test response'
{
    multi rt68158() { 1 }
    multi rt68158(*@x) { 2 }    #OK not used
    is rt68158(),  1, 'non-slurpy wins over slurpy';
    is rt68158(9), 2, 'slurpy called when non-slurpy can not bind';
}

# RT #64922
#?pugs todo
{
    multi rt64922($x, %h?) { 1 }    #OK not used
    multi rt64922(@x) { 2 }    #OK not used
    is rt64922(1),     1, 'optional parameter does not break type-based candidate sorting';
    is rt64922([1,2]), 2, 'optional parameter does not break type-based candidate sorting';
}

# RT #65672
{
    multi rt65672()   { 99 }
    multi rt65672($x) { $x }
    sub rt65672caller( &x ) { &x() }
    is rt65672caller( &rt65672 ), 99, 'multi can be passed as callable';
}

# We had a bug where the multiness leaked into a sub, so we got errors
# about anonymous methods not being allowed to be multi.
#?pugs skip 'parsefail'
{
    multi sub kangaroo() { return method () { self * 2 } }
    my $m = kangaroo();
    is 21.$m(), 42, 'can write anonymous methods inside multi subs';
}


# RT #75136
# a multi declaration should only return the current candidate, not the whole
# set of candidates.
#?pugs skip 'parsefail'
{
    multi sub koala(Int $x) { 42 * $x };

    my $x = multi sub koala(Str $x) { 42 ~ $x }
    is $x.candidates.elems,
        1, 'multi sub declaration returns just the current candidate';
    is $x('moep'), '42moep', 'and that candidate works';
    dies_ok { $x(23) }, '... and does not contain the full multiness';
}

#?pugs emit #
multi with_cap($a) { $a }
#?pugs emit #
multi with_cap($a,$b,|cap) { return with_cap($a + $b, |cap) }
#?pugs skip 'with_cap not found'
is with_cap(1,2,3,4,5,6), 21, 'captures in multi sigs work';

#RT #114886 - order of declaration matters
#?pugs skip 'where'
{
    multi sub fizzbuzz(Int $ where * %% 15) { 'FizzBuzz' };
    multi sub fizzbuzz(Int $ where * %% 5) { 'Buzz' };
    multi sub fizzbuzz(Int $ where * %% 3) { 'Fizz' };
    multi sub fizzbuzz(Int $number) { $number };
    is
        (1,3,5,15).map(&fizzbuzz).join(" "),
        <1 Fizz Buzz FizzBuzz>,
        "ordered multi subs";
}

# RT #68528
#?niecza skip 'Ambiguous call to &rt68528'
#?pugs skip 'unknown'
{
    multi rt68528(:$a!, *%_) { return "first"  };
    multi rt68528(:$b,  *%_) { return "second" };
    is(rt68528(:a, :b), "first", "RT #68528 - first defined wins the tie");
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-multi/type-based.t0000664000175000017500000001723112224265625017734 0ustar  moritzmoritzuse v6;
use Test;
plan 53;

# type based dispatching
#
#L
#L

multi foo (5)          { "Constant"  }
multi foo (Int $bar)   { "Int "  ~ $bar  }
multi foo (Str $bar)   { "Str "  ~ $bar  }
multi foo (Rat $bar)   { "Rat "  ~ $bar  }
multi foo (Bool $bar)  { "Bool " ~ $bar  }
multi foo (Regex $bar) { "Regex " ~ gist(WHAT( $bar )) } # since Rule's don't stringify
multi foo (Sub $bar)   { "Sub " ~ $bar() }
multi foo (@bar) { "Positional " ~ join(', ', @bar) }
multi foo (%bar)  { "Associative " ~ join(', ', %bar.keys.sort) }
multi foo (IO $fh)     { "IO" }   #OK not used
#?niecza emit # foo (Inf) NYI
multi foo (Inf)        { "Inf" }
#?niecza emit # foo (5) NYI
multi foo (NaN)        { "NaN" }

is foo(5), 'Constant', 'dispatched to the constant sub';

is(foo(2), 'Int 2', 'dispatched to the Int sub');
is(foo('test'), 'Str test', 'dispatched to the Str sub');

my $num = '4';
is(foo(1.4), 'Rat 1.4', 'dispatched to the Num sub');
is(foo(1 == 1), 'Bool ' ~ True, 'dispatched to the Bool sub');
is(foo(/a/),'Regex (Regex)','dispatched to the Rule sub');
is(foo(sub { 'baz' }), 'Sub baz', 'dispatched to the Sub sub');

my @array = ('foo', 'bar', 'baz');
is(foo(@array), 'Positional foo, bar, baz', 'dispatched to the Positional sub');

my %hash = ('foo' => 1, 'bar' => 2, 'baz' => 3);
is(foo(%hash), 'Associative bar, baz, foo', 'dispatched to the Associative sub');

#?niecza skip '$*ERR is apparently not IO'
is(foo($*ERR), 'IO', 'dispatched to the IO sub');

#?niecza 2 skip 'We turned these off because of a niecza bug'
is foo(Inf), 'Inf', 'dispatched to the Inf sub';
is foo(NaN), 'NaN', 'dispatched to the NaN sub';

# You're allowed to omit the "sub" when declaring a multi sub.
# L

multi declared_wo_sub (Int $x) { 1 }   #OK not used
multi declared_wo_sub (Str $x) { 2 }   #OK not used
is declared_wo_sub(42),   1, "omitting 'sub' when declaring 'multi sub's works (1)";
is declared_wo_sub("42"), 2, "omitting 'sub' when declaring 'multi sub's works (2)";

# Test for slurpy MMDs
# L
proto mmd(*@) {*}
multi mmd () { 1 }
multi mmd (*$x, *@xs) { 2 }   #OK not used

is(mmd(), 1, 'Slurpy MMD to nullary');
is(mmd(1,2,3), 2, 'Slurpy MMD to listop via args');
is(mmd(1..3), 2, 'Slurpy MMD to listop via list');

#?niecza skip 'two or more Anys error'
{
    my %h = (:a, :c);
    multi sub sigil-t (&code) { 'Callable'      }   #OK not used
    multi sub sigil-t ($any)  { 'Any'           }   #OK not used
    multi sub sigil-t (@ary)  { 'Positional'    }   #OK not used
    multi sub sigil-t (%h)    { 'Associative'   }   #OK not used
    is sigil-t(1),          'Any',      'Sigil-based dispatch (Any)';
    is sigil-t({ $_ }),     'Callable', 'Sigil-based dispatch (Callable)';
    is sigil-t(),    'Positional','Sigil-based dispatch (Arrays)';
    is sigil-t(%h),         'Associative','Sigil-based dispatch (Associative)';

}

#?niecza skip 'GLOBAL::T does not name any package'
{

    class Scissor { }
    class Paper   { }
    class Stone   { }

    multi wins(Scissor $x, Paper   $y) { 1 }   #OK not used
    multi wins(::T     $x, T       $y) { 0 }   #OK not used
    multi wins($x, $y)                { -1 }   #OK not used

    is wins(Scissor.new, Paper.new),   1,  'Basic sanity';
    is wins(Paper.new,   Paper.new),   0,  'multi dispatch with ::T generics';
    is wins(Paper.new,   Scissor.new), -1, 'fallback if there is a ::T variant';

    # RT #114394
    sub p($a, $b) { wins($a, $b) };
    is p(Paper, Paper), 0, 'Type captures and containers mix (RT 114394)';

    multi wins2(Scissor $x, Paper   $y) { 1 }   #OK not used
    multi wins2($x, $y where { $x.WHAT.gist eq $y.WHAT.gist }) { 0 }
    multi wins2($x, $y)                { -1 }   #OK not used
    is wins2(Scissor.new, Paper.new),   1,  'Basic sanity 2';
    is wins2(Paper.new,   Paper.new),   0,  'multi dispatch with faked generics';
    is wins2(Paper.new,   Scissor.new), -1, 'fallback if there is a faked generic';

    # now try again with anonymous parameters (see RT #69798)
    multi wins_anon(Scissor $, Paper   $) { 1  }
    multi wins_anon(Paper   $, Stone   $) { 1  }
    multi wins_anon(Stone   $, Scissor $) { 1  }
    multi wins_anon(::T     $, T       $) { 0  }
    multi wins_anon(        $,         $) { -1 }

    is wins_anon(Scissor, Paper),  1, 'MMD with anonymous parameters (1)';
    is wins_anon(Paper,   Paper),  0, 'MMD with anonymous parameters (2)';
    is wins_anon(Stone,   Paper), -1, 'MMD with anonymous parameters (3)';

}

{
    multi m($x,$y where { $x==$y }) { 0 }
    multi m($x,$y) { 1 }   #OK not used

    is m(2, 3), 1, 'subset types involving mulitple parameters (fallback)';
    is m(1, 1), 0, 'subset types involving mulitple parameters (success)';
}

{
    multi f2 ($)        { 1 }
    multi f2 ($, $)     { 2 }
    multi f2 ($, $, $)  { 3 }
    multi f2 ($, $, @)  { '3+' }
    is f2(3),               1, 'arity-based dispatch to ($)';
    is f2('foo', f2(3)),    2, 'arity-based dispatch to ($, $)';
    is f2('foo', 4, 8),     3, 'arity-based dispatch to ($, $, $)';
    #?niecza skip 'Ambiguous dispatch for &f2'
    is f2('foo', 4, ), '3+', 'arity-based dispatch to ($, $, @)';
}

{
    multi f3 ($ where 0 ) { 1 }
    multi f3 ($x)         { $x + 1 }
    is f3(0), 1, 'can dispatch to "$ where 0"';
    is f3(3), 4, '... and the ordinary dispatch still works';
}

# multi dispatch on typed containers
#?niecza skip 'Ambiguous dispatch for &f4'
{
    multi f4 (Int @a )  { 'Array of Int' }   #OK not used
    multi f4 (Str @a )  { 'Array of Str' }   #OK not used
    multi f4 (Array @a) { 'Array of Array' }   #OK not used
    multi f4 (Int %a)   { 'Hash of Int' }   #OK not used
    multi f4 (Str %a)   { 'Hash of Str' }   #OK not used
    multi f4 (Array %a) { 'Hash of Array' }   #OK not used

    my Int @a = 3, 4;
    my Str @b = ;
    my Array @c = [1, 2], [3, 4];

    my Int %a = a => 1, b => 2;
    my Str %b = :a, :b;
    my Array %c = a => [1, 2], b => [3, 4];

    is f4(%a), 'Hash of Int',    'can dispatch on typed Hash (Int)';
    is f4(%b), 'Hash of Str',    'can dispatch on typed Hash (Str)';
    is f4(%c), 'Hash of Array',  'can dispatch on typed Hash (Array)';

    is f4(@a), 'Array of Int',   'can dispatch on typed Array (Int)';
    is f4(@b), 'Array of Str',   'can dispatch on typed Array (Str)';
    is f4(@c), 'Array of Array', 'can dispatch on typed Array (Array)';
}

# make sure that multi sub dispatch also works if the sub is defined
# in a class (was a Rakudo regression, RT #65674)

#?rakudo skip 'our sub in class'
#?niecza skip 'Two definitions found for symbol ::GLOBAL::A::&a'
{
    class A {
        our multi sub a(Int $x) { 'Int ' ~ $x }
        our multi sub a(Str $x) { 'Str ' ~ $x }
    }

    is A::a(3),     'Int 3',  'multis in classes (1)';
    is A::a('f'),   'Str f',  'multis in classes (2)';
    dies_ok { A::a([4, 5]) }, 'multis in classes (3)';
}

{
    multi x(@a, @b where { @a.elems == @b.elems }) { 1 }
    multi x(@a, @b)                                { 2 }   #OK not used
    is x([1,2],[3,4]), 1, 'where-clause that uses multiple params (1)';
    is x([1],[2,3,4]), 2, 'where-clause that uses multiple params (1)'; 
}

#?niecza skip 'GLOBAL::T does not name any package'
{
    multi y(::T $x, T $y) { 1 }   #OK not used
    multi y($x, $y)       { 2 }   #OK not used
    is y(1, 2), 1, 'generics in multis (+)';
    is y(1, 2.5), 2, 'generics in multis (-)';
}

#?niecza skip 'no native types yet'
{
    # This once wrongly reported a multi-dispatch circularity.
    multi rt107638(int $a) { 'ok' }      #OK not used
    multi rt107638(Str $a where 1) { }   #OK not used
    ok rt107638(1), 'native types and where clauses do not cause spurious circularities';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-multi/unpackability.t0000664000175000017500000000264612224265625020542 0ustar  moritzmoritzuse v6;
use Test;
plan 10;

# L
# L

multi sub foo ([$a])            { return "one" }   #OK not used
multi sub foo ([$a,$b])         { return "two" }   #OK not used
multi sub foo ([$a,$b,$c])      { return "three" }   #OK not used
multi sub foo (*[$a,$b,$c,$d])  { return "four" }   #OK not used

my @a = (1);
my @b = (1,2);
my @c = (1,2,3);
my @d = (1,2,3,4);

is foo(@a), "one", "multi dispatch on array packed with one element";
is foo(@b), "two", "multi dispatch on array packed with two elements";
is foo(@c), "three", "multi dispatch on array packed with three elements";
is foo(@d), "four", "multi dispatch on array packed with four elements";
is foo(1,2,3,4), "four", "multi dispatch on slurpy packed with four elements";

multi sub bar ([$a,$b?])        { return "$a|$b.gist()" }
multi sub bar (*[$a,$b,$c?])     { return "$a+$b+$c" }

is bar(@a), "1|(Any)", "multi dispatch on array packed with one required element + no optional";
is bar(@b), "1|2", "multi dispatch on array packed with one required element + one optional";
is bar(1,2,3), "1+2+3", "multi dispatch on slurpy packed with two required element + one optional";

# RT #76486
{
    multi sub a(@a) { 1 ~ @a }
    multi sub a([]) { 2 ~ [] }
    my @t = 1,2;

    is a([]), '2',    'Multi-dispatch descends into sub signatures (1)';
    is a(@t), '11 2', 'Multi-dispatch descends into sub signatures (2)';

}
rakudo-2013.12/t/spec/S06-multi/value-based.t0000664000175000017500000000330412224265625020063 0ustar  moritzmoritzuse v6;

use Test;

plan 12;

# L
# L

# Simple case.
{
    multi m1("foo") { 1 }
    multi m1("bar") { 2 }

    is m1("foo"), 1,       "literal Str in signature matches value correctly";
    is m1("bar"), 2,       "literal Str in signature matches value correctly";
    dies_ok { m1("baz") }, "dies if no matching value even if type matches";
}

# More complex case. Here we check that the multis get the right narrowness,
# based upon the type of the literal, and are narrower than a candidate of
# the same type because they have constraints.
{
    multi m2(1)      { "a" }
    multi m2(2)      { "b" }
    multi m2(Int $x) { "c" }   #OK not used
    multi m2($x)     { "d" }   #OK not used

    is m2(1),   "a", 'literal Int in signature matches value correctly';
    is m2(2),   "b", 'literal Int in signature matches value correctly';
    is m2(3),   "c", 'fallback to Int variant which is less narrow than constrained one';
    is m2("x"), "d", 'if not an Int at all, fall back to Any candidate';
}

# RT #88562
{
    multi m3(0     ,     $       ) { 'a' };
    multi m3(Int $n, Str $a = 'A') { 'b' };  #OK not used

    is m3(2, 'A'), 'b', 'literal Int, anonymous parameters and default values mix';
}

{
    multi sub foo(0, $)               { 'B' };
    multi sub foo(Int $n, Str $a="A") { $a };  #OK not used
    is foo(2,"A"), 'A', 'Literals and optionals mix';
}

# not quite a multi, but also value based
# RT #107348

{
    sub f(True) { 'a' }
    is f(True), 'a', 'can call a sub f(True)  with True as argument';
    is f(False), 'a', 'works with False too, since False ~~ True';
    dies_ok { eval 'f(1)' }, 'type constraint is still Bool';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-operator-overloading/imported-subs.t0000664000175000017500000000366512224265625023512 0ustar  moritzmoritzuse v6;
use Test;

plan 19;

BEGIN { @*INC.push: 't/spec/packages' };

{
    # defined in t/spec/packages/Exportops.pm
    use Exportops;

    # note that eval_dies_ok executes in the context of
    # Test.pm, and Test.pm doesn't import or lift the operators

    ok eval('5!'), 'postfix: was exported...';
    ok eval('5! == 120 or die'), '... and it works';
    eval_dies_ok '5!', 'Test.pm does not import the operators';

    ok eval('"a" yadayada "b"'), 'infix: was exported';
    ok eval('"a" yadayada "b" eq "a..b" or die'), '... and it works';
    #?pugs todo
    ok eval('my $a = "a"; $a yadayada= "b"; $a eq "a..b" or die'), '... and yadayada= works too';

    ok eval('¢"foo"'), 'imported Unicode prefix operator';
    ok eval('¢4 eq "4 cent" or die '), '... and it works';

    ok eval('3 ± 4'), 'infix:<±> was exported';
    #?pugs todo
    ok eval('(3 ± 4).isa(Range) or die'), '... and it works';

    is eval("(NotANumber.new(:number(4)) NAN+ NotANumber.new(:number(-1))).number"), 3, "infix: was exported";
    is eval("(NotANumber.new(:number(4)) + NotANumber.new(:number(-1))).number"), 3, "multi infix:<+> was exported and is visible";
    
    #?pugs todo
    is eval('my $a = NotANumber.new(:number(4)); $a NAN+= NotANumber.new(:number(-1)); $a.number;'), 3, "NAN+= works too";
    is eval('my $a = NotANumber.new(:number(4)); $a += NotANumber.new(:number(-1)); $a.number;'), 3, "+= works too";
    
    is 4 + 2, 6, "Normal infix:<+> still works";

    #?pugs todo
    dies_ok { eval('3 notthere 4') }, 'not-exported operator was not imported';

    {
        #?pugs emit #
        my $fail = try eval q{3 notthere 4};
        #?pugs skip 'eek'
        ok $! ~~ X::Syntax::Confused, 'not imported operator fails with X::Syntax::Confused.';
        #?pugs skip 'eek'
        is $!.reason, "Two terms in a row", 'the reason is "Two terms in a row"';
    }
}

eval_dies_ok '5!', 'import of operators is lexical';

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-operator-overloading/methods.t0000664000175000017500000000150212224265625022344 0ustar  moritzmoritzuse Test;
BEGIN { @*INC.push: 't/spec/packages' };
use Test::Util;
plan 3;

# tests related to postcircumfix:<{ }> and other stuff

class A {
    has %!attrs;
    method postcircumfix:<{ }>($key) { %!attrs{$key} }
};

# RT #69612
#?rakudo todo 'nom regression'
#?niecza todo
is A.new(:attrs({ foo => "bar" })),
    'bar', 'custom postcircumfix{ } is tied to the right class';

# RT #70922
#?niecza todo "I think niecza may be doing this correctly, but it's hidden in other warnings"
is_run 'class A { method postcircumfix:<{ }>() {} }; my &r = {
my $a }; if 0 { if 0 { my $a } }',
   {status => 0, err => '' },
   'custom postcircumfix{ } does not lead to warnings';

# RT #69438
eval_lives_ok q[
class B {
method postcircumfix:<{ }>($table) {
}
}

{
1;
}
], 'custom postcircumfix{ } with weird whitespacing does not require ;';
rakudo-2013.12/t/spec/S06-operator-overloading/semicolon.t0000664000175000017500000000052412224265625022674 0ustar  moritzmoritzuse v6;
use Test;
plan 3;

# RT #88704
# A user-declared infix:<;> clashes with statement stopper ';' in Rakudo

my $marker = 0;

sub infix:<;>($a, $b) { 
 $marker = 1;
 0, 0
}; 

my @a = 1; 2; 3; 


is +@a, 1, '@a is array with 1 element';
is @a[0], 1, 'first element of @a eq 1';
is $marker, 0, 'overloaded infix ; hasn\'t been called';

rakudo-2013.12/t/spec/S06-operator-overloading/sub.t0000664000175000017500000003105412224265625021477 0ustar  moritzmoritzuse v6;

use Test;

plan 70;

=begin pod

Testing operator overloading subroutines

=end pod

# L

# This set of tests is very basic for now.
# TODO: all variants of overloading syntax (see spec "So any of these")

{
    sub prefix: ($thing) { return "ROUGHLY$thing"; };

    is(X "fish", "ROUGHLYfish",
       'prefix operator overloading for new operator');
}



{
    sub prefix:<±> ($thing) { return "AROUND$thing"; };
    is ± "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, latin-1 range)';
    sub prefix:<(+-)> ($thing) { return "ABOUT$thing"; };
    #?pugs todo 'bug'
    is eval(q[ (+-) "fish" ]), "ABOUTfish", 'prefix operator overloading for new operator (nasty)';
}

{
    sub prefix:<∔> ($thing) { return "AROUND$thing"; };
    is ∔ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, U+2214 DOT PLUS)';
}

#?rakudo skip 'prefix:[] form not implemented'
{
    sub prefix:['Z'] ($thing) { return "ROUGHLY$thing"; };

    is(Z "fish", "ROUGHLYfish",
       'prefix operator overloading for new operator Z');
}

#?rakudo skip 'prefix:[] form not implemented'
{
    sub prefix:["∓"] ($thing) { return "AROUND$thing"; };
    is ∓ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, U+2213 MINUS-OR-PLUS SIGN)';
}

#?rakudo skip 'prefix:[] form not implemented'
{
    sub prefix:["\x[2213]"] ($thing) { return "AROUND$thing"; };
    is ∓ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, \x[2213] MINUS-OR-PLUS SIGN)';
}

#?rakudo skip 'prefix:[] form not implemented'
{
    sub prefix:["\c[MINUS-OR-PLUS SIGN]"] ($thing) { return "AROUND$thing"; };
    is ∓ "fish", "AROUNDfish", 'prefix operator overloading for new operator (unicode, \c[MINUS-OR-PLUS SIGN])';
}

{
    my sub prefix:<->($thing) { return "CROSS$thing"; };
    is(-"fish", "CROSSfish",
	 'prefix operator overloading for existing operator (but only lexically so we don\'t mess up runtime internals (needed at least for PIL2JS, probably for PIL-Run, too)');
}

{
    sub infix:<×> ($a, $b) { $a * $b }
    is(5 × 3, 15, "infix Unicode operator");
}

{
    sub infix: ($text, $owner) { return "$text copyright $owner"; };
    is "romeo & juliet" C "Shakespeare", "romeo & juliet copyright Shakespeare",
	'infix operator overloading for new operator';
}

{
    sub infix:<©> ($text, $owner) { return "$text Copyright $owner"; };
    is "romeo & juliet" © "Shakespeare", "romeo & juliet Copyright Shakespeare",
	'infix operator overloading for new operator (unicode)';
}

{
    sub infix:<(C)> ($text, $owner) { return "$text CopyRight $owner"; };
    #?pugs todo 'bug'
    is eval(q[ "romeo & juliet" (C) "Shakespeare" ]), "romeo & juliet CopyRight Shakespeare",
	'infix operator overloading for new operator (nasty)';
}

{
    sub infix:«_<_ »($one, $two) { return 42 }   #OK not used
    is 3 _<_ 5, 42, "frenchquoted infix sub";
}

# unfreak perl6.vim:  >>

{
    sub postfix: ($wobble) { return "ANDANDAND$wobble"; };

    is("boop"W, "ANDANDANDboop",
       'postfix operator overloading for new operator');
}

{
    sub postfix:<&&&&&> ($wobble) { return "ANDANDANDANDAND$wobble"; };
    is("boop"&&&&&, "ANDANDANDANDANDboop",
       "postfix operator overloading for new operator (weird)");
}

#?rakudo skip 'macros'
#?niecza skip 'Unhandled exception: Malformed block at (eval) line 1'
{
    my $var = 0;
    #?pugs 2 todo 'feature'
    ok(eval('macro circumfix:[""] ($text) is parsed / .*? / { "" }; ; $var == 0;'), 'circumfix macro {"",""}');
    ok(eval('macro circumfix:«» ($text) is parsed / .*? / { "" }; ; $var == 0;'), 'circumfix macro «»');
}

# demonstrate sum prefix

{
    my sub prefix:<Σ> (@x) { [+] @x }
    is(Σ [1..10], 55, "sum prefix operator");
}

# check that the correct overloaded method is called
{
    multi postfix: ($x) { [*] 1..$x }
    multi postfix: (Str $x) { return($x.uc ~ "!!!") }

    is(10!, 3628800, "factorial postfix operator");
    is("bumbershoot"!, "BUMBERSHOOT!!!", "correct overloaded method called");
}

# Overloading by setting the appropriate code variable
#?rakudo skip "cannot bind with this LHS"
{
  my &infix:;
  BEGIN {
    &infix: := { $^a + $^b };
  }

  is 3 plus 5, 8, 'overloading an operator using "my &infix:<...>" worked';
}

# Overloading by setting the appropriate code variable using symbolic
# dereferentiation
#?rakudo skip '&::'
#?niecza skip 'Cannot use hash access on an object of type Array'
{
  my &infix:;
  BEGIN {
    &::["infix:"] := { $^a * $^b };
  }

  is 3 times 5, 15, 'operator overloading using symbolic dereferentiation';
}

# Accessing an operator using its subroutine name
{
  is &infix:<+>(2, 3), 5, "accessing a builtin operator using its subroutine name";

  my &infix: := { $^a + $^b };
  is &infix:(2, 3), 5, "accessing a userdefined operator using its subroutine name";

  #?rakudo skip 'undeclared name'
  #?niecza skip 'Undeclared routine'
  is ~(&infix:<»+«>([1,2,3],[4,5,6])), "5 7 9", "accessing a hyperoperator using its subroutine name";
}

# Overriding infix:<;>
#?rakudo todo 'infix:<;>'
#?niecza todo
{
    my proto infix:<;> ($a, $b) { $a + $b }
    is (3 ; 2), 5  # XXX correct?
}

# [NOTE]
# pmichaud ruled that prefix:<;> and postfix:<;> shouldn't be defined by
# the synopses:
#   http://colabti.de/irclogger/irclogger_log/perl6?date=2006-07-29,Sat&sel=189#l299
# so we won't test them here.

# Overriding prefix:
# L would hide statement_modifier:">
#?rakudo skip 'missing block, apparently "if" not an op'
{
    my proto prefix: ($a) { $a*2 }
    is (if+5), 10;
}

# [NOTE]
# pmichaud ruled that infix is incorrect:
#   http://colabti.de/irclogger/irclogger_log/perl6?date=2006-07-29,Sat&sel=183#l292
# so we won't test it here either.

# great.  Now, what about those silent auto-conversion operators a la:
# multi sub prefix:<+> (Str $x) returns Num { ... }
# ?

# I mean, + is all well and good for number classes.  But what about
# defining other conversions that may happen?

# here is one that co-erces a MyClass into a Str and a Num.
#?niecza skip 'import NYI'
{
    class OtherClass {
      has $.x is rw;
    }

    class MyClass {
      method prefix:<~> is export { "hi" }
      method prefix:<+> is export { 42   }
      method infix:($self: OtherClass $to) is export {   #OK not used
        my $obj = $to.new;
        $obj.x = 23;
        return $obj;
      }
    }
    import MyClass;  # should import that sub forms of the exports

  my $obj;
  lives_ok { $obj = MyClass.new }, "instantiation of a prefix:<...> and infix: overloading class worked";
  lives_ok { ~$obj }, "our object can be stringified";
  is ~$obj, "hi", "our object was stringified correctly";
  #?pugs todo 'feature'
  is eval('($obj as OtherClass).x'), 23, "our object was coerced correctly";
}

#?rakudo skip 'infix Z will never work; no lexical Z'
{
  my sub infix: ($a, $b) {
      $a ** $b;
  }
  is (2 Z 1 Z 2), 4, "default Left-associative works.";
}

#?rakudo skip 'missing block, no lexical Z'
{
  my sub infix: is assoc('left') ($a, $b) {
      $a ** $b;
  }

  is (2 Z 1 Z 2), 4, "Left-associative works.";
}

#?rakudo skip 'missing block, no lexical Z'
{
  my sub infix: is assoc('right') ($a, $b) {
      $a ** $b;
  }

  is (2 Z 1 Z 2), 2, "Right-associative works.";
}

#?rakudo skip 'missing block, no lexical Z'
{
  my sub infix: is assoc('chain') ($a, $b) {
      $a eq $b;
  }


  is (1 Z 1 Z 1), Bool::True, "Chain-associative works.";
  is (1 Z 1 Z 2), Bool::False, "Chain-associative works.";
}

#?rakudo skip 'assoc("non")'
{
  sub infix: is assoc('non') ($a, $b) {
      $a ** $b;
  }
  is (2 our_non_assoc_infix 3), (2 ** 3), "Non-associative works for just tow operands.";
  is ((2 our_non_assoc_infix 2) our_non_assoc_infix 3), (2 ** 2) ** 3, "Non-associative works when used with parens.";
  eval_dies_ok '2 our_non_assoc_infix 3 our_non_assoc_infix 4', "Non-associative should not parsed when used chainly.";
}

#?niecza skip "roles NYI"
{
    role A { has $.v }
    multi sub infix:<==>(A $a, A $b) { $a.v == $b.v }
    lives_ok { 3 == 3 or  die() }, 'old == still works on integers (+)';
    lives_ok { 3 == 4 and die() }, 'old == still works on integers (-)';
    ok  (A.new(v => 3) == A.new(v => 3)), 'infix:<==> on A objects works (+)';
    ok !(A.new(v => 2) == A.new(v => 3)), 'infix:<==> on A objects works (-)';
}

{
    sub circumfix:<<` `>>(*@args) { @args.join('-') }
    is `3, 4, "f"`, '3-4-f', 'slurpy circumfix:<<...>> works';
    is ` 3, 4, "f" `, '3-4-f', 'slurpy circumfix:<<...>> works, allows spaces';

    sub circumfix:<⌊ ⌋>($e) { $e.floor }
    is ⌊pi⌋, 3, 'circumfix with non-Latin1 bracketing characters';
    is ⌊ pi ⌋, 3, 'circumfix with non-Latin1 bracketing characters, allows spaces';
}

{
    multi sub infix:<+=> (Int $a is rw, Int $b) { $a -= $b }
    my $frew = 10;
    $frew += 5;
    is $frew, 5, 'infix redefinition of += works';
}

{
    class MMDTestType {
        has $.a is rw;
        method add(MMDTestType $b) { $.a ~ $b.a }
    }

    multi sub infix:<+>(MMDTestType $a, MMDTestType $b) { $a.add($b) };

    my MMDTestType $a .= new(a=>'foo');
    my MMDTestType $b .= new(a=>'bar');

    is $a + $b, 'foobar', 'can overload exiting operators (here: infix:<+>)';
}

# test that multis with other arity don't interfere with existing ones
# used to be RT #65640
#?niecza skip 'No matching candidates to dispatch for &infix:<+>'
{
    multi sub infix:<+>() { 42 };
    ok 5 + 5 == 10, "New multis don't disturb old ones";
}

# taken from S06-operator-overloading/method.t
{
    class Bar {
        has $.bar is rw;
    }

    multi sub prefix:<~> (Bar $self)      { return $self.bar }
    multi sub infix:<+>  (Bar $a, Bar $b) { return "$a $b" }

    {
        my $val;
        lives_ok {
            my $foo = Bar.new();
            $foo.bar = 'software';
            $val = "$foo"
        }, '... class methods work for class';
        #?rakudo todo 'huh?'
        is($val, 'software', '... basic prefix operator overloading worked');

        lives_ok {
            my $foo = Bar.new();
            $foo.bar = 'software';
            $val = $foo + $foo;
        }, '... class methods work for class';
        #?rakudo todo 'huh?'
        #?niecza todo '... basic infix operator overloading worked'
        is($val, 'software software', '... basic infix operator overloading worked');
    }

# Test that the object is correctly stringified when it is in an array.
# And test that »...« automagically work, too.
    {
        my $obj;
        lives_ok {
        $obj     = Bar.new;
        $obj.bar = "pugs";
        }, "instantiating a class which defines operators worked";

        my @foo = ($obj, $obj, $obj);
        my $res;
        #?niecza todo "stringification didn't die"
        lives_ok { $res = ~@foo }, "stringification didn't die";
        #?niecza todo "... worked in array stringification"
        #?rakudo 3 todo 'huh?'
        is $res, "pugs pugs pugs", "stringification overloading worked in array stringification";
        #?niecza todo "... with hyperization"
        lives_ok { $res = ~[@foo »~« "!"] }, "stringification with hyperization didn't die";
        #?niecza todo "... was hyperized"
        is $res, "pugs! pugs! pugs!", "stringification overloading was hyperized correctly";
    }


}

# RT #65638
{
    is eval('sub infix:<,>($a, $b) { 42 }; 5, 5'), 42, 'infix:<,>($a, $b)';
    is eval('sub infix:<,>(Int $x where 1, Int $y where 1) { 42 }; 1, 1'), 42,
       'very specific infix:<,>';
    #?rakudo todo 'RT 65638'
    #?niecza todo
    is eval('sub infix:<#>($a, $b) { 42 }; 5 # 5'), 42, 'infix:($a, $b)';
    is eval('multi sub infix:<+>() { 42 }; 5 + 5'), 10, 'infix:<+>()';
    is eval('sub infix:<+>($a, $b) { 42 }; 5 + 5'), 42, 'infix:<+>($a, $b)';
}

#?rakudo skip 'not yet implemented'
{
    multi sub infix:($a, $b) {$a + $b};

    my $x foo=6;
    is $x, 6, 'foo= works for custom operators';
}

#?rakudo skip 'not yet implemented'
{
    our sub infix:($a, $b) {$a + $b};

    my $x bar=6;
    is $x, 6, 'bar= works for custom operators';

}

# RT #74104
#?niecza skip 'No matching candidates to dispatch for &infix:<+>'
{
    class RT74104 {}
    multi sub infix:<+>(RT74104 $, RT74104 $) { -1 }
    is 2+2, 4, 'overloading an operator does not hide other candidates';
}

# RT #111418
# RT #112870
{
    sub infix:<*+>($a, $b) { $a * $b + $b }
    is 2 *+ 5, 15, 'longest operator wins (RT 111418)';
    sub infix:<~eq>(Str $a, Str $b) { uc($a) eq uc($b) }
    ok 'a' ~eq 'A', 'longest operator wins (RT 112870)';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-operator-overloading/workout.t0000664000175000017500000002520512224265625022421 0ustar  moritzmoritzuse v6;

use Test;


=begin pod

Testing operator overloading subroutines

=end pod

class Vector {
    has @.coords;
    multi method new (*@x where { @x.elems == 3 }) { self.bless(coords => @x); }
    multi method new (@x where { @x.elems == 3 }) { self.bless(coords => @x); }
    multi method abs() is export { sqrt([+](self.coords »*« self.coords)); }
    multi method Num() { die "Can't get Num from Vector"; }
}

# operators prefixed by T used the Texas version of their internal operators

multi sub infix:<+>(Vector $a, Vector $b) { Vector.new($a.coords »+« $b.coords); }
multi sub infix:(Vector $a, Vector $b) { Vector.new($a.coords >>+<< $b.coords); }
multi sub infix:<->(Vector $a, Vector $b) { Vector.new($a.coords »-« $b.coords); }
multi sub infix:(Vector $a, Vector $b) { Vector.new($a.coords >>-<< $b.coords); }
multi sub prefix:<->(Vector $a) { Vector.new(0 «-« $a.coords); }
multi sub prefix:(Vector $a) { Vector.new(0 <<-<< $a.coords); }
multi sub infix:<*>(Vector $a, $b) { Vector.new($a.coords »*» $b); }
multi sub infix:(Vector $a, $b) { Vector.new($a.coords >>*>> $b); }
multi sub infix:<*>($a, Vector $b) { Vector.new($a «*« $b.coords); }
multi sub infix:($a, Vector $b) { Vector.new($a <<*<< $b.coords); }
multi sub infix:(Vector $a, $b) { Vector.new($a.coords »/» $b); }
multi sub infix:(Vector $a, $b) { Vector.new($a.coords >>/>> $b); }
multi sub infix:<**>(Vector $a, $b) { Vector.new($a.coords »**» $b); }
multi sub infix:(Vector $a, $b) { Vector.new($a.coords >>**>> $b); }
multi sub infix:<⋅>(Vector $a, Vector $b) { [+]($a.coords »*« $b.coords); }
multi sub infix:(Vector $a, Vector $b) { [+]($a.coords >>*<< $b.coords); }

### note the is_approx from Test.pm doesn't lift infix:<-> and abs,
# so we can't expect it work with class Vector. Thus we re-make one that does
# the custom ops

sub ia($got, $expected, $descr =  "$got is approximately $expected") {
    my $tol = $expected.abs < 1e-6 ?? 1e-5 !! $expected.abs * 1e-6;
    my $test = ($got - $expected).abs <= $tol;
    ok(?$test, $descr);
    unless $test {
        diag("got:      $got");
        diag("expected: $expected");
    }
    ?$test;
}

# a few Vector sanity tests, verifying we can use is_approx for Vectors
# Note that this assumes that is_approx (1) lifts its operators (See S04)
# and (2) uses the method form of abs(), or lifts abs() too.
# Needs more discussion and spec coverage.
{
    isa_ok(Vector.new(1, 2, 3), Vector, "Vector.new produces a Vector object");
    my @a1 = (3, -3/2, 5.4);
    isa_ok(Vector.new(@a1), Vector, "Vector.new produces a Vector object");
    dies_ok({ Vector.new(1, 2, 3, 4) }, "Vector.new requires 3 parameters");
    my @a2 = (-3/2, 5.4);
    dies_ok({ Vector.new(@a2) }, "Vector.new requires an array with 3 members");

    my Vector $v1 = Vector.new(@a1);
    is($v1.coords[0], @a1[0], 'Constructor correctly assigns @coords[0]');
    is($v1.coords[1], @a1[1], 'Constructor correctly assigns @coords[1]');
    is($v1.coords[2], @a1[2], 'Constructor correctly assigns @coords[2]');
    my Vector $v2 = Vector.new(0.1, 1/5, 0.3);
    my Vector $v3 = $v1 - $v2;
    is($v3.coords[0], $v1.coords[0] - $v2.coords[0], 'Subtraction correct for @coords[0]');
    is($v3.coords[1], $v1.coords[1] - $v2.coords[1], 'Subtraction correct for @coords[1]');
    is($v3.coords[2], $v1.coords[2] - $v2.coords[2], 'Subtraction correct for @coords[2]');
    ok($v1.abs > 5, "$v1.abs is of appropriate size");
    ia($v1.abs, sqrt([+] (@a1 <<*>> @a1)), "v1.abs returns correct value");

    ia($v1, $v1, "v1 is approximately equal to itself");
    ia(Vector.new(0, 1, 0), Vector.new(0, .99999999, 0), "Different but very close Vectors");
    ok((Vector.new(1, 0, 0) - Vector.new(0, 1, 0)).abs > 1e-5,
       "Vectors of same size but different direction are not approximately equal");
}

my Vector $v1 = Vector.new(-1/2, 2, 34);
my Vector $v2 = Vector.new(1.0, 1/5, 0.3);

# basic operations
ia($v1 + $v2, Vector.new(0.5, 2.2, 34.3), "Addition correct");
ia(-$v1, Vector.new(1/2, -2, -34), "Negation correct");
ia((3/2) * $v1, Vector.new(-3/4, 3, 17*3), "Scalar multiply correct");
ia($v1 * (3/2), Vector.new(-3/4, 3, 17*3), "Scalar multiply correct");
ia($v1 / (2/3), Vector.new(-3/4, 3, 17*3), "Scalar division correct");
ia($v1 ** 2, Vector.new(1/4, 4, 34*34), "Scalar power correct");
ia($v1 ⋅ $v2, -1/2 + 2/5 + 34 * 0.3, "⋅ product correct");

# Texas versions of basic operations
ia($v1 T+ $v2, $v1 + $v2, "T Addition correct");
ia($v1 T- $v2, $v1 - $v2, "T Subtraction correct");
ia(T-$v1, Vector.new(1/2, -2, -34), "T Negation correct");
ia((3/2) T* $v1, Vector.new(-3/4, 3, 17*3), "T Scalar multiply correct");
ia($v1 T* (3/2), Vector.new(-3/4, 3, 17*3), "T Scalar multiply correct");
ia($v1 T/ (2/3), Vector.new(-3/4, 3, 17*3), "T Scalar division correct");
ia($v1 T** 2, Vector.new(1/4, 4, 34*34), "T Scalar power correct");
ia($v1 dot $v2, -1/2 + 2/5 + 34 * 0.3, "dot product correct");

# equals versions
{
    my $v = $v1;
    $v += $v2;
    ia($v, $v1 + $v2, "+= works");
}

{
    my $v = $v1;
    $v -= $v2;
    ia($v, $v1 - $v2, "-= works");
}

{
    my $v = 3/2;
    $v *= $v1;
    ia($v, (3/2) * $v1, "*= works starting with scalar");
}

{
    my $v = $v1;
    $v /= (2/3);
    ia($v, (3/2) * $v1, "/= works");
}

{
    my $v = $v1;
    $v **= 3;
    ia($v, $v1 ** 3, "**= works");
}

{
    my $v = $v1;
    $v ⋅= $v2;
    ia($v, $v1 ⋅ $v2, "⋅= works");
}

{
    my $v = $v1;
    $v T+= $v2;
    ia($v, $v1 T+ $v2, "T+= works");
}

{
    my $v = $v1;
    $v T-= $v2;
    ia($v, $v1 - $v2, "T-= works");
}

{
    my $v = 3/2;
    $v T*= $v1;
    ia($v, (3/2) T* $v1, "T*= works starting with scalar");
}

{
    my $v = $v1;
    $v T/= (2/3);
    ia($v, (3/2) T* $v1, "T/= works");
}

{
    my $v = $v1;
    $v T**= 3;
    ia($v, $v1 T** 3, "T**= works");
}

{
    my $v = $v1;
    $v dot= $v2;
    ia($v, $v1 dot $v2, "dot= works");
}


# reversed versions
ia($v1 R+ $v2, Vector.new(0.5, 2.2, 34.3), "R Addition correct");
ia($v2 R- $v1, $v1 - $v2, "R Subtraction correct");
ia((3/2) R* $v1, Vector.new(-3/4, 3, 17*3), "R Scalar multiply correct");
ia($v1 R* (3/2), Vector.new(-3/4, 3, 17*3), "R Scalar multiply correct");
ia((2/3) R/ $v1, Vector.new(-3/4, 3, 17*3), "R Scalar division correct");
ia(2 R** $v1, Vector.new(1/4, 4, 34*34), "R Scalar power correct");
ia($v1 R⋅ $v2, -1/2 + 2/5 + 34 * 0.3, "R Dot product correct");

ia($v1 RT+ $v2, $v1 + $v2, "R T Addition correct");
ia($v2 RT- $v1, $v1 - $v2, "R T Subtraction correct");
ia((3/2) RT* $v1, Vector.new(-3/4, 3, 17*3), "R T Scalar multiply correct");
ia($v1 RT* (3/2), Vector.new(-3/4, 3, 17*3), "R T Scalar multiply correct");
ia((2/3) RT/ $v1, Vector.new(-3/4, 3, 17*3), "R T Scalar division correct");
ia(2 RT** $v1, Vector.new(1/4, 4, 34*34), "R T Scalar power correct");
ia($v1 Rdot $v2, -1/2 + 2/5 + 34 * 0.3, "R Dot product correct");

#?DOES 1
multi sub is_approx_array(@got, @expected, $desc) {
    my $test = all((@got >>-<< @expected)>>.abs.map({$_ <= 0.00001}));
    ok(?$test, $desc);
}

#?DOES 1
multi sub isnt_approx_array(@got, @expected, $desc) {
    my $test = all((@got >>-<< @expected)>>.abs.map({$_ <= 0.00001}));
    ok(!$test, $desc);
}

my @vectors = ($v1, $v2, $v1 + $v2, $v1 - $v2, $v2 - $v1);

# Bad news error: the next four tests can all be made to work, just not at the same time.
# If you delete the skip line, the [T+] test works but the [-] test returns the "Can't get 
# Num from Vector" error.  If you include skip line, the [-] test works.  Help?

ia(([+] @vectors), (2 T* $v1) + (2 T* $v2), "[+] of vectors == 2 * (v1 + v2)");
ia(([T+] @vectors), (2 T* $v1) + (2 T* $v2), "[T+] of vectors == 2 * (v1 + v2)");
ia(([-] @vectors), -2 T* $v2, "[-] of vectors == -2 * v2");
ia(([T-] @vectors), -2 T* $v2, "[T-] of vectors == -2 * v2");

is_approx_array(@vectors >>*>> 2, @vectors >>+<< @vectors, "Hyper: doubling equals self + self");
isnt_approx_array(@vectors >>*>> 2, @vectors, "Hyper: doubling does not equal self");
is_approx_array((@vectors >>*>> 2) >>*>> 2, (@vectors >>+<< @vectors) >>+<< (@vectors >>+<< @vectors),
                "Hyper: doubling twice equals self+self+self+self");
is_approx_array(2 <<*<< @vectors, @vectors >>+<< @vectors, "Hyper: doubling equals self + self");
isnt_approx_array(2 <<*<< @vectors, @vectors, "Hyper: doubling does not equal self");
is_approx_array(2 <<*<< (2 <<*<< @vectors), @vectors >>+<< @vectors >>+<< @vectors >>+<< @vectors,
                "Hyper: doubling twice equals self+self+self+self");
is_approx_array(2 <<*<< (2 <<*<< @vectors), (@vectors >>+<< @vectors) >>T+<< (@vectors >>+<< @vectors),
                "Hyper: doubling twice equals self+self+self+self");
is_approx_array(2 <<*<< (2 <<*<< @vectors), (@vectors >>T+<< @vectors) >>T+<< (@vectors >>T+<< @vectors),
                "Hyper: doubling twice equals self+self+self+self");
is_approx_array(2 <<*<< (2 <<*<< @vectors), (@vectors >>T+<< @vectors) >>+<< (@vectors >>T+<< @vectors),
                "Hyper: doubling twice equals self+self+self+self");

is_approx_array(@vectors »*» 2, @vectors »+« @vectors, "Hyper: doubling equals self + self");
isnt_approx_array(@vectors »*» 2, @vectors, "Hyper: doubling does not equal self");
is_approx_array((@vectors »*» 2) »*» 2, (@vectors »+« @vectors) »+« (@vectors »+« @vectors),
                "Hyper: doubling twice equals self+self+self+self");
is_approx_array(2 «*« @vectors, @vectors »+« @vectors, "Hyper: doubling equals self + self");
isnt_approx_array(2 «*« @vectors, @vectors, "Hyper: doubling does not equal self");
is_approx_array(2 «*« (2 «*« @vectors), @vectors »+« @vectors »+« @vectors »+« @vectors,
                "Hyper: doubling twice equals self+self+self+self");

is_approx_array((@vectors »⋅« @vectors)».sqrt, @vectors».abs, "Hyper sqrt of hyper dot equals hyper length");
is_approx_array((@vectors >>⋅<< @vectors)».sqrt, @vectors».abs, "Hyper sqrt of hyper dot equals hyper length");
is_approx_array((@vectors >>⋅<< @vectors)>>.sqrt, @vectors>>.abs, "Hyper sqrt of hyper dot equals hyper length");

is_approx_array((@vectors »dot« @vectors)».sqrt, @vectors».abs, "Hyper sqrt of hyper dot equals hyper length");
is_approx_array((@vectors >>dot<< @vectors)>>.sqrt, @vectors>>.abs, "Hyper sqrt of hyper dot equals hyper length");

is_approx_array(((3/2) <<*<< @vectors) >>-<< @vectors , @vectors >>/>> 2,
                "Hyper: 3/2 v - v equals v / 2");
is_approx_array(((3/2) <<*<< @vectors) »-« @vectors , @vectors >>/>> 2,
                "Hyper: 3/2 v - v equals v / 2");
is_approx_array(((3/2) <<*<< @vectors) >>T-<< @vectors , @vectors >>/>> 2,
                "Hyper: 3/2 v - v equals v / 2");
is_approx_array(((3/2) <<*<< @vectors) »T-« @vectors , @vectors >>/>> 2,
                "Hyper: 3/2 v - v equals v / 2");

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-other/anon-hashes-vs-blocks.t0000664000175000017500000000432412224265625021772 0ustar  moritzmoritzuse v6;

use Test;

# L

plan 22;

my $hash = {
   '1' => { '2' => 3, '4' => 5 },
};


is( $hash<1><2>, '3', 'First nested element.');
is( $hash<1><4>, '5', 'Second nested element.');

my $h2 = {
   x => [2,3]
};
is( $h2[0], '2', 'First nested element.');
is( $h2[1], '3', 'Second nested element.');

my %foo = (1 => 2);
my $bar = { %foo };

ok $bar ~~ Hash, '%foo in a block causes hash composing';


# pugs had problems with //= and the hash() contextualizer
{
    my %hash;
    %hash //= hash();
    %hash //= hash;
    my $h_ref;
    $h_ref  //= hash();
    is(%hash.WHAT.gist, ::Hash.gist, "Parses as two items");
    is(%hash.WHAT.gist, ::Hash.gist, "Parens do not help");
    is($h_ref.WHAT.gist,     ::Hash.gist, "It is not limited to hash values");
}

{
    ok {; a => 1 } ~~ Block, '{; ... } is a Block';
    ok {  a => 1 } ~~ Hash,  '{ a => 1} is a Hash';
    #?pugs 4 skip "Missing required parameters"
    ok { $^a => $^b } ~~ Block, 'placeholders force it to be a block';
    ok { $^a => 'b' } ~~ Block, '... as a key';
    ok { a => $^x }   ~~ Block, '... as a value';
    ok { b => 3, a => $^x, 4 => 5 }   ~~ Block, '... somewhere deep inside';
    ok {;} ~~ Block, '{;} is a Block';
}

#?niecza skip "Thinks the block is a hash"
#?pugs   skip "Thinks the block is a hash"
{
    my @foo = ;
    my %hash = map { (state $counter)++ => $_ }, @foo;
    is %hash<0>, 'a', 'state variable declaration certainly makes it a block (1)';
    is %hash<1>, 'b', 'state variable declaration certainly makes it a block (2)';
}

# RT #68298
#?niecza skip "Thinks the block is a hash"
#?pugs   skip "Thinks the block is a hash"
is (map { $_ => $_ * $_ }, 1..3).hash<2>, 4, 'block with $_ is not a hash';

# RT #76896
#?pugs skip "parsefail"
{
    my %fs = ();

    %fs{ lc( 'A' ) } = &fa;
    sub fa() {
        return 'FA';
    }

    %fs{ lc( 'B' ) } = &fb;
    sub fb() {
        return 'FB'
    }

    my $fname = lc( 'A' );
    is('FA', %fs{ $fname }(), "fa has been called");
    is('FA', %fs{ lc( 'A' ) }(), "fa has been called");
    $fname = lc( 'B' );
    is('FB', %fs{ $fname }(), "fb has been called");
    is('FB', %fs{ lc( 'B' ) }(), "fb has been called");
}
done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-other/introspection.t0000664000175000017500000000241712224265625020566 0ustar  moritzmoritzuse v6;

use Test;

plan 12;

# L

# introspecting only subs
only sub only-sub($a, $b) { "only" };   #OK not used

# .candidates
is(&only-sub.candidates.elems,1,"an only subs lists itself in the .candidates");
is(&only-sub.candidates[0].(1,2),"only","an only subs lists itself in the .candidates");

# .cando
is(&only-sub.cando(\(1,2)).elems,1,"an only sub implements .cando");
is(&only-sub.cando(\(1,2)).[0].(1,2),"only","an only sub implements .cando");

# .signature
ok(\(1,2) ~~ &only-sub.signature,"an only sub implements .signature");

# introspecting multi subs
multi sub multi-sub(1,2) { "m1" };
multi sub multi-sub(1)   { "m2" };
multi sub multi-sub()    { "m3" };

# .candidates
is(&multi-sub.candidates.elems,3,"a multi sub returns all its candidates");

# .cando
is(&multi-sub.cando(\(1,2)).[0].(1,2),"m1","you can invoke through introspection");
is(&multi-sub.cando(\(1)).[0].(1),"m2","you can invoke through introspection");
is(&multi-sub.cando(\()).[0].(),"m3","you can invoke through introspection");

# .signature
{
    my $sig = &multi-sub.signature;
    ok(\(1,2) ~~ $sig,"junction sig matches first candidate");
    ok(\(1)   ~~ $sig,"junction sig matches second candidate");
    ok(\()    ~~ $sig, "junction sig matches third candidate");
}
rakudo-2013.12/t/spec/S06-other/main-eval.t0000664000175000017500000000103612224265625017533 0ustar  moritzmoritzuse v6;

use Test;

plan 3;

# L subroutine/"the compilation unit was directly
# invoked rather than by being required by another compilation unit">

# a MAIN sub in eval() shouldn't be called

my $main_invoked = 0;
my $eval_worked = 0;
eval q[
    my @*ARGS = ;
    sub MAIN($a, $b) { $main_invoked = 1 };
    $eval_worked = 1;
];
ok ! $!, 'no exception thrown';
ok $eval_worked, 'eval code executed';
#?rakudo todo 'MAIN in eval'
is $main_invoked, 0, 'sub MAIN is not called in eval()';

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-other/main.t0000664000175000017500000000134112224265625016605 0ustar  moritzmoritzuse v6;

use Test;

plan 6;

## If this test file is fudged, then MAIN never executes because 
## the fudge script introduces an C into the mainline.
## This definition prevents that insertion from having any effect.  :-)
sub exit { }

# L subroutine/>

sub MAIN($a, $b, *@c) {
    ok(1, 'MAIN called correctly');
    is($a, 'a', 'first positional param set correctly');
    is($b, 'b', 'second positional param set correctly');
    is(~@c, 'c d e', 'slurpy param set correctly');
}

@*ARGS = ;

ok( @*ARGS == 5, '@*ARGS has correct elements');

# RT #114354
@*INC.push: 't/spec/packages/';
#?niecza todo
lives_ok { require HasMain }, 'MAIN in a module did not get executed';

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-other/main-usage.t0000664000175000017500000001030012224265625017702 0ustar  moritzmoritzuse v6;
use Test;

plan  22;

BEGIN { @*INC.push: 't/spec/packages' }

use Test::Util;


# Basic functionality

is_run 'sub MAIN($x) { }; sub USAGE() { print "USAGE() called" }',
    {
        out => 'USAGE() called',
    },
    'a user-defined USAGE sub is called if MAIN dispatch fails';

is_run 'sub MAIN() { print "MAIN() called" }; sub USAGE() { print "USAGE() called" }',
    {
        out    => 'MAIN() called',
        status => 0,
    },
    'a user-defined USAGE sub is not called if MAIN dispatch succeeds';

is_run 'sub MAIN( $a = nosuchsub()) { }; sub USAGE { say 42 }',
    {
        out => '',
        err => /nosuchsub/,
    },
    'if the MAIN dispatch results in an error, that error should be printed, not USAGE';

is_run 'sub MAIN($foo) { }',
    {
        err     => /<< foo >>/,
        out     => '',
    },
    'auto-generated USAGE message goes to $*ERR and contains parameter name';

is_run 'sub MAIN($bar) { }',
    {
        out => /<< bar >>/,
    },
    :args['--help'],
    '--help option sends auto-generated USAGE message to $*OUT';

is_run 'sub MAIN(Bool :$x) { say "yes" if $x }',
    {
        out => "yes\n",
        err => '',
        status => 0,
    },
    :args['--x'],
    'boolean option +';

is_run 'sub MAIN(Bool :$x) { print "yes" if $x }',
    {
        out => "",
    },
    :args['--/x'],
    'boolean option -';

is_run 'sub MAIN(:$x) { print $x }',
    {
        out => "23",
    },
    :args['--x=23'],
    'option with value';

is_run 'sub MAIN(:xen(:$xin)) { print $xin }',
    {
        out => "23",
    },
    :args['--xin=23'],
    'named alias (inner name)';

is_run 'sub MAIN(:xen(:$xin)) { print $xin }',
    {
        out => "23",
    },
    :args['--xen=23'],
    'named alias (outer name)';

# RT #71366
is_run 'sub MAIN($a, :$var) { say "a: $a, optional: $var"; }',
    {
        err     => /\-\-var/,
        out     => '',
    },
    :args['param', '--var'],
    'Non Bool option last with no value';

is_run 'sub MAIN($a, Bool :$var) { say "a: $a, optional: $var"; }',
    {
        out     => "a: param, optional: True\n",
    },
    :args['--var', 'param'],
    'Bool option followed by positional value';


# Spacey options may be removed from core spec; for now, moving to end of tests
# (discussion starts at http://irclog.perlgeek.de/perl6/2011-10-17#i_4578353 )

#?rakudo todo 'nom regression'
#?niecza todo 'copied nom regression'
is_run 'sub MAIN(:$x) { print $x }',
    {
        out => "23",
    },
    :args['--x', '23'],
    'option with spacey value';

#?rakudo todo 'nom regression'
#?niecza todo 'copied nom regression'
is_run 'sub MAIN(:xen(:$x)) { print $x }',
    {
        out => "23",
    },
    :args['--xen', '23'],
    'long option with spacey value';

#?rakudo todo 'nom regression'
#?niecza todo 'copied nom regression'
is_run 'sub MAIN(:xen(:$xin)) { print $xin }',
    {
        out => "23",
    },
    :args['--xin', '23'],
    'named alias (inner name) with spacey value';

#?rakudo todo 'nom regression'
#?niecza todo 'copied nom regression'
is_run 'sub MAIN(:xen(:$xin)) { print $xin }',
    {
        out => "23",
    },
    :args['--xen', '23'],
    'named alias (outer name) with spacey value';

#?rakudo todo 'nom regression'
#?niecza todo 'copied nom regression'
is_run 'sub MAIN(:xen(:$x)) { print $x }',
    {
        out => "23",
    },
    :args['-x', '23'],
    'short option with spacey value';

is_run 'subset Command of Str where "run";
multi MAIN(Command $c) { print 1 },
multi MAIN()           { print 2 }',
{ out => "2" };


# RT #92986
is_run 'multi MAIN($) { print q[Any] }; multi MAIN(Str) { print q[Str] }',
    :args['foo'],
    {
        out => 'Str',
    },
    'best multi matches (not just first one)';

is_run 'sub MAIN() { print 42 }', :args['--foo'],
    {
        out => '',
        err => rx:i/usage/,
    },
    'superfluous options trigger usage message';

# RT #115744
#?rakudo todo 'RT 115744'
#?niecza todo
is_run 'sub MAIN($arg) { print $arg }',
    {
        out => "--23"
    },
    :args['--', '--23'],
    'Stopping option processing';

#?rakudo todo 'RT 115744'
#?niecza todo
is_run 'sub MAIN($arg, Bool :$bool) { print $bool, $arg }',
    {
        out => 'True-option'
    },
    :args['--bool', '--', '-option'],
    'Boolean argument with --';
rakudo-2013.12/t/spec/S06-other/misc.t0000664000175000017500000000071512224265625016620 0ustar  moritzmoritzuse v6;

use Test;

plan 3;

#not really much of a test (no links to the spec either). Please improve, I only wrote what was required! --lue

sub a () { my $a=4; }; #zero-arg sub to test the underlying problem   #OK not used

eval_dies_ok 'e("wtz")', "e should not be defined to accept arguments";
eval_dies_ok 'pi("wtz")',"pi should not be defined to accept arguments either :) ";
#?pugs todo
dies_ok { eval('a(3)') }, "this should die, no arguments defined";
rakudo-2013.12/t/spec/S06-other/pairs-as-lvalues.t0000664000175000017500000000072712224265625021060 0ustar  moritzmoritzuse v6;
use Test;

plan 5;

# L

eval_dies_ok 'my $var; (key => $var) = "value"';

{
    my ($a, $b);
    $b = 'b';
    :(:$a) := $b;
    is $a, 'b', 'can bind to single pair';
    ok $a =:= $b, 'variables are bound together (?)';
}

{
    my ($t, $m);
    :(:type($t), :motivation($m)) := (type => 'geek', motivation => '-Ofun');
    is $t, 'geek',  'bound to the first pair';
    is $m, '-Ofun', 'bound ot the second pair';
}




# vim: ft=perl6
rakudo-2013.12/t/spec/S06-routine-modifiers/lvalue-subroutines.t0000664000175000017500000000571612224265625024066 0ustar  moritzmoritzuse v6;

use Test;

plan 14;

=begin description

Testing lvalue-returning subroutines

=end description

# L

# Lvalue subrefs
{
  my $var1 = 1;
  my $var2 = 2;

  my $lastvar = sub () is rw { $var2      };
  my $prevvar = sub () is rw { $lastvar() };

  $lastvar() = 3;
  is $var2, 3, "lvalue subroutine references work (simple)";

  $prevvar() = 4;
  is $var2, 4, "lvalue subroutine references work (nested)";
}

{
  my $var = 42;
  my $notlvalue = sub () { $var };

  #?pugs 2 todo 'bug'
  #?niecza 2 todo 'rw checking'
  dies_ok { $notlvalue() = 23 },
    "assigning to non-rw subrefs should die";
  is $var, 42,
    "assigning to non-rw subrefs shouldn't modify the original variable";
}

  my $var1 = 1;
  my $var2 = 2;

  sub lastvar is rw { $var2; }
  sub prevvar is rw { lastvar(); }

  lastvar() = 3;
  is($var2, 3, "lvalue subroutines work (simple)");

  prevvar() = 4;
  is($var2, 4, "lvalue subroutines work (nested)");

{
  my $var = 42;

  # S6 says that lvalue subroutines are marked out by 'is rw'
  sub notlvalue { $var; } # without rw

  #?niecza 2 todo 'rw checking'
  dies_ok { notlvalue() = 5 },
    "assigning to non-rw subs should die";
  is $var, 42,
    "assigning to non-rw subs shouldn't modify the original variable";
}

sub check ($passwd) { $passwd eq "fish"; };

sub checklastval ($passwd) is rw {
    Proxy.new(
        FETCH => sub ($self) {   #OK not used
                lastvar();
            },
        STORE => sub ($self, $val) {   #OK not used
                die "wrong password" unless check($passwd);
                lastvar() = $val;
            }
        );
};

#?rakudo skip 'hangs, probably due to [RT #114134]'
dies_ok {checklastval("octopus") = 10 }, 'checklastval STORE can die';

# Above test may well die for the wrong reason, if the Proxy stuff didn't
# parse OK, it will complain that it couldn't find the desired subroutine
#?rakudo skip 'maximum recursion depth exceeded'
is((try { checklastval("fish") = 12 }), 12, 'proxy lvalue subroutine STORE works');
#?rakudo emit #
my $resultval = checklastval("fish");
#?rakudo skip 'maximum recursion depth exceeded'
is($resultval, 12, 'proxy lvalue subroutine FETCH works');

my $realvar = "foo";
sub proxyvar ($prefix) is rw {
    Proxy.new(
        FETCH => method ()     { $prefix ~ lc($realvar) },
        STORE => method ($val) { lc($realvar = $val) },
    );
}
is proxyvar("PRE"), 'PREfoo', 'proxy lvalue subroutine FETCH works';
# Return value of assignments of Proxy objects is decided now.
# See thread "Assigning Proxy objects" on p6l,
# L<"http://www.nntp.perl.org/group/perl.perl6.language/21838">.
# Quoting Larry:
#   The intention is that lvalue subs behave in all respects as if they
#   were variables.  So consider what
#   
#       say $nonproxy = 40;
#   
#   should do.
is (proxyvar("PRE") = "BAR"), 'PREbar',
    'proxy lvalue subroutine STORE works and returns the correct value';
#?pugs todo 'feature'
is $realvar, 'BAR', 'variable was modified';

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-routine-modifiers/proxy.t0000664000175000017500000000433212224265625021370 0ustar  moritzmoritzuse v6;

use Test;

# Tests for the Proxy class

# L
# Return value of assignments of Proxy objects is decided now.
# See thread "Assigning Proxy objects" on p6l,
# L<"http://www.nntp.perl.org/group/perl.perl6.language/21838">.
# Quoting Larry:
#   The intention is that lvalue subs behave in all respects as if they
#   were variables.  So consider what
#   
#       say $nonproxy = 40;
#   
#   should do.

plan 18;

my $foo        = 42;
my $was_inside = 0;

sub lvalue_test1() is rw {
  $was_inside++;
  return Proxy.new:
    FETCH => method () { 100 + $foo },
    STORE => method ($new) { $foo = $new - 100 };
};

{
    is $foo, 42,       "basic sanity (1)";
    is $was_inside, 0, "basic sanity (2)";

    is lvalue_test1(),              142, "getting var through Proxy (1)";
    # No todo_is here to avoid unexpected succeeds (? - elaborate?)
    is      $was_inside,              1, "lvalue_test1() was called (1)";

    is (lvalue_test1() = 123),      123, "setting var through Proxy";
    is      $was_inside,              2, "lvalue_test1() was called (2)";
    is      $foo,                    23, "var was correctly set (1)";

    is lvalue_test1(),              123, "getting var through Proxy (2)";
    is      $was_inside,              3, "lvalue_test1() was called (3)";
}

$foo        = 4;
$was_inside = 0;

sub lvalue_test2() is rw {
  $was_inside++;
  return Proxy.new:
    FETCH => method ()     { 10 + $foo },
    STORE => method ($new) { $foo = $new - 100 };
};

{
    is $foo, 4,        "basic sanity (3)";
    is $was_inside, 0, "basic sanity (4)";


    is lvalue_test2(),               14, "getting var through Proxy (4)";
    # No todo_is here to avoid unexpected succeeds
    is      $was_inside,              1, "lvalue_test2() was called (4)";

    is (lvalue_test2() = 106),      16, "setting var through Proxy returns new value of the var";
    is      $was_inside,              2, "lvalue_test2() was called (5)";
    is      $foo,                     6, "var was correctly set (2)";

    is lvalue_test2(),               16, "getting var through Proxy (5)";
    is      $was_inside,              3, "lvalue_test2() was called (5)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-routine-modifiers/scoped-named-subs.t0000664000175000017500000000320312224265625023514 0ustar  moritzmoritzuse v6;
use Test;
plan 12;

# L

#first lets test lexical named subs
{
    my Str sub myNamedStr() { return 'string' };
    is myNamedStr(), 'string', 'lexical named sub() return Str';
}

eval_dies_ok 'myNamedStr()', 'Correct : lexical named sub myNamedStr() should NOT BE available outside its scope';

{
    my Int sub myNamedInt() { return 55 };
    is myNamedInt(), 55, 'lexical named sub() return Int';
}
eval_dies_ok('myNamedInt()', 'Correct : lexical named sub myNamedInt() should NOT BE available outside its scope');


#packge-scoped named subs

{
    our Str sub ourNamedStr() { return 'string' };
    is ourNamedStr(), 'string', 'package-scoped named sub() return Str';
}
#?pugs skip 'Cannot use Undef as a Code object'
{
    our &ourNamedStr;
    is ourNamedStr(), 'string', 'Correct : package-scoped named sub ourNamedStr() should BE available in the whole package';
}

{
    our Int sub ourNamedInt() { return 55 };
    is ourNamedInt(), 55, 'package-scoped named sub() return Int';
}
#?pugs skip 'Cannot use Undef as a Code object'
{
    our &ourNamedInt;
    is ourNamedInt(), 55, 'Correct : package-scoped named sub ourNamedInt() should BE available in the whole package';
}

eval_dies_ok
    'my Num List sub f () { return ("A") }; f()',
    'Return of list with wrong type dies';

eval_lives_ok
    'my Parcel sub f () { return () }; f()',
    'return of empty Parcel should live';
is eval('my Parcel sub f () { return () }; (f(), "a")'), ['a'],
    'return of empty Parcel should be empty Parcel';

eval_dies_ok
    'my Num List sub f () { ("A") }; f()',
    'implicit return of list with wrong type dies';

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/arity.t0000664000175000017500000001323412224265625017675 0ustar  moritzmoritzuse v6;

use Test;

plan 52;

# L
sub a_zero  ()           { };
sub a_one   ($a)         { };   #OK not used
sub a_two   ($a, $b)     { };   #OK not used
sub a_three ($a, $b, @c) { };   #OK not used
sub a_four  ($a, $b, @c, %d) { };   #OK not used

sub o_zero  ($x?, $y?)   { };   #OK not used
sub o_one   ($x, :$y)    { };   #OK not used
sub o_two   ($x, :$y!, :$z) { };   #OK not used

is &a_zero.arity,   0, '0 arity &sub';
is &a_one.arity,    1, '1 arity &sub';
is &a_two.arity,    2, '2 arity &sub';
is &a_three.arity,  3, '3 arity &sub';
is &a_four.arity,   4, '4 arity &foo';

#?pugs 5 skip '.count'
is &a_zero.count,   0, '0 count &sub';
is &a_one.count,    1, '1 count &sub';
is &a_two.count,    2, '2 count &sub';
is &a_three.count,  3, '3 count &sub';
is &a_four.count,   4, '4 count &foo';

#?pugs 3 todo
is &o_zero.arity,   0, 'arity 0 sub with optional params';
is &o_one.arity,    1, 'arity 1 sub with optional params';
is &o_two.arity,    1, 'arity with optional and required named params';

#?pugs 3 skip '.count'
is &o_zero.count,   2, 'count on sub with optional params';
is &o_one.count,    1, 'count on sub with optional params';
is &o_two.count,    1, 'count on sub with optional and required named params';

#?pugs skip 'parsefail'
{
    sub b_zero  ()           { };
    sub b_one   ($)          { };
    sub b_two   ($, $)       { };
    sub b_three ($, $, @)    { };
    sub b_four  ($, $, @, %) { };
    is &b_zero.arity,   0, '0 arity &sub (sigils only)';
    is &b_one.arity,    1, '1 arity &sub (sigils only)';
    is &b_two.arity,    2, '2 arity &sub (sigils only)';
    is &b_three.arity,  3, '3 arity &sub (sigils only)';
    is &b_four.arity,   4, '4 arity &foo (sigils only)';

}

# It's not really specced in what way (*@slurpy_params) should influence
# .arity. Also it's unclear what the result of &multisub.arity is.
# See the thread "&multisub.arity?" on p6l started by Ingo Blechschmidt for
# details:
# L

{
    is ({ $^a         }.arity), 1,
        "block with one placeholder var has .arity == 1";
    #?pugs 4 skip "is multi"
    is (-> $a { $a         }.arity), 1,
        "pointy block with one placeholder var has .arity == 1";
    is { $^a,$^b     }.arity, 2,
        "block with two placeholder vars has .arity == 2";
    is (-> $a, $b { $a,$b     }).arity, 2,
        "pointy block with two placeholder vars has .arity == 2";
    is { $^a,$^b,$^c }.arity, 3,
        "block with three placeholder vars has .arity == 3";
    is (-> $a, $b, $c { $a,$b,$c }).arity, 3,
        "pointy block with three placeholder vars has .arity == 3";
    
    #?pugs 6 skip ".count"
    is ({ $^a         }.count), 1,
        "block with one placeholder var has .count == 1";
    is (-> $a { $a         }.count), 1,
        "pointy block with one placeholder var has .count == 1";
    is { $^a,$^b     }.count, 2,
        "block with two placeholder vars has .count == 2";
    is (-> $a, $b { $a,$b     }).count, 2,
        "pointy block with two placeholder vars has .count == 2";
    is { $^a,$^b,$^c }.count, 3,
        "block with three placeholder vars has .count == 3";
    is (-> $a, $b, $c { $a,$b,$c }).count, 3,
        "pointy block with three placeholder vars has .count == 3";
}

#?pugs skip "is multi"
{
    is { my $k; $^a         }.arity, 1,   #OK not used
        "additional my() vars don't influence .arity calculation (1-1)";
    is { my $k; $^a,$^b     }.arity, 2,   #OK not used
        "additional my() vars don't influence .arity calculation (1-2)";
    is { my $k; $^a,$^b,$^c }.arity, 3,   #OK not used
        "additional my() vars don't influence .arity calculation (1-3)";

    is { my $k; $^a         }.count, 1,   #OK not used
        "additional my() vars don't influence .count calculation (1-1)";
    is { my $k; $^a,$^b     }.count, 2,   #OK not used
        "additional my() vars don't influence .count calculation (1-2)";
    is { my $k; $^a,$^b,$^c }.count, 3,   #OK not used
        "additional my() vars don't influence .count calculation (1-3)";
}

#?pugs skip 'is multi' 
{
    is { $^a;         my $k }.arity, 1,   #OK not used
        "additional my() vars don't influence .arity calculation (2-1)";
    is { $^a,$^b;     my $k }.arity, 2,   #OK not used
        "additional my() vars don't influence .arity calculation (2-2)";
    is { $^a,$^b,$^c; my $k }.arity, 3,   #OK not used
        "additional my() vars don't influence .arity calculation (2-3)";

    is { $^a;         my $k }.count, 1,   #OK not used
        "additional my() vars don't influence .count calculation (2-1)";
    is { $^a,$^b;     my $k }.count, 2,   #OK not used
        "additional my() vars don't influence .count calculation (2-2)";
    is { $^a,$^b,$^c; my $k }.count, 3,   #OK not used
        "additional my() vars don't influence .count calculation (2-3)";
}

# used to be a bug in Rakudo, RT #63744
#?pugs skip 'parsefail'
{
    sub indirect-count(Code $c) { +$c.signature.params; }
    my $tester = -> $a, $b, $c? { ... };   #OK not used
    is +$tester.signature.params, 3, '+$obj.signature.params work';
    is +$tester.signature.params, indirect-count($tester),
       '... also when passed to a sub first';
}

#?pugs todo
dies_ok { eval("a_zero( 'hello', 'world' )") }, 'no matching sub signature';

#?pugs skip 'parsefail'
{
    my proto sub a($, $?) { * }
    my multi sub a($)     { 1 }
    my multi sub a($, $)  { 2 }
    is &a.count, 2, '&multi.count';
    is &a.arity, 1, '&multi.arity';
}

# RT #111646
#?pugs 2 skip '.count'
is (-> *@a { }).count, Inf, 'slurpy positional causes infinite count';  #OK not used
is (-> *%a { }).count, 0,   'slurpy named causes no count change';      #OK not used

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/caller-param.t0000664000175000017500000000117212224265625021103 0ustar  moritzmoritzuse v6;
use Test;
plan 7;

sub callerunderscore ($foo = $CALLER::_) {
    return "-" ~ $foo ~ "-"
}

is(callerunderscore("foo"), "-foo-", 'CALLER:: string arg');
is(callerunderscore(1), "-1-", 'CALLER:: number arg');
$_ = "foo";
is(callerunderscore(), "-foo-", 'CALLER:: $_ set once');
$_ = "bar";
is(callerunderscore(), "-bar-", 'CALLER:: $_ set twice');
for ("quux") {
    #?pugs todo
    is(callerunderscore(), '-quux-', 'CALLER:: $_ set by for');
}
given 'hirgel' {
    #?pugs todo
    is callerunderscore, '-hirgel-', '$CALLER::_ set by given';
}
is(callerunderscore(), '-bar-', 'CALLER:: $_ reset after for');


# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/closure-over-parameters.t0000664000175000017500000000121712224265625023331 0ustar  moritzmoritzuse v6;

use Test;

=begin desc

Closure over parameters of outer subs, as per
# L
# L

=end desc 

plan 4;

sub factorial (Int $n) {
    my sub facti (Int $acc, Int $i) {
        return $acc if $i > $n;
        facti($acc * $i, $i + 1);
    }
    facti(1, 1);
} ;

is factorial(0), 1, "closing over params of outer subs (0)";
is factorial(1), 1, "closing over params of outer subs (1)";
#?pugs 2 todo
is factorial(2), 2, "closing over params of outer subs (2)";
is factorial(3), 6, "closing over params of outer subs (3)";

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/closure-parameters.t0000664000175000017500000000471312224265625022364 0ustar  moritzmoritzuse v6;
use Test;

plan 15;

# L

{
    my sub testit (&testcode) {testcode()}

    ok(testit({return 1}), 'code executes as testsub({...})');

    my $code = {return 1};
    ok(testit($code), 'code executes as testsub($closure)');

    my sub returntrue {return 1}
    ok(testit(&returntrue), 'code executes as testsub(&subroutine)');
}

# with a signature for the closure
#?rakudo skip 'type syntax parse failure'
{
    my sub testit (&testcode:(Int)) {testcode(12)}
    my sub testint(Int $foo) {return 1}   #OK not used
    my sub teststr(Str $foo) {return 'foo'}   #OK not used

    ok(testit(&testint), 'code runs with proper signature (1)');
    eval_dies_ok('testit(&teststr)', 'code dies with invalid signature (1)');
}

#?rakudo skip 'type syntax parse failure'
{
    my sub testit (&testcode:(Int --> Bool)) {testcode(3)}
    my Bool sub testintbool(Int $foo) {return Bool::True}   #OK not used
    my Bool sub teststrbool(Str $foo) {return Bool::False}   #OK not used
    my Int  sub testintint (Int $foo) {return 1}   #OK not used
    my Int  sub teststrint (Str $foo) {return 0}   #OK not used

    ok(testit(&testintbool), 'code runs with proper signature (2)');
    eval_dies_ok('testit(&testintint)',  'code dies with invalid signature (2)');
    eval_dies_ok('testit(&teststrbool)', 'code dies with invalid signature (3)');
    eval_dies_ok('testit(&teststrint)',  'code dies with invalid signature (4)');
}

#?rakudo skip 'type syntax parse failure'
{
    multi sub t1 (&code:(Int)) { 'Int' };   #OK not used
    multi sub t1 (&code:(Str)) { 'Str' };   #OK not used
    multi sub t1 (&code:(Str --> Bool)) { 'Str --> Bool' };   #OK not used
    multi sub t1 (&code:(Any, Any)) { 'Two' };   #OK not used

    is t1(-> $a, $b { }), 'Two',   #OK not used
       'Multi dispatch based on closure parameter syntax (1)';
    is t1(-> Int $a { }), 'Int',   #OK not used
       'Multi dispatch based on closure parameter syntax (2)';
    is t1(-> Str $a { }), 'Str',   #OK not used
       'Multi dispatch based on closure parameter syntax (3)';

    sub takes-str-returns-bool(Str $x --> Bool) { True }   #OK not used
    is t1(&takes-str-returns-bool), 'Str --> Bool',
       'Multi dispatch based on closure parameter syntax (4)';

    dies_ok { t1( -> { 3 }) }, 
       'Multi dispatch based on closure parameter syntax (5)';
}

{
    sub foo(:&a) { bar(:&a) }
    sub bar(*%_) { "OH HAI" }
    is foo(), 'OH HAI', 'can use &a as a named parameter';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/code.t0000664000175000017500000000243712224265625017462 0ustar  moritzmoritzuse v6;
use Test;
plan 8;

# TODO: move this test to closure-parameters.t if it works in the future

# L

our $collector = 2;
sub to_be_called($x) {
    $collector += $x;
}

sub tester(&my_sub) {
    my_sub(4);
}

tester(&to_be_called);
ok $collector == 6, 'Can call my_sub() if &my_sub was a parameter';

tester(sub ($x) { $collector = 3 * $x });
ok $collector == 12, 'same with anonymous sub';

sub tester2(&my_sub) { 1 }    #OK not used
#?pugs todo
dies_ok {eval 'tester2(42)' }, "can't pass thing that doesn't do Callable";

sub not_returns_a_sub { 3 };
#?pugs todo
dies_ok { eval 'tester2(not_returns_a_sub)' }, 
        "can't pass thing that doesn't do Callable";

is tester2({ 'block' }), 1, 'Can pass a block to a ¶meter';

# RT #68578
#?niecza todo
#?pugs todo
{
    sub rt68578( Callable &x ) {}   #OK not used
    dies_ok { rt68578({ 'block' }) },
            "Can't pass something that isn't typed as returning Callable";
}

# RT #67932
{
    my $tracker;
    sub foo(&foo = &foo) {
        $tracker = &foo
    };
    #?niecza todo
    #?rakudo todo 'RT 67932'
    lives_ok { foo },
        'can call a sub with a code object defaulting to something of its own name';
    #?pugs todo
    ok !$tracker.defined, 'the inner &foo is undefined (scoping)';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/defaults.t0000664000175000017500000000161612224265625020355 0ustar  moritzmoritzuse v6;

use Test;

=begin description

Tests assigning default values to variables of type code in sub definitions.

=end description

# L

plan 5;

sub doubler($x) { return 2 * $x }

sub value_v(Code $func = &doubler) {
    return $func(5);
}

is(value_v, 10, "default sub called");
is value_v({3 * $_ }), 15, "default sub can be overridden";

package MyPack {

    sub double($x) { return 2 * $x }

    our sub val_v(Code :$func = &double) is export {
        return $func(5);
    }

}

ok((MyPack::val_v), "default sub called in package namespace");


{
    sub default_with_list($x = (1, 2)) {
        $x[0];
    }
    is default_with_list(), 1, 'can have a parcel literal as default value';
}

# RT #69200
{
    sub rt69200(Bool :$x) { $x };
    is rt69200(:x), True, '":x" is the same as "x => True" in sub call';
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/errors.t0000664000175000017500000000257412224265625020066 0ustar  moritzmoritz    use v6;

use Test;

plan 10;

=begin pod

These are misc. sub argument errors.

=end pod

sub bar (*@x) { 1 }   #OK not used
lives_ok { bar(reverse(1,2)) }, 'slurpy args are not bounded (2)';  

#?pugs todo
eval_dies_ok 'sub quuux ($?VERSION) { ... }',
             'parser rejects magicals as args (1)';
eval_lives_ok 'sub quuuux ($!) { ... }', 'but $! is OK';

# RT #64344
#?pugs todo
{
    sub empty_sig() { return };
    dies_ok { eval('empty_sig("RT #64344")') },
            'argument passed to sub with empty signature';
}

# RT #71478
{
    #?pugs todo
    dies_ok { eval 'sub foo(%h) { %h }; foo(1, 2); 1' },
        "Passing two arguments to a function expecting one hash is an error";

    try { eval 'sub foo(%h) { %h }; foo(1, 2); 1' };
    my $error   = "$!";
    #?pugs todo
    ok $error ~~ / '%h' /,   '... error message mentions parameter';
    #?pugs todo
    ok $error ~~ /:i 'type' /, '... error message mentions "type"';
    #?pugs todo
    ok $error ~~ / Associative | \% /, '... error message mentions "Associative" or the % sigil';
}

# RT #109064
eval_dies_ok 'my class A { submethod BUILD(:$!notthere = 10) }; A.new',
    'named parameter of undeclared attribute dies';

# RT #72082
#?niecza todo
#?pugs todo
{
    try { eval 'sub rt72082(@a, $b) {}; rt72082(5)' };
    my $error = ~$!;
    ok $error ~~ / 'will never work' .* 'Expected' .* '(@a, $b)' /
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/introspection.t0000664000175000017500000001163412224265625021447 0ustar  moritzmoritzuse v6;
use Test;
plan 52;

# L

sub j(*@i) {
    @i.map({ $_ ?? '1' !! '0' }).join(' ');
}

{
    sub a($x, Int $y?, :$z) { };   #OK not used
    ok &a.signature.params ~~ Positional, '.params does Positional';
    my @l = &a.signature.params;
    ok ?(all(@l >>~~>> Parameter)), 'And all items are Parameters';
    is +@l, 3, 'we have three of them';
    is ~(@l>>.name), '$x $y $z', 'can get the names with sigils';
    ok @l[0].type === Any, 'Could get first type';
    ok @l[1].type === Int, 'Could get second type';

    is j(@l>>.readonly), '1 1 1', 'they are all read-only';
    is j(@l>>.rw),       '0 0 0', '... none rw';
    is j(@l>>.copy),     '0 0 0', '... none copy';
    is j(@l>>.parcel),   '0 0 0', '... none ref';
    is j(@l>>.slurpy),   '0 0 0', '... none slurpy';
    is j(@l>>.optional), '0 1 1', '... some optional';
    is j(@l>>.invocant), '0 0 0', '... none invocant';
    is j(@l>>.named),    '0 0 1', '... one named';
}

#?niecza skip "Unhandled trait rwt"
{
    sub b(:x($a)! is rw, :$y is parcel, :$z is copy) { };   #OK not used
    my @l = &b.signature.params;
    is j(@l>>.readonly), '0 0 0', '(second sig) none are all read-only';
    is j(@l>>.rw),       '1 0 0', '... one rw';
    is j(@l>>.parcel),   '0 1 0', '... one parcel';
    is j(@l>>.copy),     '0 0 1', '... one copy';
    is j(@l>>.slurpy),   '0 0 0', '... none slurpy';
    is j(@l>>.optional), '0 1 1', '... some optional';
    is j(@l>>.invocant), '0 0 0', '... none invocant';
    is j(@l>>.named),    '1 1 1', '... all named';

    is ~@l[0].named_names, 'x',   'named_names work';
    is ~@l[0].name,      '$a',    '.name works for renamed params';
}

{
    sub d(*@pos, *%named) { };   #OK not used
    my @l = &d.signature.params;
    #?niecza todo
    is j(@l>>.named),    '0 1', '.named for slurpies';
    is j(@l>>.slurpy),   '1 1', '.slurpy';
    is ~(@l>>.name),     '@pos %named', '.name for slurpies';
}


{
    sub d(:x(:y(:z($a)))) { };   #OK not used
    is ~&d.signature.params.[0].named_names.sort, 'x y z', 'multi named_names';
    is ~&d.signature.params.[0].name, '$a',    '... and .name still works';
}

#?niecza skip "Parameter separator ;  NYI"
{
    sub e($x = 3; $y = { 2 + $x }) { };   #OK not used
    my @l = &e.signature.params>>.default;
    ok ?( all(@l >>~~>> Code) ), '.default returns closure';
    is @l[0].(),    3, 'first closure works';
    # XXX The following test is very, very dubious...
    #?rakudo skip 'expected Any but got Mu instead'
    is @l[1].().(), 5, 'closure as default value captured outer default value';
}

#?niecza skip "Unable to resolve method constraints in class Parameter"
{
    sub f(Int $x where { $_ % 2 == 0 }) { };   #OK not used
    my $p = &f.signature.params[0];
    ok 4  ~~ $p.constraints, '.constraints (+)';
    ok 5 !~~ $p.constraints, '.constraints (-)';
    ok 5 ~~ (-> $x { }).signature.params[0].constraints,
       '.constraints on unconstraint param should still smartmatch truely';
    sub g(Any $x where Int) { };   #OK not used
    ok 3 ~~ &g.signature.params[0].constraints,
       'smartmach against non-closure constraint (+)';
    ok !(3.5 ~~ &g.signature.params[0].constraints),
       'smartmach against non-closure constraint (-)';
}

# RT #70720
#?niecza skip "Action method fakesignature not yet implemented"
{
    is :(3).params[0].constraints, 3, ':(3) contains the 3';
    ok :(3).params[0].type === Int,   ':(3) has a parameter of type Int';
}

#?niecza skip "GLOBAL::T does not name any package"
{
    sub h(::T $x, T $y) { };   #OK not used
    my @l = &h.signature.params;
    is @l[0].type_captures, 'T', '.type_captures';
    lives_ok { @l[1].type }, "can access a type_capture'd type";
}

{
    sub i(%h($a, $b)) { };   #OK not used
    my $s = &i.signature.perl;
    #?niecza 2 todo
    ok $s ~~ /'$a' >> /, '.perl on a nested signature contains variables of the subsignature (1)';
    ok $s ~~ /'$b' >> /, '.perl on a nested signature contains variables of the subsignature (2)';

}

#?niecza skip "Action method fakesignature not yet implemented"
{
    my $x;
    ok :(|x).params[0].capture, 'prefix | makes .capture true';
    ok :(|x).perl  ~~ / '|' /,  'prefix | appears in .perl output';

    ok :(\x).params[0].parcel, 'prefix \\ makes .parcel true';
    ok :(\x).perl ~~ / '\\' /, 'prefix \\ appears in .perl output';
}

# RT #69492
#?niecza skip "Abbreviated named parameter must have a name"
{
    sub foo(:$) {};
    ok &foo.signature.perl ~~ / ':' /, '.perl of a signature with anonymous named parameter';
}

# Capture param introspection
{
    sub xyz(|c) {};
    is &xyz.signature.params[0].name,       'c' , '.name of |c is "c"';
    #?niecza todo "Does this test make sense?"
    is &xyz.signature.params[0].positional, False, '.positional on Capture param is False';
    is &xyz.signature.params[0].capture,    True , '.capture on Capture param is True';
    is &xyz.signature.params[0].named,      False, '.named on Capture param is True';
}

done;

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/mixed-placeholders.t0000664000175000017500000000132012224265625022307 0ustar  moritzmoritzuse v6;

use Test;

#L

plan 12;

sub t {
    is $^tene, 3, "Placeholder vars work";
    is $:DietCoke, 6, "Placeholder vars work";
    is $^chromatic, 1, "Placeholder vars work";
    is $:moritz, 4, "Placeholder vars work";
    is $^mncharity, 2, "Placeholder vars work";
    is $:TimToady, 5, "Placeholder vars work";
    is @_[1], 8, "Placeholder vars work";
    is %_, 11, "Placeholder vars work";
    is @_[0], 7, "Placeholder vars work";
    is %_, 10, "Placeholder vars work";
    is @_[2], 9, "Placeholder vars work";
    is %_, 12, "Placeholder vars work";
}

t(1, 2, 3, :moritz(4), :TimToady(5), :DietCoke(6), 7, 8, 9, :foo(10), :bar(11), :baz(12));

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/multidimensional.t0000664000175000017500000000252512224265625022123 0ustar  moritzmoritzuse v6;

use Test;

plan 10;

# L

sub get_multidim_arglist (**@AoA) { @AoA }

{
    my @array1 = ;
    my @array2 = ;

    my @AoA = get_multidim_arglist(@array1; @array2);
    is +@AoA,          2, "basic multidim arglist binding (1)";
    is ~@AoA[0], "a b c", "basic multidim arglist binding (2)";
    is ~@AoA[1], "d e f", "basic multidim arglist binding (3)";
}

{
    my @array1 = ;

    my @AoA = get_multidim_arglist(@array1);
    is +@AoA,          1, "multidim arglist binding with only one array (1)";
    is ~@AoA[0], "a b c", "multidim arglist binding with only one array (2)";
}

multi sub multi_get_multidim_arglist(**@AoA) { @AoA }
multi sub multi_get_multidim_arglist(Int $a) { $a }

{
    my @a1 = ;
    my @a2 = ;

    my @AoA = multi_get_multidim_arglist(@a1; @a2);
    is +@AoA,          2, "multi sub with multidim arglist binding (1)";
    is  @AoA[0], "a b c", "multi sub with multidim arglist binding (2)";
    is  @AoA[1], "d e f", "multi sub with multidim arglist binding (3)";
}

{
    my @a1 = ;

    my @AoA = multi_get_multidim_arglist(@a1);
    is +@AoA,          1, "multi sub with multidim arglist binding for only one array (1)";
    is  @AoA[0], "a b c", "multi sub with multidim arglist binding for only one array (2)";
}

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/multiple-signatures.t0000664000175000017500000000363612224265625022567 0ustar  moritzmoritzuse v6;
use Test;

# this tests signatures, so the file lives in S06-signature/, although
# the features are (mostly?) described in S13

plan 11;

# L

# normal subs
{
    multi sub si  (Str $s, Int $i)
                | (Int $i, Str $s) {
        die "dispatch went wrong" unless $s ~~ Str && $i ~~ Int;
        "s:$s i:$i";
    }
    is si("a", 3), "s:a i:3", 'sub with two sigs dispatches correctly (1)';
    is si(3, "b"), "s:b i:3", 'sub with two sigs dispatches correctly (2)';
}

# try it with three sigs as well, and mixed named/positionals
{
    multi sub three  (Str $s, Int $i, Num :$n)
                   | (Int $i, Str :$s, Num :$n)
                   | (Num :$s, Int :$i, Str :$n) {
        "$s $i $n";
    }
    is three('abc', 3, :n(2.3)), 'abc 3 2.3', 'multi dispatch on three() (1)';
    is three(4, :s, :n(2.3)), 'x 4 2.3',   'multi dispatch on three() (2)';
    is three(:i(4), :s(0.2), :n('f')), '0.2 4 f', 'multi dispatch on three() (3)';
}

# L

{
    multi sub count  (Str $s, Int $i)   #OK not used
                | (Int $i, Str $s) {   #OK not used
        state $x = 0;
        ++$x;
    }
    is count("a", 3), 1, 'initialization of state var in multi with two sigs';
    is count("a", 2), 2, 'state var works';
    is count(2, 'a'), 3, '... and there is only one';
}

# L

{
    eval_dies_ok q[ multi sub x ($x, $y) | ($x, $y, $z) { 1 }],
        'multis with multiple sigs must have the same set of formal variables';
    eval_dies_ok q[ multi sub x ($x, $y) | ($x, @y) { 1 }],
        'multis with multiple sigs must have the same set of formal variables';
}

# common sense
eval_dies_ok q[ only sub y (Int $x, Str $y) | (Str $x, Int $y) ],
    'and "only" sub can not have multiple signatures';

# vim: ft=perl6
rakudo-2013.12/t/spec/S06-signature/named-parameters.t0000664000175000017500000002660212224265625021775 0ustar  moritzmoritzuse v6;
use Test;

plan 93;

# L

{
    sub a($x = 4) {
        return $x;
    }
    is a(3), 3, 'Can pass positional arguments';
    #?pugs skip 'Named argument found where no matched parameter expected'
    dies_ok { eval('a(g=>7)') }, 'Dies on passing superfluous arguments';
}

{
    sub c(:$w=4){
        return $w;
    } 
    is c(w => 3), 3, 'Named argument passes an integer, not a Pair';
    my $w = 5;
    is c(:$w), 5, 'can use :$x colonpair syntax to call named arg';
    #?pugs skip 'Named argument found where no matched parameter expected'
    dies_ok {eval('my $y; c(:$y)')}, 'colonpair with wrong variable name dies';
}

{
    sub add5(:$g) {
        return $g + 5;
    }
    class A {
        has $!g = 3;
        method colonpair_private { add5(:$!g) }
    };
    class B {
        has $.g = 7;
        method colonpair_public { add5(:$.g) }
    };
    sub colonpair_positional {
        add5(:$^g);
    }

    is A.new.colonpair_private, 8, 'colonpair with a private variable';
    is B.new.colonpair_public, 12, 'colonpair with a public variable';
    #?rakudo skip 'Not enough positional parameters passed; got 0 but expected 1'
    #?pugs skip 'Named argument found where no matched parameter expected'
    is colonpair_positional(:g<10>), 15, 'colonpair with a positional variable';
}


# L
sub simple_pos_params (:$x) { $x }

is(simple_pos_params( x => 4 ), 4, "simple named param");


sub foo (:$x = 3) { $x }

is(foo(), 3, "not specifying named params that aren't mandatory works");

# part of RT 53814
#?pugs todo 'bug'
dies_ok({foo(4)}, "using a named as a positional fails");

is(foo( x => 5), 5, "naming named param also works");
is(foo( :x<5> ), 5, "naming named param adverb-style also works");

sub foo2 (:$x = 3, :$y = 5) { $x + $y }

is(foo2(), 8, "not specifying named params that aren't mandatory works (foo2)");
#?pugs 2 todo 'bug'
dies_ok({foo2(4)}, "using a named as a positional fails (foo2)");
dies_ok({foo2(4, 10)}, "using a named as a positional fails (foo2)");
is(foo2( x => 5), 10, "naming named param x also works (foo2)");
is(foo2( y => 3), 6, "naming named param y also works (foo2)");
is(foo2( x => 10, y => 10), 20, "naming named param x & y also works (foo2)");
is(foo2( :x(5) ), 10, "naming named param x adverb-style also works (foo2)");
is(foo2( :y(3) ), 6, "naming named param y adverb-style also works (foo2)");
is(foo2( :x(10), :y(10) ), 20, "naming named params x & y adverb-style also works (foo2)");
is(foo2( x => 10, :y(10) ), 20, "mixing fat-comma and adverb naming styles also works for named params (foo2)");
is(foo2( :x(10), y => 10 ), 20, "mixing adverb and fat-comma naming styles also works for named params (foo2)");

#?pugs emit # dies with Undeclared variable on the $x here.

#?pugs emit #
sub assign_based_on_named_positional ($x, :$y = $x) { $y } 

#?pugs skip "depends on previous sub"
is(assign_based_on_named_positional(5), 5, "When we don't explicitly specify, we get the original value");
#?pugs skip "depends on previous sub"
is(assign_based_on_named_positional(5, y => 2), 2, "When we explicitly specify, we get our value");
#?pugs skip "depends on previous sub"
is(assign_based_on_named_positional('y'=>2), ('y'=>2), "When we explicitly specify, we get our value");
#?pugs emit #
my $var = "y";
#?pugs skip "depends on previous sub"
is(assign_based_on_named_positional($var => 2), ("y"=>2),
   "When we explicitly specify, we get our value");

# L
#?niecza skip 'multiple same-named arguments NYI' 
#?pugs   skip 'multiple same-named arguments NYI'
    #?rakudo skip 'multiple same-named arguments NYI'
{
    sub named_array(:@x) { +«@x }

    is(named_array(:x), (1), 'named array taking one named arg');
    is(named_array(:x, :!x), (1, 0), 'named array taking two named args');
    is(named_array(:x(1), :x(2), :x(3)), (1, 2, 3), 'named array taking three named args');
}

# L
#?rakudo skip 'multiple same-named arguments NYI'
#?niecza skip 'multiple same-named arguments NYI'
#?pugs skip 'unexpected =>'
{
    sub named_array2(@x, :y) { (+«@x, 42, +«@y) }
    # +«(:x) is (0, 1)

    is(named_array2(:!x, :y), (0, 42, 1), 'named and unnamed args - two named');
    is(named_array2(:!x, y => 1), (0, 42, 1), 'named and unnamed args - two named - fatarrow');
    is(named_array2(:y, :!x), (0, 42, 1), 'named and unnamed args - two named - backwards');
    is(named_array2(:y, (:x)), (0, 1, 42, 1), 'named and unnamed args - one named, one pair');
    is(named_array2(1, 2), (1, 42), 'named and unnamed args - two unnamed');
    is(named_array2(:!y, 1), (1, 42, 0), 'named and unnamed args - one named, one pos');
    is(named_array2(1, :!y), (1, 42, 0), 'named and unnamed args - one named, one pos - backwards');
    is(named_array2(:y, 1, :!y), (1, 42, 1, 0), 'named and unnamed args - two named, one pos');
    
    nok(try { eval 'named_array2(:y, :y)'}.defined, 'named and unnamed args - two named with same name');

    is(named_array2(:y, (:x)), (0, 1, 42, 1), 'named and unnamed args - passing parenthesized pair');
    is(named_array2(:y, (:y)), (0, 1, 42, 1), 'named and unnamed args - passing parenthesized pair of same name');
    is(named_array2(:y, :z), (0, 1, 42, 1), 'named and unnamed args - passing pair of unrelated name');
    is(named_array2(:y, "x" => 1), (0, 1, 42, 1), 'named and unnamed args - passing pair with quoted fatarrow');
}

# L
# L
sub mandatory (:$param!) {
    return $param;
}

is(mandatory(param => 5) , 5, "named mandatory parameter is returned");
#?pugs todo
dies_ok {eval 'mandatory()' },  "not specifying a mandatory parameter fails";

#?niecza skip "Unhandled trait required"
{
    sub mandatory_by_trait (:$param is required) {
        return $param;
    }
    
    is(mandatory_by_trait(param => 5) , 5, "named mandatory parameter is returned");
    dies_ok( { mandatory_by_trait() }, "not specifying a mandatory parameter fails");
}


# L
sub formalize($text, :$case, :$justify) {
   return($text,$case,$justify); 
}

{
my ($text,$case,$justify)  = formalize('title', case=>'upper');
is($text,'title', "text param was positional");
nok($justify.defined, "justification param was not given");
is($case, 'upper', "case param was named, and in justification param's position");
}

{
my ($text,$case,$justify)   = formalize('title', justify=>'left');
is($text,'title', "text param was positional");
is($justify, 'left', "justify param was named");
nok($case.defined, "case was not given at all");
}

{
my  ($text,$case,$justify) = formalize("title", :justify, :case);

is($text,'title', "title param was positional");
is($justify, 'right', "justify param was named with funny syntax");
is($case, 'title', "case param was named with funny syntax");
}

{
sub h($a,$b,$d) { $d ?? h($b,$a,$d-1) !! $a~$b }

is(h('a','b',1),'ba',"parameters don\'t bind incorrectly");
}

# Slurpy Hash Params
{
sub slurpee(*%args) { return %args }
my %fellowship = slurpee(hobbit => 'Frodo', wizard => 'Gandalf');
is(%fellowship<hobbit>, 'Frodo', "hobbit arg was slurped");
is(%fellowship<wizard>, 'Gandalf', "wizard arg was slurped");
is(+%fellowship, 2, "exactly 2 arguments were slurped");
nok(%fellowship<dwarf>.defined, "dwarf arg was not given");
}

{
    sub named_and_slurp(:$grass, *%rest) { return($grass, %rest) }
    my ($grass, %rest) = named_and_slurp(sky => 'blue', grass => 'green', fire => 'red');
    is($grass, 'green', "explicit named arg received despite slurpy hash");
    #?pugs todo
    is(+%rest, 2, "exactly 2 arguments were slurped");
    #?pugs todo
    is(%rest<sky>, 'blue', "sky argument was slurped");
    is(%rest<fire>, 'red', "fire argument was slurped");
    nok(%rest<grass>.defined, "grass argument was NOT slurped");
}

{
    my $ref;
    sub setref($refin) {
        $ref = $refin;
    }
    my $aref = [0];
    setref($aref);
    $aref[0]++;
    is($aref[0], 1, "aref actually implemented");
    is($ref[0], 1, "ref is the same as aref");
}

{
    sub typed_named(Int :$x) { 1 }
    is(typed_named(:x(42)), 1,      'typed named parameters work...');
    is(typed_named(),       1,      '...when value not supplied also...');
    #?pugs todo
    dies_ok({ typed_named("BBQ") }, 'and the type check is enforced');
}

#?pugs skip 'parsefail'
{
    sub renames(:y($x)) { $x }
    is(renames(:y(42)),  42, 'renaming of parameters works');
    is(renames(y => 42), 42, 'renaming of parameters works');
    dies_ok { renames(:x(23)) }, 'old name is not available';
}

# L<S06/Parameters and arguments/"A signature containing a name collision">

#?niecza 2 todo "sub params with the same name"
#?pugs todo
eval_dies_ok 'sub rt68086( $a, $a ) { }', 'two sub params with the same name';

#?pugs todo
eval_dies_ok 'sub svn28865( :$a, :@a ) {}',
             'sub params with the same name and different types';

{
    sub svn28870( $a, @a ) { return ( $a, +@a ) }

    my $item = 'bughunt';
    my @many = ( 22, 'twenty-two', 47 );

    is( svn28870( $item, @many ), ( 'bughunt', 3 ),
        'call to sub with position params of same name and different type' );
}

# RT #68524
#?pugs todo
{
    sub rt68524( :$a! ) {}
    ok( &rt68524.signature.perl ~~ m/\!/,
        '.signature.perl with required parameter includes requirement' );
}

# RT #69516
#?pugs skip 'parsefail'
{
    sub rt69516( :f($foo) ) { "You passed '$foo' as 'f'" }
    ok( &rt69516.signature.perl ~~ m/ ':f(' \s* '$foo' \s* ')' /,
        'parameter rename appears in .signature.perl' );
}

# L<S06/Named parameters/Bindings happen in declaration order>
#?rakudo skip 'where constraints'
#?pugs skip 'parsefail'
{
    my $t = '';
    sub order_test($a where { $t ~= 'a' },   #OK not used
                   $b where { $t ~= 'b' },   #OK not used
                   $c where { $t ~= 'c' }) { 8 };   #OK not used
    is order_test(c => 5, a => 3, b => 2), 8,
        'can fill positional by name';
    ok $t ~~ /a.*b/, '$a was bound before $b';
    ok $t ~~ /a.*c/, '$a was bound before $c';
    ok $t ~~ /b.*c/, '$b was bound before $c';
}

# RT #67558
#?pugs skip 'parsefail'
{
    #?niecza todo "Renaming a parameter to an existing positional should fail"
    eval_dies_ok q[sub a(:$x, :foo($x) = $x) { $x }],
        'Cannot rename a parameter to an already existing positional';
    sub a(:$x, :foo($y) = $x) { $y };
    is a(x => 2), 2, 'Can fill named parameter with default from other named';
    is a(foo => 3), 3, 'Can fill in directly even it has a default value';
    is a(x => 2, foo => 3), 3, 'direct fill takes precedence';


}

{
    sub test_positional_named(:@a) { @a.join('|'); }
    is test_positional_named(:a(3, 4, 5)), '3|4|5',
        ':a(1, 2, 3) can be passed to a :@a parameter';
    is test_positional_named(:a[3, 4, 5]), '3|4|5',
        ':a[1, 2, 3] can be passed to a :@a parameter';
    is test_positional_named(:a<3 4 5>), '3|4|5',
        ':a<1 2 3> can be passed to a :@a parameter';

}

#?pugs todo
{
    sub quoted_named(:$x = 5) { $x };
    dies_ok { quoted_named( "x" => 5 ) }, 'quoted pair key => positional parameter';
}

#?niecza skip "Abbreviated named parameter must have a name"
#?pugs skip 'parsefail'
{
    sub named_empty(:$) {
        42
    }
    my %h = '' => 500;
    is named_empty(|%h), 42, 'can call function with empty named argument';
}

done;

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/named-placeholders.t��������������������������������������������0000664�0001750�0001750�00000000560�12224265625�022272� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 3;

#L<S06/Placeholder variables/>

sub one_placeholder {
    is $:bla,  2, "A single named placeholder works";
}

one_placeholder(:bla(2));

sub two_placeholders {
    is $:b, 1, "Named dispatch isn't broken for placeholders";
    is $:a, 2, "Named dispatch isn't broken for placeholders";
}

two_placeholders(:a(2), :b(1));

# vim: syn=perl6
������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/named-renaming.t������������������������������������������������0000664�0001750�0001750�00000001435�12224265625�021427� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 10;

{
    sub f(:a(:$b)) { $b }
    sub g(:a( $b)) { $b }

    is f( a => 1), 1, 'can use the alias name (1)';
    is g( a => 1), 1, 'can use the alias name (1)';
    is f( b => 1), 1, 'can use the var name';
    dies_ok { eval 'g(  b => 1)' },
            'cannot use the var name if there is no : in front of it';
}

{
    sub mandatory(:x(:$y)!) { $y }
    is mandatory( y => 2), 2, 'mandatory named';
    is mandatory( x => 3), 3, 'mandatory renamed';
    dies_ok { eval 'mandatory()' }, 'and it really is mandatory';
}

{
    sub typed(:i(:%j)) { %j.keys.[0] };
    is typed(i => { a => 1 }), 'a', 'typed renames -- sanity';
    dies_ok { eval 'typed(:j)' }, 'type constraint on var';
    dies_ok { eval 'typed(:i)' }, 'type constraint on var propagates to alias';
}
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/optional.t������������������������������������������������������0000664�0001750�0001750�00000006742�12224265625�020400� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S06/Optional parameters/>

plan 25;

sub opt1($p?) { defined($p) ?? $p !! 'undef'; }

is opt1('abc'), 'abc',      'Can pass optional param';
is opt1(),      'undef',    'Can leave out optional param';

sub opt2($p?, $q?) {
      (defined($p) ?? $p !! 'undef')
    ~ '|'
    ~ (defined($q) ?? $q !! 'undef');
}

is opt2('a', 'b'), 'a|b',           'Can pass all two optional params';
is opt2('a'),      'a|undef',       'Can pass one of two optional params';
is opt2(),         'undef|undef',   'Can leave out all two optional params';

sub t_opt2(Str $p?, Str $q?) {
      (defined($p) ?? $p !! 'undef')
    ~ '|'
    ~ (defined($q) ?? $q !! 'undef');
}

is t_opt2('a', 'b'), 'a|b',           'Can pass all two optional params';
is t_opt2('a'),      'a|undef',       'Can pass one of two optional params';
is t_opt2(),         'undef|undef',   'Can leave out all two optional params';

sub opt_typed(Int $p?) { defined($p) ?? $p !! 'undef' };

is opt_typed(2), 2,        'can pass optional typed param';
is opt_typed() , 'undef',  'can leave out optional typed param';

# L<S06/Parameters and arguments/"required positional parameters must come
# before those bound to optional positional">
#?pugs todo
eval_dies_ok 'sub wrong1 ($a?, $b) {...}', 'optional params before required ones are forbidden';
# RT #76022
#?pugs todo
{
    eval_dies_ok 'sub wrong2 ($a = 1, $b) {...}', "...even if they're only optional by virtue of a default";
    eval_dies_ok 'sub wrong3 ($a = 0, $b) {...}', '...and the default is 0';
}

sub foo_53814($w, $x?, :$y = 2) { $w~"|"~$x~"|"~$y };
dies_ok {foo_53814(1,Mu,'something_extra',:y(3))},
      'die on too many parameters (was once bug RT 53814)';


{

    # old test is bogus, nullterm only allowed at the end of a list
    # is rt54804( 1, , 3, ), '1|undef|3|undef',
    #    'two commas parse as if undef is between them';
    eval_dies_ok q/sub rt54804( $v, $w?, $x?, $y? ) {
        (defined( $v ) ?? $v !! 'undef')
        ~ '|' ~
        (defined( $w ) ?? $w !! 'undef')
        ~ '|' ~
        (defined( $x ) ?? $x !! 'undef')
        ~ '|' ~
        (defined( $y ) ?? $y !! 'undef')
    }
    rt54804( 1, , 3, )/, "two commas in a row doesn't parse";
}

#?pugs todo
eval_dies_ok( 'sub rt66822($opt?, $req) { "$opt, $req" }',
              "Can't put required parameter after optional parameters" );

# Niecza bug#49
sub opt_array1(@x?) { @x.elems }
sub opt_array2(@x? is copy) { @x.elems }
sub opt_hash1(%x?) { %x.keys.elems }
sub opt_hash2(%x? is copy) { %x.keys.elems }
is opt_array1(), 0, "optional array not passed is empty";
is opt_array2(), 0, "optional array not passed is empty (copy)";
is opt_hash1(),  0, "optional hash not passed is empty";
is opt_hash2(),  0, "optional hash not passed is empty (copy)";

# RT #71110
#?pugs todo
eval_dies_ok 'sub opt($a = 1, $b) { }',
    'Cannot put required parameter after optional parameters';

# RT #74758
#?pugs todo
{
    sub opt-type1(Int $x?) { $x };
    ok opt-type1() === Int,
        'optional param with type constraints gets the right value';
    sub opt-type2(Int $x = 'str') { };  #OK not used
    dies_ok { eval('opt-type2()') }, 'default values are type-checked';
}

# RT # 76728
#?pugs skip "Can't modify constant item: VUndef"
{
    sub opt-hash(%h?) {
        %h<a> = 'b';
        %h
    }
    is opt-hash().keys, 'a', 'can assign to optional parameter';

    # RT #79642
    sub opt-hash2(%h?) {
        %h;
    }
    ok opt-hash2() eqv ().hash, 'an optional-but-not-filled hash is just an empty Hash';
}

# vim: ft=perl6
������������������������������rakudo-2013.12/t/spec/S06-signature/outside-subroutine.t��������������������������������������������0000664�0001750�0001750�00000000370�12224265625�022413� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin desc

Signature binding outside of routine calls
RT #82946

=end desc 

plan 2;

my ($f, $o, @a); 
@a = 2, 3, 4; 
:($f, $o, $) := @a; 

is $f, 2, 'f eq 2 after binding';
is $o, 3, 'o eq 3 after binding';

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/passing-arrays.t������������������������������������������������0000664�0001750�0001750�00000002714�12224265625�021511� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S06/Parameters and arguments>
# TODO: better smart-linking

plan 11;

{
    sub count(@a) {
        my $x = 0;
        $x++ for @a;
        return $x;
    }

    is count([1, 2, 3, 4]),       4, 'count([1, 2, 3, 4])';
    is count(my @b = 1, 2, 3, 4), 4, 'count(my @b = 1, 2, 3)';
    is count((1, 2, 3)),          3, 'count((1, 2, 3))';

    sub count2($a) {
        my $x = 0;
        $x++ for $a;
        return $x;
    }

    is count2((1,2,3)),           1, 'count2((1,2,3))';
}

{
    sub pa(@a) { @a.WHAT; }
    my @b = 2, 3;
    isa_ok pa(@b), Array, 'basic array type sanity';
    #?pugs todo
    dies_ok { eval('pa(3)') }, 'non-slurpy array does not take a single Int';

    sub ph(%h) { 1 }   #OK not used
    #?pugs todo
    dies_ok { eval('ph(3)') }, 'an Int is not a Hash';
}

# this used to be a rakudobug, RT #62172
{
    my @a = 1..8;
    sub t1(@a) { return +@a };
    sub t2(@a) { return t1(@a) };
    is t2(@a), 8, 'can pass arrays through multiple subs';
}

{
    sub test_two_array(@a,@b)
    {
        return @a[0] + @b[0];
    }

    is(test_two_array([100,5],[20,300]), 120, 
    "Passing array references to functions accepting arrays works.");
}

# A Rakudo regression

{
    sub ro_a(@a) { };   #OK not used
    sub ro_b(@a) { ro_a(@a) };
    my @x = 1, 2, 4;
    lives_ok { ro_b(@x) },   'can pass parameter Array on to next function';
    lives_ok { @x = 5, 6 }, '... and that did not make the caller Array ro';
}

# vim: ft=perl6
����������������������������������������������������rakudo-2013.12/t/spec/S06-signature/passing-hashes.t������������������������������������������������0000664�0001750�0001750�00000000673�12224265625�021465� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S06/Parameters and arguments>
# TODO: better smart-linking

use Test;
plan 3;

sub sanity {
    my %sane = 'a'..'d' Z 1..4;
    isa_ok(%sane, Hash, '%sane is a Hash');
}

sub insanity (%baloney) {
    isa_ok(%baloney, Hash, '%baloney is a Hash');
}

# sanity 0
my %h = 'a'..'d' Z 1..4;
isa_ok(%h.WHAT, Hash, '%h is a Hash');

#sanity 1;
sanity;

# Hash passed to a sub used to become a List in pugs
insanity %h;


# vim: ft=perl6
���������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/positional-placeholders.t���������������������������������������0000664�0001750�0001750�00000002332�12224265625�023366� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 10;

#L<S06/Placeholder variables/>

sub one_placeholder {
    is $^bla,  2, "A single placeholder works";
}

one_placeholder(2);

sub two_placeholders {
    is $^b, 2, "Second lexicographic placeholder gets second parameter";
    is $^a, 1, "First lexicographic placeholder gets first parameter";
}

two_placeholders(1, 2);

sub non_twigil {
    is $^foo, 5, "A single placeholder (still) works";
    is $foo, 5, "It also has a corresponding non-twigil variable";
}

non_twigil(5);

eval_dies_ok( ' {$foo; $^foo;}(1) ',
'A non-twigil variable should not precede a corresponding twigil variable' );

# RT #64310
eval_dies_ok ' {my $foo; $^foo;}(1) ', 'my $foo; $^foo; is an illegal redeclaration';

# RT #74778
{
    my $tracker = '';
    for 1, 2 {
        $tracker ~= $^a ~ $^a ~ '|';
    }
    is $tracker, '11|22|', 'two occurrences of $^a count as one param';
}

# RT #99734
{
    sub rt99734 { "$^c is $^a and $^b" };
    is rt99734("cake", "tasty", "so on"), 'so on is cake and tasty',
       'RT 99734';
}

# RT #73688
{
    sub inner(*@a) { @a.join(', ') };
    sub outer { &^c($^a, $^b)  };
    is outer('x', 'y', &inner), 'x, y',
        'can have invocable placeholder with arguments';
}

# vim: syn=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/positional.t����������������������������������������������������0000664�0001750�0001750�00000001747�12224265625�020734� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 7;

sub my_first  ($x, $,  $ ) { $x };
sub my_second ($,  $x, $ ) { $x };
sub my_third  ($,  $,  $x) { $x };

is my_first( 4, 5, 6), 4, '($x, $, $) works as a signature';
is my_second(4, 5, 6), 5, '($, $x, $) works as a signature';
is my_third( 4, 5, 6), 6, '($, $, $x) works as a signature';

# RT #60408
{
    sub rt60408 {
        return { @_.join };
    }

    is rt60408().(1, 2, 3), '123', '@_ belongs to the inner-most block';
}

{

    sub f(@a, $i) {
        $i ~ "[{map { f($_, $i + 1) }, @a}]"
    };
    is f([[], [[]], []], 0), "0[1[] 1[2[]] 1[]]",
       'recusion and parameter binding work out fine';
}

# using "special" variables as positional parameters
{
    # RT #77054
    sub dollar-underscore($x, $y, $_, $z) { "$x $y $_ $z"; }
    is dollar-underscore(1,2,3,4), '1 2 3 4', '$_ works as parameter name';

    sub dollar-slash($x, $/, $y) { "$x $<b> $y" }
    is dollar-slash(1, { b => 2 }, 3), '1 2 3', '$/ works as parameter name';
}

# vim: ft=perl6
�������������������������rakudo-2013.12/t/spec/S06-signature/scalar-type.t���������������������������������������������������0000664�0001750�0001750�00000001621�12224265625�020766� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 8;

# a scalar parameter can be bound to any type below Any, and should
# preserve its type

{
  sub foo( $arg ) { return $arg.WHAT }
  sub make_array() { return ['were','there'] }
  sub make_hash() { return {'z'=>'y','x'=>'w'} }
  is( foo([]), ::Array, "anon-def empty array arg defined inline" );

  is( foo(['hello']), ::Array, "anon-def 1-elem array arg defined inline" );

  is( foo(['hello','world']), ::Array, "anon-def 2-elem array arg defined inline" );

  is( foo(make_array()), ::Array, "2-elem array arg, sub-returned, invoked inline" );

  is( foo(hash()), ::Hash, "anon-def empty hash arg defined inline" );

  is( foo({'a'=>'b'}), ::Hash, "anon-def 1-elem hash arg defined inline" );

  is( foo({'a'=>'b','c'=>'d'}), ::Hash, "anon-def 2-elem hash arg defined inline" );

  is( foo(make_hash()), ::Hash, "2-elem hash arg, sub-returned, invoked inline" );
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/sigilless.t�����������������������������������������������������0000664�0001750�0001750�00000002131�12224265625�020535� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 10;

# test \term
{
    sub identity(\x) { x }

    sub count(\x) {
        my $c = 0;
        ++$c for x;
        $c
    }

    sub swap(\x, \y) {
        my $z = y;
        y = x;
        x = $z;
    }

    is identity('foo'), 'foo',
       'basic passing of an argument to backslashed identifier';
    is count((1, 2, 3)), 3, 'passing of flattening arguments ';
    is count([1, 2, 3]), 1, 'passing of non-flatteing arguments';

    my $a = 5;
    my $b = 3;
    lives_ok { eval 'swap($a, $b)' }, 'backslash does not make read-only';
    is "$a|$b", '3|5', 'swapping worked';
    dies_ok { eval 'swap(42, $a)' }, 'no additional writable containers involved';
}

# test |term
{
    sub pass-on(&c, |args) { c(|args) }
    sub join-em(|args)     { args.list.join('|') }

    is pass-on(-> $a, $b { $a + $b }, 2, 3),  5,        '|args sanity (1)';
    is join-em('foo', 42),                    'foo|42', '|args sanity (2)';
    is join-em(pass-on(-> $a, $b { $a + $b }, 2, 3), 42),
       '5|42', 'combined sanity';

    is pass-on({ $:l~ $:w }, :w<6>, :l<p>), 'p6', 'named arguments';

}
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/slurpy-and-interpolation.t��������������������������������������0000664�0001750�0001750�00000002264�12224265625�023531� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 7;

# L<S03/Argument List Interpolating/"interpolate">

# try to flatten the args for baz() to match

sub baz ($a, $b) { return "a: $a b: $b"}
sub invoke (*@args) { baz(|@args) }

my $val;
lives_ok {
    $val = invoke(1, 2);
}, '... slurpy args flattening and matching parameters';

is($val, 'a: 1 b: 2', '... slurpy args flattening and matching parameters');

# try to flatten the args for the anon sub to match

sub invoke2 ($f, *@args) { $f(|@args) }; 
is(invoke2(sub ($a, $b) { return "a: $a b: $b"}, 1, 2), 'a: 1 b: 2', 
    '... slurpy args flattening and matching parameters');

dies_ok {
    invoke2(sub ($a, $b) { return "a: $a b: $b"}, 1, 2, 3);
}, '... slurpy args flattening and not matching because of too many parameters';  

# used to be a Rakudo regression, RT #62730

{
    sub f1(*%h) { %h.perl }; 
    sub f2(*%h) { f1(|%h) };
    lives_ok { f2( :a(1) ) },
            'Can interpolate hashes into slurpy named parameters';
    is eval(f2(:a(4))).<a>, 4,  '... with a sane return value';
}

# RT #113804
#?niecza skip "Unable to resolve method Capture in type Range"
is join('|', |(1..5)), '1|2|3|4|5', 'can interpolate ranges into arglists';

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/slurpy-blocks.t�������������������������������������������������0000664�0001750�0001750�00000000720�12224265625�021352� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;


use Test;

plan 6;

# L<S06/Slurpy block/>

sub foo (Code *$block) {
    return $block.();
}

is(foo():{ "foo" }, 'foo', 'Code *$block - 1');
is(foo():{ 0 }, 0, 'Code *$block - 2');

sub bar (*&block) {
    return &block.();
}

is(bar():{ "bar" }, 'bar', '*&block - 1');
is(bar():{ 0 }, 0, '*&block - 2');

is(foo():{ "foo" }, bar():{ "foo" }, 'Code *$block == *&block - 1');
is(foo():{ 0 }, bar():{ 0 }, 'Code *$block == *&block - 2');

# vim: ft=perl6
������������������������������������������������rakudo-2013.12/t/spec/S06-signature/slurpy-params.t�������������������������������������������������0000664�0001750�0001750�00000021772�12224265625�021372� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S06/List parameters/Slurpy parameters>

plan 57;

sub xelems(*@args) { @args.elems }
sub xjoin(*@args)  { @args.join('|') }

is xelems(1),          1,        'Basic slurpy params 1';
is xelems(1, 2, 5),    3,        'Basic slurpy params 2';

is xjoin(1),           '1',      'Basic slurpy params 3';
is xjoin(1, 2, 5),     '1|2|5',  'Basic slurpy params 4';

sub mixed($pos1, *@slurp) { "|$pos1|" ~ @slurp.join('!') }

is mixed(1),           '|1|',    'Positional and slurp params';
is mixed(1, 2, 3),     '|1|2!3', 'Positional and slurp params';
#?pugs todo
dies_ok {eval(' mixed()')},      'at least one arg required';

#?rakudo skip 'types on slurpy params'
{
    sub x_typed_join(Int *@args){ @args.join('|') }
    is x_typed_join(1),           '1',      'Basic slurpy params with types 1';
    is x_typed_join(1, 2, 5),     '1|2|5',  'Basic slurpy params with types 2';
    #?niecza todo 'Types on slurpy params are checked'
    #?pugs todo
    dies_ok { x_typed_join(3, 'x') }, 'Types on slurpy params are checked';
}

sub first_arg      ( *@args         ) { ~@args[0]; }
sub first_arg_rw   ( *@args is rw   ) { ~@args[0]; }
sub first_arg_copy ( *@args is copy ) { ~@args[0]; }

is first_arg(1, 2, 3),      '1',  'can grab first item of a slurpy array';
is first_arg_rw(1, 2, 3),   '1',  'can grab first item of a slurpy array (is rw)';
is first_arg_copy(1, 2, 3), '1',  'can grab first item of a slurpy array (is copy)';

# test that shifting works
{
    sub func(*@m) {
        @m.shift;
        return @m;
    }
    #?pugs todo 'bug'
    is func(5).elems, 0, "Shift from an array function argument works";
}


sub whatever {
    is(@_[3], 'd', 'implicit slurpy param flattens');
    is(@_[2], 'c', 'implicit slurpy param flattens');
    is(@_[1], 'b', 'implicit slurpy param flattens');
    is(@_[0], 'a', 'implicit slurpy param flattens');
}

whatever( 'a', 'b', 'c', 'd' );

# use to be t/spec/S06-signature/slurpy-params-2.t


=begin pod

=head1 List parameter test

These tests are the testing for "List paameters" section of Synopsis 06

You might also be interested in the thread Calling positionals by name in
presence of a slurpy hash" on p6l started by Ingo
Blechschmidt L<http://www.nntp.perl.org/group/perl.perl6.language/22883>

=end pod

#?niecza todo
{
    my sub foo ($n, *%h) { };   #OK not used
    ## NOTE: *NOT* sub foo ($n, *%h, *@a)
    lives_ok { foo 1, n => 20, y => 300 },
        'Testing: `sub foo($n, *%h) { }; foo 1, n => 20, y => 300`';
}

{
    my sub foo ($n, *%h) { };   #OK not used
    ## NOTE: *NOT* sub foo ($n, *%h, *@a)
    dies_ok { foo 1, x => 20, y => 300, 4000 },
        'Testing: `sub foo($n, *%h) { }; foo 1, x => 20, y => 300, 4000`';
}


# Named with slurpy *%h and slurpy *@a
# named arguments aren't required in tests below
{
    my sub foo(:$n, *%h, *@a) { };   #OK not used
    my sub foo1(:$n, *%h, *@a) { $n };   #OK not used
    my sub foo2(:$n, *%h, *@a) { %h<x> + %h<y> + %h<n> };   #OK not used
    my sub foo3(:$n, *%h, *@a) { [+] @a };   #OK not used
    
    diag("Testing with named arguments (named param isn't required)");
    lives_ok { foo 1, x => 20, y => 300, 4000 },
      'Testing: `sub foo(:$n, *%h, *@a){ }; foo 1, x => 20, y => 300, 4000`';
    nok (foo1 1, x => 20, y => 300, 4000).defined,
      'Testing value for named argument';
    is (foo2 1, x => 20, y => 300, 4000), 320,
      'Testing value for slurpy *%h';
    is (foo3 1, x => 20, y => 300, 4000), 4001,
      'Testing the value for slurpy *@a';
    
    ### named parameter pair will always have a higher "priority" while passing
    ### so %h<n> will always be undefined
    lives_ok { foo1 1, n => 20, y => 300, 4000 },
      'Testing: `sub foo(:$n, *%h, *@a){ }; foo 1, n => 20, y => 300, 4000`';
    is (foo1 1, n => 20, y => 300, 4000), 20,
      'Testing the named argument';
    is (foo2 1, n => 20, y => 300, 4000), 300,
      'Testing value for slurpy *%h';
    is (foo3 1, n => 20, y => 300, 4000), 4001,
      'Testing the value for slurpy *@a';
}


# named with slurpy *%h and slurpy *@a
## Named arguments **ARE** required in tests below

#### ++ version
{
    my sub foo(:$n!, *%h, *@a) { };   #OK not used
    diag('Testing with named arguments (named param is required) (++ version)');
    lives_ok { foo 1, n => 20, y => 300, 4000 },
    'Testing: `my sub foo(+:$n, *%h, *@a){ }; foo 1, n => 20, y => 300, 4000 }`';
    #?pugs todo 'bug'
    dies_ok { foo 1, x => 20, y => 300, 4000 };
}

#### "trait" version
#?niecza skip 'Unhandled trait required'
{
    my sub foo(:$n is required, *%h, *@a) { };   #OK not used
    diag('Testing with named arguments (named param is required) (trait version)');
    lives_ok { foo 1, n => 20, y => 300, 4000 },
    'Testing: `my sub foo(:$n is required, *%h, *@a){ }; foo 1, n => 20, y => 300, 4000 }`';
    #?pugs todo 'bug'
    dies_ok { foo 1, x => 20, y => 300, 4000 },
    'Testing: `my sub foo(:$n is required, *%h, *@a){ }; foo 1, x => 20, y => 300, 4000 }`';
}

##### Now slurpy scalar tests here.
=begin desc

=head1 List parameter test

These tests are the testing for "List parameters" section of Synopsis 06


=end desc

# L<S06/List parameters/Slurpy scalar parameters capture what would otherwise be the first elements of the variadic array:>

#?niecza todo '*$f slurps everything up'
{
    sub first(*$f, *$s, *@r) { return $f };   #OK not used
    sub second(*$f, *$s, *@r) { return $s };   #OK not used
    sub rest(*$f, *$s, *@r) { return [+] @r };   #OK not used
    diag 'Testing with slurpy scalar';
    is first(1, 2, 3, 4, 5), 1,
       'Testing the first slurpy scalar...';
    is second(1, 2, 3, 4, 5), 2,
       'Testing the second slurpy scalar...';
    is rest(1, 2, 3, 4, 5), 12,
       'Testing the rest slurpy *@r';
}

# RT #61772
{
    my @array_in = <a b c>;

    sub no_copy( *@a         ) { @a }
    sub is_copy( *@a is copy ) { @a }

    my @not_copied = no_copy( @array_in );
    my @copied     = is_copy( @array_in );

    is @copied, @not_copied, 'slurpy array copy same as not copied';
}

# RT #64814
#?rakudo skip 'types on slurpy params'
#?niecza skip 'Unhandled trait of'
#?pugs skip 'parsefail'
{
    sub slurp_any( Any *@a ) { @a[0] }
    is slurp_any( 'foo' ), 'foo', 'call to sub with (Any *@a) works';

    sub slurp_int( Int *@a ) { @a[0] }
    dies_ok { slurp_int( 'foo' ) }, 'dies: call (Int *@a) sub with string';
    is slurp_int( 27.Int ), 27, 'call to sub with (Int *@a) works';

    sub slurp_of_int( *@a of Int ) { @a[0] }
    dies_ok { slurp_of_int( 'foo' ) }, 'dies: call (*@a of Int) with string';
    is slurp_of_int( 99.Int ), 99, 'call to (*@a of Int) sub works';

    class X64814 {}
    class Y64814 {
        method x_slurp ( X64814 *@a ) { 2 }   #OK not used
        method of_x ( *@a of X64814 ) { 3 }   #OK not used
        method x_array ( X64814 @a ) { 4 }   #OK not used
    }

    my $x = X64814.new;
    my $y = Y64814.new;
    is $y.x_array( $x ), 4, 'call to method with typed array sig works';
    is $y.of_x( $x ),    3, 'call to method with "slurp of" sig works';
    is $y.x_slurp( $x ), 2, 'call to method with typed slurpy sig works';
    dies_ok { $y.x_array( 23 ) }, 'die calling method with typed array sig';
    dies_ok { $y.of_x( 17 ) }, 'dies calling method with "slurp of" sig';
    dies_ok { $y.x_slurp( 35 ) }, 'dies calling method with typed slurpy sig';
}

{
    my $count = 0;
    sub slurp_obj_thread(*@a) { $count++; }   #OK not used
    multi sub slurp_obj_multi(*@a) { $count++; }   #OK not used

    $count = 0;
    slurp_obj_thread(3|4|5);
    is $count, 1, 'Mu slurpy param doesnt autothread';
    $count = 0;
    slurp_obj_multi(3|4|5);
    is $count, 1, 'Mu slurpy param doesnt autothread';
}

##  Note:  I've listed these as though they succeed, but it's possible
##  that the parameter binding should fail outright.  --pmichaud
#?rakudo skip 'types on slurpy params'
{
    my $count = 0;
    sub slurp_any_thread(Any *@a) { $count++; }   #OK not used
    multi sub slurp_any_multi(Any *@a) { $count++; }   #OK not used

    slurp_any_thread(3|4|5);
    is $count, 1, 'Any slurpy param doesnt autothread';
    $count = 0;
    slurp_any_multi(3|4|5);
    is $count, 1, 'Any slurpy param doesnt autothread';
}

#?pugs todo
eval_dies_ok 'sub rt65324(*@x, $oops) { say $oops }',
             "Can't put required parameter after variadic parameters";

# used to be RT #69424
#?rakudo skip 'types on slurpy params'
#?pugs skip 'parsefail'
{
    sub typed-slurpy(Int *@a) { 5 }   #OK not used
    my Int @b;
    is typed-slurpy(@b), 5, 'can fill typed slurpy with typed array';
}


# RT #61772
{
    sub array_slurpy_copy(*@a is copy) {
        return @a;
    }
    my @array = <a b c>;
    my @c = array_slurpy_copy(@array);
    is @c[0], 'a', 'slurpy is copy-array works fine, thank you';
}

# RT #72600
{
    sub A (*@_) {
        is @_, [5, 4], 'slurpy @_ contains proper values';
        if 1 {
            is @_, [5, 4], 'slurpy @_ values not clobbered by if statement';
        }
    };
    A(5, 4);
}

# RT #74410
#?pugs skip "can't find multi for is"
{
    is -> *@a { @a[+0] }.([5]), 5,
        'slurpy array can be indexed if index contains prefix:<+>';
}

done;

# vim: ft=perl6
������rakudo-2013.12/t/spec/S06-signature/slurpy-placeholders.t�������������������������������������������0000664�0001750�0001750�00000001601�12224265625�022541� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 8;

#L<S06/Placeholder variables/>

sub positional_slurpy {
    is @_[0],  1, "Leftover positional args get passed to @_ if present";
    is +@_, 1, 'one item filled into @_';
}

positional_slurpy(1);

sub named_slurpy {
    is %_<a>, 1, "Leftover named args get passed to %_ if present";
}

named_slurpy(:a(1));

sub both {
    is @_[1], 3, "Positional and named placeholder slurpies play well together";
    is %_<a>, 4, "Positional and named placeholder slurpies play well together";
    is @_[0], 5, "Positional and named placeholder slurpies play well together";
    is %_<b>, 6, "Positional and named placeholder slurpies play well together";
}

both(5, :b(6), 3, :a(4));

{
    my @result;
    sub perl5sub {
        push @result, @_[0];
        push @result, @_[1];
    }
    perl5sub(<foo bar>);
    is(@result, [<foo bar>], 'use @_ in sub');
}


# vim: syn=perl6
�������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/sub-ref.t�������������������������������������������������������0000664�0001750�0001750�00000007203�12224265625�020107� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S02/"Built-In Data Types"/Perl 6> 

plan 34;

=begin description

These tests test subroutine references and their invocation.

See L<S02/"Built-in Data Types"> for more information about Code, Routine, Sub, Block, etc.

=end description

# Quoting A06:
#                                   Code
#                        ____________|________________
#                       |                             |
#                    Routine                        Block
#       ________________|_______________ 
#      |     |       |       |    |     |
#     Sub Method Submethod Multi Rule Macro

{
    my $foo = sub () { 42 };
    isa_ok($foo, Code);
    isa_ok($foo, Routine);
    isa_ok($foo, Sub);
    is $foo.(), 42,                 "basic invocation of an anonymous sub";
    dies_ok { $foo.(23) }, "invocation of a parameterless anonymous sub with a parameter dies";
}

{
    my $foo = -> { 42 };
    isa_ok($foo, Code);
    isa_ok($foo, Block);
    is $foo.(), 42,                 "basic invocation of a pointy block";
    dies_ok { $foo.(23) },  "invocation of a parameterless pointy block with a parameter dies";
}

{
    my $foo = { 100 + $^x };
    isa_ok($foo, Code);
    isa_ok($foo, Block);
    is $foo.(42), 142,              "basic invocation of a pointy block with a param";
    dies_ok { $foo.() }, "invocation of a parameterized block expecting a param without a param dies";
}

# RT #63974
#?pugs skip 'No compatible multi variant found: "$c"'
{
    my $topic = 'topic unchanged';
    my @topic_array = <topic array unchanged>;
    my $c = { $topic = $_; @topic_array = @_ };

    $c( 2, 3, 4, 5 );

    #?rakudo 2 todo 'RT 63974'
    #?niecza 2 todo
    is $topic, 2, '$_ got right value for code ref';
    is @topic_array, ( 3, 4, 5 ), '@_ got right value in code ref';
}

{
    my $foo = sub { 100 + (@_[0] // -1) };
    isa_ok($foo, Code);
    isa_ok($foo, Routine);
    isa_ok($foo, Sub);
    is $foo.(42), 142,              "basic invocation of a perl5-like anonymous sub (1)";
    is $foo.(),    99,              "basic invocation of a perl5-like anonymous sub (2)";
}

{
    my $foo = sub ($x) { 100 + $x };
    isa_ok($foo, Code);
    isa_ok($foo, Routine);
    isa_ok($foo, Sub);
    is $foo.(42),      142,    "calling an anonymous sub with a positional param";
    dies_ok { $foo.() }, 
        "calling an anonymous sub expecting a param without a param dies";
    dies_ok { $foo.(42, 5) },
        "calling an anonymous sub expecting one param with two params dies";
}

# Confirmed by p6l, see thread "Anonymous macros?" by Ingo Blechschmidt
# L<"http://www.nntp.perl.org/group/perl.perl6.language/21825">
#?rakudo skip 'macros, compile time binding'
#?niecza skip 'macros NYI'
{
    # We do all this in a eval() not because the code doesn't parse,
    # but because it's safer to only call macro references at compile-time.
    # So we'd need to wrap the code in a BEGIN {...} block. But then, our test
    # code would be called before all the other tests, causing confusion. :)
    # So, we wrap the code in a eval() with an inner BEGIN.
    # (The macros are subject to MMD thing still needs to be fleshed out, I
    # think.)
    our &foo_macro ::= macro ($x) { "1000 + $x" };
    isa_ok(&foo_macro, Code);
    isa_ok(&foo_macro, Routine);
    #?pugs todo 'macros'
    isa_ok(&foo_macro, Macro);

    is foo_macro(3), 1003, "anonymous macro worked";
}

{
    my $mkinc = sub { my $x = 0; return sub { $x++ }; };

    my $inc1 = $mkinc();
    my $inc2 = $mkinc();

    is($inc1(), 0, "closures: inc1 == 0");
    is($inc1(), 1, "closures: inc1 == 1");
    is($inc2(), 0, "closures: inc2 == 0");
    is($inc2(), 1, "closures: inc2 == 1");
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/tree-node-parameters.t������������������������������������������0000664�0001750�0001750�00000005073�12224265625�022572� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 20;

# L<S06/Unpacking tree node parameters>

# hash left/right
{
    #?DOES 2
    my sub traverse_hash (%top (:$left, :$right, *%), $desc?) {
        is($left,  %top<left>,  "left value is correct: $desc");
        is($right, %top<right>, "right value is correct: $desc");
    }

    my %hash = {left => 'abc', right => 'def'};
    traverse_hash(%hash, 'basic hash');
    traverse_hash({%hash, a => 0, b => 1, c => 2}, 'hash with extra values');

    %hash<left>  = {left => 'foo', right => 'bar'};
    %hash<right> = {left => 'baz', right => 'qux'};
    traverse_hash(%hash, 'hash with values that are hashes');
}

{
    #?DOES 2
    my sub traverse_hash (%top (:$east, :$west, *%), $desc?) {
        is($east, %top<east>, "east value is correct: $desc");
        is($west, %top<west>, "west value is correct: $desc");
    }

    my %hash = {east => 'abc', west => 'def'};
    traverse_hash(%hash, 'custom hash values work');
    traverse_hash({%hash, a => 0, b => 1}, 'custom hash, extra values');

    %hash<east> = {east => 'foo', west => 'bar'};
    %hash<west> = {east => 'baz', west => 'qux'};
    traverse_hash(%hash, 'custom hash with values that are hashes');
}

# object left/right
{
    class BinTree {
        has $.left is rw;
        has $.right is rw;
        method Str() { $.left.WHICH ~ ',' ~ $.right.WHICH }
    }

    #?DOES 2
    my sub traverse_obj (BinTree $top (:$left, :$right), $desc?) {
        is($left,  $top.left,  "left object value is correct: $desc");
        is($right, $top.right, "right object value is correct: $desc");
    }

    my $tree = BinTree.new(left => 'abc', right => 'def');
    traverse_obj($tree, 'simple object');

    $tree.left = $tree;
    $tree.right = $tree;
    traverse_obj($tree, 'nested object tree');
}

# L<S06/Unpacking tree node parameters/You may omit the top variable if you prefix the parentheses>
#?DOES 4
#?rakudo skip 'signature binding of return values NYI'
{
    class Point {has $.x is rw; has $.y is rw}
    class TwoPoints {has Point $.a is rw; has Point $.b is rw}

    my $point_a = Point.new(x => 0, y => 1);
    my $point_b = Point.new(x => 4, y => 2);
    sub getpoints {
        my $points = TwoPoints.new;
        $points.a = $point_a;
        $points.b = $point_b;
        return $points;
    }

   my (Point $ ($a, $b)) := getpoints();
   is($a, $point_a, 'unpacked TwoPoint object (1)');
   is($b, $point_b, 'unpacked TwoPoint object (2)');

   my (Point $ ($c, $d)) := getpoints();
   is($c, $point_a, 'unpacked TwoPoint object (3)');
   is($d, $point_a, 'unpacked TwoPoint object (4)');
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/type-capture.t��������������������������������������������������0000664�0001750�0001750�00000002102�12224265625�021157� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 8;

# TODO: move to S02?
# L<S02/Generic types/>

# Check it captures built-in types.
sub basic_capture(::T $x) { T }   #OK not used
isa_ok(basic_capture(42),  Int, 'captured built-in type');
isa_ok(basic_capture(4.2), Rat, 'captured built-in type');

# User defined ones too.
class Foo { }
isa_ok(basic_capture(Foo.new), Foo, 'captured user defined type');

# Check you can use captured type later in the signature.
sub two_the_same(::T $x, T $y) { 1 }   #OK not used
ok(two_the_same(42, 42), 'used captured type later in the sig');
my $ok = 1;
try {
    two_the_same(42, 4.2);
    $ok = 0;
}
ok($ok, 'used captured type later in the sig');

# Check you can use them to declare variables.
sub declare_cap_type(::T $x) {   #OK not used
    my T $y = 4.2;   #OK not used
    1
}
#?rakudo skip 'nom regression'
ok(declare_cap_type(3.3), 'can use captured type in declaration');
$ok = 1;
try {
    declare_cap_type(42);
    $ok = 0;
}
ok($ok, 'can use captured type in declaration');

#RT #114216
eval_lives_ok q':(::T $x)', "No error on type capture";
# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/types.t���������������������������������������������������������0000664�0001750�0001750�00000001014�12224265625�017702� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

sub f($x) returns Int { return $x };

ok &f.returns === Int, 'sub f returns Int can be queried for its return value';
ok &f.of === Int, 'sub f returns Int can be queried for its return value (.of)';

lives_ok { f(3) },      'type check allows good return';
dies_ok  { f('m') },    'type check forbids bad return';

sub g($x) returns  Int { $x };

lives_ok { g(3)   },    'type check allows good implicit return';
dies_ok  { g('m') },    'type check forbids bad  implicitreturn';

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/unpack-array.t��������������������������������������������������0000664�0001750�0001750�00000003256�12224265625�021145� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 13;

# L<S06/Unpacking array parameters>

sub foo($x, [$y, *@z]) {
    return "$x|$y|" ~ @z.join(';');
}

my @a = 2, 3, 4, 5;
is foo(1, @a), '1|2|3;4;5',  'array unpacking';

sub bar([$x, $y, $z]) {
    return $x * $y * $z;
}

ok bar(@a[0..2]) == 24, 'fixed length array unpacking';
dies_ok { bar [1,2] }, 'fixed length array unpacking too short';
dies_ok { bar [1,2,3,4] }, 'fixed length array unpacking too long';

sub baz([$x, $y?, $z?]) {
    return "$x|$y.gist()|$z.gist()";
}

dies_ok { baz( [] ) } , 'unpack optional scalars; required scalar missing';
is baz( [2] ), "2|(Any)|(Any)", 'unpack optional scalars; one required';
is baz( [2,3] ), "2|3|(Any)", 'unpack optional scalars; one required + one optional';
is baz( [2,3,4] ), "2|3|4", 'unpack optional scalars; one required + two optional';
dies_ok { baz( [2,3,4,5] ) }, 'unpack optional scalars; one required + too many optional';

sub blat ($x, @a [$a, *@b]) {
    return $x == 1 ?? @a.join("|") !! "$a-" ~ @b.join('-');
}

is blat( 1, [2,3,4] ), "2|3|4", 'unpack named array';
is blat( 2, [2,3,4] ), "2-3-4", 'unpack named array with named pieces';

# RT #75900
{
    my @my-array = 4,2,3,4;

    sub fsort-only([$p?,*@r]) {
        return fsort-only(@r.grep( {$_ <= $p} )),$p,fsort-only(@r.grep( {$_ > $p} )) if $p || @r;
    }
    multi fsort-multi([$p?,*@r]) {
        return fsort-multi(@r.grep( {$_ <= $p} )),$p,fsort-multi(@r.grep( {$_ > $p} )) if $p || @r;
    }

   #?niecza 2 todo "https://github.com/sorear/niecza/issues/180"
   is fsort-only(@my-array).join(' '), '2 3 4 4', 'array unpacking and only-subs';
   is fsort-multi(@my-array).join(' '), '2 3 4 4', 'array unpacking and only-multi';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/unpack-object.t�������������������������������������������������0000664�0001750�0001750�00000001152�12224265625�021266� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 4;

{
    my $tracker = '';
    for a => 1, b => 2 -> Pair $p (:$key, :$value) {
        $tracker ~= "|$key,$value";
    }
    is $tracker, '|a,1|b,2', 'unpacking a Pair';
}

{
    class A { has $.x };

    my $tracker = '';
    for A.new(x => 4), A.new(x => 2) -> $ (:$x) {
        $tracker ~= $x;
    }
    is $tracker, '42', 'unpacking attribute of custom class';
}

{
    multi f((Int :$value, *%)) { "Int $value" }
    multi f((Str :$value, *%)) { "Str $value" }
    is f('a' =>  3 ), 'Int 3', 'typed Pair unpackaing (Int)';
    is f('a' => 'x'), 'Str x', 'typed Pair unpackaing (Str)';

}
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-signature/unspecified.t���������������������������������������������������0000664�0001750�0001750�00000004011�12241724324�021027� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 17;

# L<S06/Perl5ish subroutine declarations/You can declare a sub without
# parameter list>
#
# TODO: stop using is() to compare signatures, their stringification
# isn't specced

sub simple { 'simple' }
#?rakudo todo 'siglist'
is &simple.signature, :(), 'signature is :() when none is specified';
is simple(), 'simple', 'can call sub with no signature specified';
dies_ok { eval('simple( :golf<hotel> )') },
        'sub with no signature dies when given a named argument';
dies_ok { eval("simple( 'india' )") },
        'sub with no signature dies when given positional argument';

sub positional { @_[0] }
#?rakudo todo 'siglist'
is &positional.signature, :(*@_),
   'signature is :(Mu *@_) when none is specified and @_ is used';
is positional( 'alpha' ), 'alpha', 'can call sub with positional param used';
nok positional().defined, 'sub using positional param called with no params';
dies_ok { positional( :victor<whiskey> ) },
   'sub using positional param called with named param';

sub named { %_<bravo> }
#?rakudo todo 'siglist'
is &named.signature, :(*%_),
   'signature is :(Mu *%_) when none is specified and %_ is used';
is named( :bravo<charlie> ), 'charlie', 'can call sub with named param used';
nok named().defined, 'named param sub is callable with no params';
dies_ok { named( 'zulu' ) }, 'named param sub dies with positional param';

sub both { @_[1] ~ %_<delta> }
#?rakudo todo 'siglist'
is &both.signature, :(*@_, *%_),
   'signature is :(Mu *@_, Mu *%_) when none is specified and @_ and %_ are used';
is both( 'x', :delta<echo>, 'foxtrot' ), 'foxtrotecho',
   'can call sub with both named and positional params used';
is both(), '',
   'sub using both named and position params works with no params';

# RT 71112
{
    sub rt71112 { @_[0] = 'bug' }
    my $tender = 'sanity';
    #?rakudo todo 'RT 71112: Cannot assign to readonly variable.'
    dies_ok { rt71112( $tender ) }, 'Sub that tries to modify @_ dies';
    is $tender, 'sanity', 'The variable passed is unchanged.';
}

done;

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/as.t���������������������������������������������������������������0000664�0001750�0001750�00000001042�12224265625�016447� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 5;

=begin description

Testing coercion types.

=end description

sub t1(Int() $x) {
    is($x.WHAT.gist, '(Int)', 'object bound .WHATs to the right thing');
    is($x,           1,       'object bound was coerced to the right value');
}
t1(4/3);

sub t2(Int(Rat) $x) {
    is($x.WHAT.gist, '(Int)', 'object bound .WHATs to the right thing');
    is($x,           2,       'object bound was coerced to the right value');
}
t2(7/3);
dies_ok { eval("t2('omg hedgehog!')") }, 'Type checks still enforced';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/is-assoc.t���������������������������������������������������������0000664�0001750�0001750�00000002200�12224265625�017562� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 6;

{
    sub infix:<lea>($a, $b) is assoc<left> {
        "($a|$b)";
    }

    is (1 lea 2 lea 3), '((1|2)|3)', 'assoc<left>';
}

{
    sub infix:<ra>($a, $b) is assoc<right> {
        "($a|$b)";
    }

    is (1 ra 2 ra 3), '(1|(2|3))', 'assoc<right>';
}

{
    sub infix:<lia>(*@a) is assoc<list> {
        '(' ~ join('|', @a) ~ ')';
    }
    is (1 lia 2 lia 3), '(1|2|3)', 'assoc<list>';
}

{
    sub infix:<na>(*@a) is assoc<non> {
        '(' ~ join('|', @a) ~ ')';
    }
    # RT #116238
    dies_ok { eval '1 na 2 na 3' }, 'assoc<non>';
}

#?rakudo skip 'RT 116244'
{
    sub postfix:<_post_l_>($a) is assoc<left> is equiv(&prefix:<+>) {
        "<$a>"
    }
    sub prefix:<_pre_l_>  ($a) is assoc<left> is equiv(&prefix:<+>) {
        "($a)"
    }
    is (_pre_l_ 'a' _post_l_), '<(a)>', 'assoc<left> on prefix/postfix ops';
}

#?rakudo skip 'RT 116244'
{
    sub postfix:<_post_r_>($a) is assoc<left> is equiv(&prefix:<+>) {
        "<$a>"
    }
    sub prefix:<_pre_r_>  ($a) is assoc<left> is equiv(&prefix:<+>) {
        "($a)"
    }
    is (_pre_r_ 'a' _post_r_), '(<a>)', 'assoc<left> on prefix/postfix ops';
}
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/is-copy.t����������������������������������������������������������0000664�0001750�0001750�00000005267�12224265625�017444� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S06/"Parameter traits"/"=item is copy">
# should be moved with other subroutine tests?

plan 24;

{
  sub foo($a is copy) {
    $a = 42;
    return 19;
  }

  my $bar = 23;
  is $bar,      23, "basic sanity";
  is foo($bar), 19, "calling a sub with an is copy param";
  is $bar,      23, "sub did not change our variable";
}
{
    sub copy_tester ($copy_tester is copy = 5, $bar is copy = 10) {
        $copy_tester += $bar;
        $copy_tester;
    }

    is(copy_tester(), 15, 'calling without arguments');

    is(copy_tester(10), 20, 'calling with one argument');
    is(copy_tester(10, 15), 25, 'calling with two arguments');

    my ($baz, $quux) = (10, 15);

    is(copy_tester($baz), 20, 'calling with one argument');
    is($baz, 10, 'variable was not affected');

    is(copy_tester($baz, $quux), 25, 'calling with two arguments');
    is($baz, 10, 'variable was not affected');
}

# is copy with arrays
{
    sub array_test(@testc is copy) {
        is(@testc[0], 1,   'array copied correctly by is copy');
        @testc[0] = 123;
        is(@testc[0], 123, 'can modify array copied by is copy...');
    };
    my @test = (1, 2, 3);
    array_test(@test);
    is(@test[0], 1,        '...and original is unmodified.');
}

# is copy with hashes
{
    sub hash_test(%h is copy) {
        is(%h<x>, 1,   'hash copied correctly by is copy');
        %h<x> = 123;
        is(%h<x>, 123, 'can modify hash copied by is copy...');
    };
    my %test = (x => 1);
    hash_test(%test);
    is(%test<x>, 1,    '...and original is unmodified.');
}

# RT #76242
{
    sub t(@a is copy) {
        my $x = 0;
        $x++ for @a;
        $x;
    }

    my $a = [1, 2, 3];
    #?pugs todo
    is t($a), 3, 'passing [1,2,3] to @a is copy does results in three array items';
}

# RT #76804
{
    sub f($arg is copy) {
        my $other;
        ($arg, $other) = 5, 6;
        $arg;
    };
    is f(0), 5, 'list assignment (0)';
    is f(1), 5, 'list assignment (1)';
}

# RT #74454
{
    sub g(%hash? is copy) { };  #OK not used
    lives_ok { g() }, 'can call a sub with an optional "is copy" hash param';
}

# RT #75302
{
    sub h($x is copy) {
        $x = 'abc';
        $x
    }
    is h(*), 'abc', 'can re-assign to "is copy" parameter that held a Whatever';
}

# RT #82810
{
    sub j(@a is copy) { @a ||= -1, -1, +1, +1; @a.join(',') }
    #?pugs todo
    is j([1, 2, 3, 4]), '1,2,3,4', 'can use ||= on "is copy" array';
}

# RT #74430
#?pugs skip 'parsefail'
{
    sub foo(@items is copy) { @items[0..^1] };
    my @items = 'a'...'g';
    is foo(@items), 'a', 'can slice "is copy" arrays';
}

# RT #117583
# the redeclaration thingy is only a warning
eval_lives_ok 'sub f ($x is copy) { my $x }';


# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/is-readonly.t������������������������������������������������������0000664�0001750�0001750�00000001203�12224265625�020271� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 3;

# L<S06/"Parameter traits"/"=item is readonly">
# should be moved with other subroutine tests?

{
    my $a = 3;

    ok (try { VAR($a).defined }), ".VAR on a plain normal initialized variable returns true";
}

# RT #71356
{
    class C {
        has $!attr is readonly = 71356;
        method get-attr() { $!attr }
        method set-attr($val) { $!attr = $val }
    }
    is C.new.get-attr, 71356, 'can read from readonly private attributes';
    #?rakudo todo 'readonly attributes'
    #?pugs todo
    dies_ok { my $c = C.new; $c.set-attr: 99; }, 'cannot assign to readonly private attribute'
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/is-rw.t������������������������������������������������������������0000664�0001750�0001750�00000002170�12224265625�017110� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 7;
# L<S06/"Parameter traits"/"=item is rw">


{
  sub foo($a is rw) {
    $a = 42;
    return 19;
  }

  my $bar = 23;
  is $bar,      23, "basic sanity";
  is foo($bar), 19, "calling a sub with an is rw param";
  is $bar,      42, "sub changed our variable";
  # RT #74830
  #?pugs todo
  dies_ok { eval('foo(28)') }, 'is rw requires a variable';
}

{
  my $anon = -> $a is rw { $a++ };
  my $bar = 10;
  $anon.($bar);
  is($bar, 11, "anon sub changed variable");
}

# See thread "is rw basically a null-op on objects/references?" on p6l
# L<"http://www.nntp.perl.org/group/perl.perl6.language/20671">
{
  my %hash = (a => 23);
  # First check .value = ... works (as this is a dependency for the next test)
  try { %hash.pairs[0].value = 42 };
#?rakudo todo ''
  is %hash<a>, 42, "pairs are mutable";

  for %hash.pairs -> $pair {     # Note: No "is rw"!
    try { $pair.value += 100 };  # Modifies %hash
  }
#?rakudo todo 'Depends on preceding test working'
  is %hash<a>, 142, "'is rw' not necessary on objects/references";
}

# for ... -> ... is rw {...} already tested for in t/statements/for.t.

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/misc.t�������������������������������������������������������������0000664�0001750�0001750�00000004755�12224265625�017015� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 19;

=begin description

Testing parameter traits for subroutines

=end description

# L<S06/"Parameter traits">

my $foo=1;

# note: many of these errors can be detected at compile time, so need
# eval_dies_ok instead of dies_ok
#
# test twice, once with assignment and once with increment, rakudo
# used to catch the first but not the latter.
#
eval_dies_ok '
    my $tmp = 1;
    sub mods_param ($x) { $x++; }
    mods_param($tmp)
    ',
    'can\'t modify parameter, constant by default';

eval_dies_ok '
    my $tmp = 1;
    sub mods_param ($x) { $x = 1; }
    mods_param($tmp)
    ',
    'can\'t modify parameter, constant by default';

# is readonly
eval_dies_ok 'sub mods_param_constant ($x is readonly) { $x++; };
              mods_param_constant($foo);' ,
              'can\'t modify constant parameter, constant by default';

sub mods_param_rw ($x is rw) { $x++; }
dies_ok  { mods_param_rw(1) }, 'can\'t modify constant even if we claim it\'s rw';
sub mods_param_rw_does_nothing ($x is rw) { $x; }
lives_ok { mods_param_rw_does_nothing(1) }, 'is rw with non-lvalue should autovivify';

lives_ok  { mods_param_rw($foo) }, 'pass by "is rw" doesn\'t die';
is($foo, 2, 'pass by reference works');

#icopy
$foo=1;
sub mods_param_copy ($x is copy) {$x++;}
lives_ok { mods_param_copy($foo) }, 'is copy';
is($foo, 1, 'pass by value works');

# same test with default value
sub boom ($arg is copy = 0) { $arg++ }

lives_ok { boom(42) }, "can modify a copy";


# is parcel
{
    $foo=1;
    sub mods_param_parcel ($x is parcel) { $x++;  }
    dies_ok { mods_param_parcel(1); }, 'is parcel with non-lvalue';
    #?pugs todo
    lives_ok { mods_param_parcel($foo); }, 'is parcel with non-lvalue';
    #?pugs todo
    is($foo, 2, 'is parcel works');
}


# with <-> we should still obey readonly traits
{
    my $anon1 = <-> $a is readonly, $b { $b++ };
    my $anon2 = <-> $a is readonly, $b { $a++ };
    my $x = 1;
    $anon1($x, $x);
    is($x, 2,                   '<-> does not override explicit traints (sanity)');
    #?rakudo 2 todo 'is readonly does not override'
    dies_ok({ $anon2($x, $x) }, '<-> does not override explicit traints');
    is($x, 2,                   '<-> does not override explicit traints (sanity)');
}


{
    try { eval 'my $gack; sub oh_noes( $gack is nonesuch ) { }' };

    ok  $!  ~~ Exception,  "Can't use an unknown trait";
    ok "$!" ~~ /trait/,    'error message mentions trait';
    ok "$!" ~~ /nonesuch/, 'error message mentions the name of the trait';
}

# vim: ft=perl6
�������������������rakudo-2013.12/t/spec/S06-traits/precedence.t�������������������������������������������������������0000664�0001750�0001750�00000003114�12224265625�020143� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Tests for precedence of self defined operators

=end pod

# L<S06/Subroutine traits/"relative to an existing">

plan 10;

do {
    sub prefix:<!> (Int $x) is tighter(&infix:<**>) {
        return 3 * $x;
    }
    #?rakudo todo 'changing precedence of already declared op'
    is !1**2, 9, "'is tighter' on prefix works";
}

do {
    sub prefix:<foo> (Int $x) is looser(&infix:<+>) {
        return 2 * $x;
    }

    is foo 2 + 3, 10, "'is looser' on prefix works";
}


{
    sub postfix:<!> (Int $x) is tighter(&infix:<**>) {
        return 2 * $x;
    }

    is 3**1!, 9, "'is tighter' on postfix works";
}


{
    sub infix:<mul> ($a, $b) is looser(&infix:<+>) {
        return $a * $b;
    }

    is 2 mul 3 + 4, 14, "'is looser' infix works 1";
    is 4 + 3 mul 2 , 14, "'is looser' infix works 2";
}

{
    sub infix:<div> ($a, $b) is equiv(&infix:<*>) {
        return $a / $b;
    }

    ok((4 div 2 * 3) == 6, "'is equiv' works");
}

# prefix/postfix precedence

{
    sub prefix:<'foo1'> (Int $x) {
        return 2 * $x;
    }

    sub postfix:<'bar1'> (Int $x) is looser(&prefix:<'foo1'>){
        return 1 + $x;
    }

    is('foo1'3'bar1', 7, "Postifix declared looser than prefix");

    sub postfix:<'bar2'> (Int $x) is tighter(&prefix:<'foo1'>){
        return 1 + $x;
    }

    is('foo1'3'bar2', 8, "Postfix declared tighter than prefix");
}

{
    sub postfix:<!> ($n) {
        return [*] 1..$n;
    }

    is( -1!, -1 , "Should be parsed as '-(1!)'");
    dies_ok( { eval '4 !' },  "Whitespace not allowed before user-defined postfix");
}


# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S06-traits/slurpy-is-rw.t�����������������������������������������������������0000664�0001750�0001750�00000000663�12224265625�020451� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 3;

# test splatted parameter for rw ability
# L<S06/"Parameter traits"/"is rw">

my @test = 1..5;
my $test = 42;
lives_ok {
    my sub should_work ( *@list is rw ) {
        @list[0]   = "hi"; 
        @list[*-1] = "ho"; 
    }
    should_work(@test, $test);
}, "trying to use an 'is rw' splat does work out";
is(@test[0], "hi", "@test was changed");
is($test,    "ho", '$test was changed');

# vim: ft=perl6
�����������������������������������������������������������������������������rakudo-2013.12/t/spec/S07-iterators/range-iterator.t������������������������������������������������0000664�0001750�0001750�00000010553�12224265625�021505� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;


{
    my $r = RangeIter.new(1..5);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, 1, '$r.get == 1';
    is $r.get, 2, '$r.get == 2';
    is $r.get, 3, '$r.get == 3';
    is $r.get, 4, '$r.get == 4';
    is $r.get, 5, '$r.get == 5';
    is $r.get, EMPTY, '$r.get is done';
    is $r.get, EMPTY, '$r.get is still done';
}

{
    my $r = RangeIter.new(-1.5.Num..^3);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, -1.5, '$r.get == -1.5';
    is $r.get, -.5, '$r.get == -0.5';
    is $r.get, .5, '$r.get == .5';
    is $r.get, 1.5, '$r.get == 1.5';
    is $r.get, 2.5, '$r.get == 2.5';
    is $r.get, EMPTY, '$r.get is done';
    is $r.get, EMPTY, '$r.get is still done';
}

{
    my $r = RangeIter.new(-1.5..^3);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, -1.5, '$r.get == -1.5';
    is $r.get, -.5, '$r.get == -0.5';
    is $r.get, .5, '$r.get == .5';
    is $r.get, 1.5, '$r.get == 1.5';
    is $r.get, 2.5, '$r.get == 2.5';
    is $r.get, EMPTY, '$r.get is done';
    is $r.get, EMPTY, '$r.get is still done';
}

{
    my $r = RangeIter.new(-1.5.Num^..3);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, -.5, '$r.get == -0.5';
    is $r.get, .5, '$r.get == .5';
    is $r.get, 1.5, '$r.get == 1.5';
    is $r.get, 2.5, '$r.get == 2.5';
    is $r.get, EMPTY, '$r.get is done';
    is $r.get, EMPTY, '$r.get is still done';
}

{
    my $r = RangeIter.new(-1..*);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, -1, '$r.get == -1';
    is $r.get, 0, '$r.get == 0';
    is $r.get, 1, '$r.get == 1';
    is $r.get, 2, '$r.get == 2';
    is $r.get, 3, '$r.get == 3';
    is $r.get, 4, '$r.get == 4';
    is $r.get, 5, '$r.get == 5';
    loop (my $i = 0; $i < 100; $i++) {
        $r.get;  # 6 through 105
    }
    is $r.get, 106, '$r.get == 106';
}

{
    my $r = RangeIter.new(-1.5.Num..*);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, -1.5, '$r.get == -1.5';
    is $r.get, -.5, '$r.get == -0.5';
    is $r.get, .5, '$r.get == .5';
    is $r.get, 1.5, '$r.get == 1.5';
    is $r.get, 2.5, '$r.get == 2.5';
    is $r.get, 3.5, '$r.get == 3.5';
    is $r.get, 4.5, '$r.get == 4.5';
}

{
    my $r = RangeIter.new(-1.5..*);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, -1.5, '$r.get == -1.5';
    is $r.get, -.5, '$r.get == -0.5';
    is $r.get, .5, '$r.get == .5';
    is $r.get, 1.5, '$r.get == 1.5';
    is $r.get, 2.5, '$r.get == 2.5';
    is $r.get, 3.5, '$r.get == 3.5';
    is $r.get, 4.5, '$r.get == 4.5';
}

{
    # Make sure we can read two different RangeIters at the same time.
    # (May sound like an odd test, but as I type this, if Range iteration
    #  were implemented with gather/take, this test would fail.)
    my $r1 = RangeIter.new(-1..*);
    my $r2 = RangeIter.new(42..*);
    isa_ok $r1, RangeIter, '$r1 is a RangeIter';
    isa_ok $r2, RangeIter, '$r2 is a RangeIter';
    is $r1.get, -1, '$r1.get == -1';
    is $r2.get, 42, '$r2.get == 42';
    is $r1.get, 0, '$r1.get == 0';
    is $r2.get, 43, '$r2.get == 43';
    is $r1.get, 1, '$r1.get == 1';
    is $r2.get, 44, '$r2.get == 44';
    is $r1.get, 2, '$r1.get == 2';
    is $r2.get, 45, '$r2.get == 45';
    is $r1.get, 3, '$r1.get == 3';
    is $r2.get, 46, '$r2.get == 46';
    is $r1.get, 4, '$r1.get == 4';
    is $r2.get, 47, '$r2.get == 47';
    is $r1.get, 5, '$r1.get == 5';
    is $r2.get, 48, '$r2.get == 48';
}

{
    my $r = RangeIter.new('d'..'g');
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, 'd', '$r.get == d';
    is $r.get, 'e', '$r.get == e';
    is $r.get, 'f', '$r.get == f';
    is $r.get, 'g', '$r.get == g';
    is $r.get, EMPTY, '$r.get is done';
    is $r.get, EMPTY, '$r.get is still done';
}

{
    my $r = RangeIter.new('d'..*);
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, 'd', '$r.get == d';
    is $r.get, 'e', '$r.get == e';
    is $r.get, 'f', '$r.get == f';
    is $r.get, 'g', '$r.get == g';
    is $r.get, 'h', '$r.get == h';
    is $r.get, 'i', '$r.get == i';
}

{
    my $r = RangeIter.new(0..'50');
    isa_ok $r, RangeIter, '$r is a RangeIter';
    is $r.get, 0, '$r.get == 0';
    is $r.get, 1, '$r.get == 1';
    is $r.get, 2, '$r.get == 2';
    is $r.get, 3, '$r.get == 3';
    is $r.get, 4, '$r.get == 4';
    is $r.get, 5, '$r.get == 5';
    #?rakudo 2 todo "Mixing Int and Str doesn't work yet"
    is $r.get, 6, '$r.get == 6';
    is $r.get, 7, '$r.get == 7';
}

done;
�����������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S09-autovivification/autoincrement.t������������������������������������������0000664�0001750�0001750�00000001226�12224265625�023005� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S09/Autovivification/>

plan 7;

{
  my $foo = 0;
  $foo++;
  is $foo, 1, 'lvalue $var works';
}

{
  my $foo = [0];
  $foo[0]++;
  is $foo[0], 1, 'lvalue $var[] works';
}

{
  my $foo = [[0]];
  $foo[0][0]++;
  is $foo[0][0], 1, 'lvalue $var[][] works';
}

{
  my @foo = [0];
  @foo[0][0]++;
  is @foo[0][0], 1, 'lvalue @var[][] works';
}

{
  is ++[[0]][0][0], 1, 'lvalue [[]][][] works';
}

{
  my $foo = {a => [0]};
  $foo<a>[0]++;
  is $foo<a>[0], 1, 'lvalue $var<>[] works';
}

#?pugs skip "Can't modify constant item: VInt 0"
{
  my %foo = (a => [0]);
  %foo<a>[0]++;
  is %foo<a>[0], 1, 'lvalue %var<>[] works';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S09-autovivification/autovivification.t���������������������������������������0000664�0001750�0001750�00000013521�12227737244�023520� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S09/"Autovivification">

plan 42;

#?niecza todo
#?pugs skip '!exists'
{
  my %hash;
  %hash<a>;
  ok %hash<a>:!exists, 'just mentioning a hash value should not autovivify it';
}

{
  my %hash;

  %hash<key>[42] = 17;
  is %hash<key>[42], 17, "autovivification of a hash element to an arrayref worked";
  is +%hash.keys, 1, 'Created one hash item';
}

# RT #61740
{
  my %hash;

  %hash<key><innerkey> = 17;
  is %hash<key><innerkey>, 17, "autovivification of a hash element to a hashref worked";
  isa_ok %hash<key>, Hash, 'Inner hash item is really a Hash';
}

# Autovification by push, unshift, etc.
# XXX I understand that @array[0].push(...) should autovivify an Array
# in @array[0], but is that also true for a normal scalar?
#?niecza skip 'Unable to resolve method push in class Any'
{
  my $arrayref;

  push $arrayref, 1,2,3;
  is ~$arrayref, "1 2 3", "autovivification to an array by &push";
  isa_ok $arrayref, Array, 'autovivified to Array';
}

#?niecza skip 'Unable to resolve method unshift in class Any'
{
  my $arrayref;

  unshift $arrayref, 1,2,3;
  is ~$arrayref, "1 2 3", "autovivification to an array by &unshift";
}

# Autovification by push, unshift, etc. of an array/hash element
# L<S09/Autovivification/"push, unshift, .[]">
#?niecza skip 'Unable to resolve method push in class Any'
{
  my @array;

  push @array[2], 1,2,3;
  is ~@array, "  1 2 3", "autovivification of an array element to an array by &push";
}

#RT #84000
#?niecza skip 'Unable to resolve method push in class Any'
{
  my %hash;

  push %hash<key>, 1,2,3;
  is ~%hash, "key\t1 2 3", "autovivification of an hash element to an array by &push";
}

# Simple hash autovivification
# Actually, that first test passes, but I can't figure out how to skip just
# the next two.
{
  my $hashref;
  ok $hashref !~~ Hash, "uninitialized variable is not a Hash (1)";

  $hashref<key> = 23;
  is $hashref<key>,  23, "hash element assignment worked";
  #?niecza skip 'No value for parameter \$other in CORE Any.isa'
  #?pugs skip 'isa multi variant'
  #?rakudo skip 'isa multi variant'
  ok $hashref.isa !~~ Hash, "uninitialized variable was autovivified to a hash (1)";
}

{
  my $hashref;
  ok $hashref !~~ Hash, "uninitialized variable is not a Hash (2)";

# Note that 
#    Autovivification will only happen if the *vivifiable* *path* is used as a container
#    ... value extraction does not autovivify.
  lives_ok { my $elem = $hashref<key> },
    "accessing a not existing hash element of an uninitialized variable works";
  #?pugs todo
  ok $hashref !~~ Hash, "uninitialized variable is not autovivified to a hash (2)";

  my $hashref2;
  lives_ok { my $elem2 = $hashref2<key2><a><b><c><d><e><f> },
    "accessing a not existing hash element of an uninitialized variable works (2)";
  #?pugs 2 todo
  ok $hashref2 !~~ Hash, "uninitialized variable is not autovivified to a hash (3)";
  ok $hashref2<key2><a><b><c><d><e> !~~ Hash, "uninitialized variable is not autovivified to a hash (4)";
}

{
  my $hashref;
  ok $hashref !~~ Hash, "uninitialized variable is not a Hash (3)";

  lives_ok { my $elem := $hashref<key> },
    "binding a not existing hash element of an uninitialized variable works";
  #?rakudo todo 'autoviv, binding'
  ok $hashref ~~ Hash, "uninitialized variable is autovivified to a hash (4)";

  lives_ok { my $elem2 := $hashref<key2><a><b><c><d><e><f> },
    "binding a not existing hash element of an uninitialized variable works (2)";
  #?rakudo todo 'autoviv, binding'
  ok $hashref<key2><a><b><c><d><e> ~~ Hash, "uninitialized variable is autovivified to a hash (5)";
}

# Simple array autovivification
{
  my $arrayref;
  ok !$arrayref.isa(Array), "uninitialized variable is not an Array (1)";

  $arrayref[42] = 23;
  ok $arrayref.isa(Array), "uninitialized variable was autovivified to an array (1)";
  is $arrayref[42],    23, "array element assignment worked";
}

{
  my $arrayref;
  ok !$arrayref.isa(Array), "uninitialized variable is not an Array (2)";

# Note that 
#    Autovivification will only happen if the *vivifiable* *path* is used as a container
#    ... value extraction does not autovivify.
  lives_ok { my $elem = $arrayref[42] },
    "accessing a not existing array element of an uninitialized variable works";
  #?pugs todo
  ok !$arrayref.isa(Array), "uninitialized variable was not autovivified to an array (2)";

  my $arrayref2;
  lives_ok { my $elem = $arrayref2[1][2][3][4][5][6] },
    "accessing a not existing array element of an uninitialized variable works";
  #?pugs 2 todo
  ok !$arrayref2.isa(Array), "uninitialized variable was not autovivified to an array (3)";
  ok !$arrayref2[1][2][3][4][5].isa(Array), "uninitialized variable was not autovivified to an array (4)";
}

{
  my $arrayref;
  ok !$arrayref.isa(Array), "uninitialized variable is not an Array (3)";

  lives_ok { my $elem := $arrayref[42] },
    "binding a not existing array element of an uninitialized variable works (1)";
  #?rakudo todo 'unknown'
  ok $arrayref.isa(Array), "uninitialized variable is autovivified to an array (1)";

  lives_ok { my $elem2 := $arrayref[1][2][3][4][5][6] },
    "binding a not existing array element of an uninitialized variable works (2)";
  #?rakudo todo 'unknown'
  ok $arrayref[1][2][3][4][5].isa(Array), "uninitialized variable is autovivified to an array (2)";
}


# Autovivification of an array/hash element
{
  my @array;

  @array[42][23] = 17;
  is @array[42][23], 17, "autovivification of an array element to an arrayref worked";
}

{
  my @array;

  @array[42]<key> = 17;
  is @array[42]<key>, 17, "autovivification of an array element to a hashref worked";
}


lives_ok {
  &New::Package::foo;
  # this is ok, as you don't have to predeclare globally qualified variables
}, "using an undeclared globaly qualified code variable in void context is ok";

dies_ok {
  &New::Package::foo();
}, "...but invoking undeclared globally qualifed code variable should die";

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S09-hashes/objecthash.t�������������������������������������������������������0000664�0001750�0001750�00000005126�12224265625�020135� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 31;

{
    class A { method Str() { 'foo' } };
    my $a = A.new;

    my %h{Any};
    %h{$a} = 'blubb';
    is  %h{$a}, 'blubb', 'Any-typed hash access (+)';
    #?pugs todo
    nok %h{A.new},       'and the hash really uses ===-semantics';
    #?pugs todo
    dies_ok { %h{Mu.new} = 3 }, 'Any-typed hash does not like Mu keys';
    #?pugs todo
    ok %h.keys[0] === $a, 'returned key is correct';
} #4

{
    my %h{Int};
    %h{2} = 3;
    is %h{1 + 1}, 3, 'value-type semantics';
    #?pugs todo
    dies_ok { %h{'foo'} }, 'non-conformant type dies';
} #2

# combinations of typed and objecthash
{ 
    my Int %h{Rat};
    %h{0.5} = 1;
    %h{0.3} = 2;
    #?pugs todo
    dies_ok { %h{2} = 3 },     'key type mismatch';
    #?pugs todo
    dies_ok { %h{0.5} = 0.2 }, 'value type mismatch';
    #?pugs todo
    dies_ok { %h{2} = 0.5 },   'key and value type mismatch';
    #?pugs todo
    is %h.keys.sort.join(','), '0.3,0.5', '.keys';
    #?pugs todo
    is ~%h.values.sort,        '1 2',     '.values';
    #?pugs skip 'flat'
    isa_ok %h.kv.flat[0],      Rat,       '.kv types (1)';
    #?pugs skip 'flat'
    isa_ok %h.kv.flat[1],      Int,       '.kv types (2)';
    #?pugs todo
    isa_ok %h.pairs[0].key,    Rat,       '.pairs.key type';
    isa_ok %h.pairs[0].value,  Int,       '.pairs.value type';
    #?pugs todo
    is %h.elems,               2,         '.elems';
    lives_ok { %h{0.2} := 3 }, 'binding to typed objecthash elements';
    #?pugs todo
    is %h.elems,               3,         'updated .elems';
    #?pugs todo
    dies_ok  { %h{ 3 } := 3 }, 'binding key type check failure';
    #?pugs todo
    dies_ok  { %h{0.2} := 'a' }, 'binding value type check failure';
    dies_ok  { %h.push: 0.5 => 2 },
             'Hash.push fails when the resulting array conflicts with the type check';
    #?pugs todo
    lives_ok { %h.push: 0.9 => 3 }, 'Hash.push without array creation is OK';
    dies_ok  { %h.push: 1 => 3 },   'Hash.push key type check failure';
    dies_ok  { %h.push: 1.1 => 0.2 }, 'Hash.push value type check failure';
} #18

{
    my %h{Any};
    %h = 1, 2;
    #?pugs todo
    ok %h.keys[0] === 1, 'list assignment + object hashes';
} #1

{
    my %h{Mu};
    #?rakudo 6 skip 'oh noes, it dies'
    ok %h{Mu} = 2, "just make the fudging work";
    #?pugs todo
    is %h{Mu}, 2, 'using Mu as a key';
    ok %h{Any} = 3, "just make the fudging work";
    #?pugs todo
    is %h{Any}, 3, 'using Any as a key';
    #?pugs todo
    is %h{ Mu, Any }.join(","), "2,3", 'check slice access on Mu';
    #?pugs todo
    is %h{*}.join(","), "2,3", 'check whatever access with Mu as key';
} #6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S09-subscript/slice.t���������������������������������������������������������0000664�0001750�0001750�00000005060�12237474612�017664� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S09/Subscript and slice notation>
# (Could use an additional smart link)

=begin pod

Testing array slices.

=end pod

plan 26;

{   my @array = (3,7,9,11);

    is(@array[0,1,2], (3,7,9),   "basic slice");
    is(@array[(0,1,2)], (3,7,9), "basic slice, explicit list");

    is(@array[0,0,2,1,1,2], "3 3 9 7 7 9", "basic slice, duplicate indices");

    my @slice = (1,2);

    is(@array[@slice], "7 9",      "slice from array, part 1");
    is(@array[@slice], (7,9),      "slice from array, part 2");
    is(@array[@slice[1]], (9),     "slice from array slice, part 1");
    is(@array[@slice[0,1]], (7,9), "slice from array slice, part 2");
    is(@array[0..1], (3,7),	   "range from array");
    is(@array[0,1..2], (3,7,9),	   "slice plus range from array");
    is(@array[0..1,2,3], (3,7,9,11), "range plus slice from array");    
}

# Behaviour assumed to be the same as Perl 5
{   my @array  = <a b c d>;
    my @slice := @array[1,2];
    is ~(@slice = <A B C D>), "A B",
        "assigning a slice too many items yields a correct return value";
}

# Slices on array literals
{   is ~(<a b c d>[1,2]),   "b c", "slice on array literal";
    is ~([<a b c d>][1,2]), "b c", "slice on arrayref literal";
}

# Calculated slices
{   my @array = (3,7,9);
    my %slice = (0=>3, 1=>7, 2=>9);
    is((3,7,9), [@array[%slice.keys].sort],    "values from hash keys, part 1");
    is((3,7,9), [@array[%slice.keys.sort]],    "values from hash keys, part 2");
    is((3,7,9), [@array[(0,1,1)>>+<<(0,0,1)]], "calculated slice: hyperop");
}


# slices with empty ranges
{
    my @array = 1, 2, 3;
    my @other = @array[2..1];
    is +@other, 0, '@array[2..1] is an empty slice';
}

#?rakudo skip 'RT 61844'
#?niecza skip 'hangs'
{
    eval_lives_ok '(0,1)[ * .. * ]', 'Two Whatever stars slice lives';
    is eval('(0,1)[ * .. * ]'), [0, 1], 'Two Whatever stars slice';
}

# RT #63014
#?pugs skip 'No such subroutine: "&Positional"'
{
    my @array = <1 2 3>;
    isa_ok @array, Array;
    ok @array[0..1] ~~ Positional;

    ok @array[0..0] ~~ Positional, 'slice with one element is a list';
    my $zero = 0;
    ok @array[$zero..$zero] ~~ Positional,
           'slice with one element specified by variables';
}

# RT #108508
{
    my @a1 = 1,2,3,4, 5;
    my @a2 = @a1[2 ..^ @a1];
    my @a3 = @a2[1..^ @a2];
    is @a3.join('|'), '4|5', 'can use 1..^@a for subscripting';
}

# RT #120383
#?pugs   skip 'unexpected ['
#?rakudo skip '#120383'
{
    my @a = 42..50;
    is @a .= [1,2], (43,44), 'did we return right slice';;
    is @a, (43,44), 'did we assign slice ok';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S09-typed-arrays/arrays.t�����������������������������������������������������0000664�0001750�0001750�00000014600�12224265625�020472� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 61;

# L<S09/Typed arrays/>

{
    my Int @x;
    ok @x.VAR.of === Int, '@x.VAR.of of typed array (my Int @x)';
    # RT #77748
    ok @x.WHAT.gist ~~ /Array/, '.WHAT.gist of the type object makes sense';
    lives_ok { @x = 1, 2, 3 }, 'can assign values of the right type';
    lives_ok { @x = 1..3    }, 'can assign range of the right type';
    lives_ok { @x.push: 3, 4}, 'can push values of the right type';
    lives_ok { @x.unshift: 3}, 'can unshift values of the right type';
    lives_ok { @x[0, 2] = 2, 3}, 'can assign values to a slice';
    @x = 2, 3, 4;
    is @x.pop, 4, 'can pop from typed array';
    is @x.unshift(2), [2, 2, 3], 'can unshift from typed array';
} #9

{
    my Int @x;
    ok @x.VAR.of === Int, '@x.VAR.of of typed array (my Int @x)';
    lives_ok { @x = 1, 2, 3 }, 'can assign values of the right type (Int @x)';
    lives_ok { @x = 1..3    }, 'can assign range of the right type (Int @x)';
    lives_ok { @x.push: 3, 4}, 'can push values of the right type (Int @x)';
    lives_ok { @x.unshift: 3}, 'can unshift values of the right type (Int @x)';
    lives_ok { @x[0, 2] = 2, 3}, 'can assign values to a slice (Int @x)';
    @x = 2, 3, 4;
    is @x.pop, 4, 'can pop from typed array (Int @x)';
    is @x.unshift(1), [1, 2, 3], 'can unshift from typed array (Int @x)';
} #8

# initialization 
{
    lives_ok { my Int @x = 1, 2, 3 }, 'initialization of typed array';
    lives_ok { my Int @x = 1 .. 3 }, 'initialization of typed array from range';
} #2

{
    my @x of Int;
    ok @x.VAR.of === Int, '@x.VAR.of of typed array (my @x of Int)';
    lives_ok { @x = 1, 2, 3 }, 'can assign values of the right type (@x of Int)';
    lives_ok { @x = 1..3    }, 'can assign range of the right type (@x of Int)';
    lives_ok { @x.push: 3, 4}, 'can push values of the right type (@x of Int)';
    lives_ok { @x.unshift: 3}, 'can unshift values of the right type (@x of Int)';
    lives_ok { @x[0, 2] = 2, 3}, 'can assign values to a slice (@x of Int)';
    @x = 2, 3, 4;
    is @x.pop, 4, 'can pop from typed array (@x of Int)';
    
    ok @x.unshift, 'can unshift from typed array (@x of Int)';
} #8

{
    my Array @x;
    ok @x.VAR.of === Array, '@x.VAR.of of typed array (my Array @x)';
    dies_ok { @x = 1, 2, 3 }, 'can not assign values of the wrong type';
    dies_ok { @x = 1..3    }, 'can not assign range of the wrong type';
    dies_ok { @x.push: 3, 4}, 'can not push values of the wrong type';
    dies_ok { @x.unshift: 3}, 'can not unshift values of the wrong type';
    dies_ok { @x[0, 2] = 2, 3}, 
            'can not assign values of wrong type to a slice';
    lives_ok { @x = [1, 2], [3, 4] },
             '... but assigning values of the right type is OK';
} #7

{
    my @x of Array;
    ok @x.VAR.of === Array, '@x.VAR.of of typed array (my @x of Array)';
    dies_ok { @x = 1, 2, 3 }, 'can not assign values of the wrong type';
    dies_ok { @x = 1..3    }, 'can not assign range of the wrong type';
    dies_ok { @x.push: 3, 4}, 'can not push values of the wrong type';
    dies_ok { @x.unshift: 3}, 'can not unshift values of the wrong type';
    dies_ok { @x[0, 2] = 2, 3}, 
            'can not assign values of wrong type to a slice';
    lives_ok { @x = [1, 2], [3, 4] },
             '... but assigning values of the right type is OK';
} #7

{
    my Array of Int @x;
    ok @x.VAR.of === Array[Int], 'my Array of Int @x declares a nested array';
    #?rakudo skip "nested typechecks are borked"
    lives_ok { @x = [2, 3], [5, 6] }, 'assignment works';
    #?rakudo todo "nested typechecks are borked"
    lives_ok { @x.push: [8, 9] }, 'pushing works';
    dies_ok  { @x.push: 8 }, 'type constraint is enforced';
    #?rakudo todo "nested typechecks are borked"
    lives_ok { @x[0].push: 3 }, 'pushing to the inner array is OK';
    dies_ok  { @x[0].push: 'foo' }, 'inner array enforces the type constraint';
} #6

# test that lists/arrays returned from array methods are typed as well
{
    my Int @a = 1, 2, 3;
    my Int @b;
    lives_ok { @b = @a }, 'can assign typed array to typed array';
    #?rakudo todo 'need parameterized Lists'
    ok @a.values.VAR.of.WHICH eqv Int.WHICH, '@a.values is typed (1)';
    lives_ok { @b = @a.values }, '@a.values is typed (2)';
} #3

#?rakudo skip 'initialization'
{
    my Str @c = <foo bar baz>;
    ok @c.keys.VAR.of.WHICH eqv Str.WHICH, '@array.keys is typed with Str';
} #1

# test that we can have parametric array return types
{
    sub ret_pos_1 returns Positional of Int { my Int @a = 1,2,3; return @a; }
    sub ret_pos_2 returns Positional of Int { my Int @a = 1,2,3; @a }
    sub ret_pos_3 returns Positional of Int { my @a = 1,2,3; return @a; }
    sub ret_pos_4 returns Positional of Int { my @a = 1,2,3; @a }
    sub ret_pos_5 returns Positional of Int { my Num @a = 1,2,3; return @a; }
    sub ret_pos_6 returns Positional of Int { my Num @a = 1,2,3; @a }
    sub ret_pos_7 returns Positional of Num { my Int @a = 1,2,3; return @a; }
    sub ret_pos_8 returns Positional of Num { my Int @a = 1,2,3; @a }
    lives_ok { ret_pos_1() },
        'type check Positional of Int allows correctly typed array to be returned explicitly';
    lives_ok { ret_pos_2() },
        'type check Positional of Int allows correctly typed array to be returned implicitly';
    dies_ok { ret_pos_3() },
        'type check Positional of Int prevents untyped array to be returned explicitly';
    dies_ok { ret_pos_4() },
        'type check Positional of Int prevents untyped array to be returned implicitly';
    dies_ok { ret_pos_5() },
        'type check Positional of Int prevents incorrectly typed array to be returned explicitly';
    dies_ok { ret_pos_6() },
        'type check Positional of Int prevents incorrectly typed array to be returned implicitly';
    #?rakudo 2 todo "no parametrization"
    lives_ok { ret_pos_7() },
        'type check Positional of Num allows subtyped Int array to be returned explicitly';
    lives_ok { ret_pos_8() },
        'type check Positional of Num allows subtyped Int array to be returned implicitly';
} #8

# RT #69482
#?rakudo skip 'type on our-variables'
{
    our Int @a1;
    our @a2;
    lives_ok { @a2[0] = 'string' },
        'Can assign to untyped package array in presence of typed array';
} #1

# RT 71958
{
    class RT71958 {
        has @.rt71958 is rw;
    }
    my Int @typed_array;
    lives_ok { RT71958.new().rt71958[0] = RT71958.new() },
             'can assign to untyped array in presence of typed array';
} #1

done;

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S09-typed-arrays/hashes.t�����������������������������������������������������0000664�0001750�0001750�00000004555�12224265625�020454� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 30;

# L<S09/Typed arrays>

# while S09 doesn't explicit state it for Hashes, we can assume that
# the same that it says for Arrays hold true.

{
    my Int %h;
    is %h.of,    Int, 'my Int %h declares a Hash of Int';
    is %h.keyof, Any, 'my Int %h declares a Hash with Any keys';
    lives_ok { %h = (a => 3, b => 7) }, 'can assign Ints to an Hash of Int';
    lives_ok { %h<foo> = 8           }, 'can assign Int to hash slot';
    lives_ok { %h{'c', 'd' } = (3, 4) }, 'can assign to slice of typed hash';
    is +%h, 5, '... and we have the right number of items';

    my Int %g;
    lives_ok { %g = %h }, 'can assign one typed hash to another';
    lives_ok { %h.pairs }, 'can call methods on typed hashes';
    is %h.pairs.sort.join, %g.pairs.sort.join, 
                        '... and the hashes are the same afterwards';

    lives_ok { my Int %s = :a(3) }, 'can initialize typed hash';
    my Str %s = :a<b>;
    dies_ok { %h = %s }, "Can't assign Str hash to Int hash";
    dies_ok { %h = :a<b> }, "Can't assign literal Str hash to Int hash";
    dies_ok { %h<a> = 'foo' }, "Can't assign to hash item";
    dies_ok { %h{'a', 'b'} = <c d> }, "prevent mismatched hash slice";
    dies_ok { %h<z><t> = 3 }, 'Type constraint prevents autovivification';
    ok %h<a>:!exists,  'Make sure autovivication did not happen';
} #16

{
    lives_ok { my %s of Int = :a(3) }, 'can initialize typed hash (of Int)';
    dies_ok { my %s of Int = :a("3") }, 'initialization of typed hash type checked (of Int)';
    my %s of Str;
    lives_ok { %s<a> = 'b' }, "Can assign to typed hash element (of Str)";
    dies_ok { %s<a> = 1 }, "Can't assign wrongly typed value to typed hash element (of Int)";
} #4

#?pugs   skip "doesn't know about key constraints"
#?niecza skip "doesn't know about key constraints"
{
    my %h{Int};
    is %h.of,    Any, "check the value constraint";
    is %h.keyof, Int, "check the key constraint";
    dies_ok { %h<a>=1 }, "cannot use strings as keys";
    dies_ok { %h<a b c>=(1,2,3) }, "cannot use string slices as keys";
    lives_ok { %h{1} = "a" }, "can use Ints as keys";
    is %h{1}, 'a', "a did the assignment work";
    lives_ok { %h{(2,3,4)} = <b c d> }, "can use Int slices as keys";
    is %h{2}, 'b', "b did the assignment work";
    is %h{3}, 'c', "b did the assignment work";
    is %h{4}, 'd', "b did the assignment work";
} #10

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/basic.t����������������������������������������������������������0000664�0001750�0001750�00000017310�12224265625�017375� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S10/Packages>

use Test;

plan 59;

my regex fairly_conclusive_platform_error {:i ^\N* <<Null?>>}

my regex likely_perl6_not_found_err {:i ^\N* <<'can'?not>> \N* <<[f[i|ou]nd|located?|access'ed'?]>> }

package Empty {}
package AlsoEmpty::Nested {}

package Simple {
    enum B <a>;
    class Bar {method baz {'hi'}};
    our $forty_two = 42;
}

is Simple::Bar.new.baz, 'hi', 'class test';

#?niecza skip 'AlsoEmpty undeclared (ie no autovivification, I guess)'
{
    is AlsoEmpty.gist, '(AlsoEmpty)',
        'autovivification(?) for nested packages'
}

# RT #65404
#?niecza todo
{
    lives_ok {Empty.perl ne "tbd"}, 'test for working .perl method'
}

# change to match likely error (top of file) when passes
{
    eval_dies_ok 'Empty::no_such_sub()', 'Non-existent sub through package';
}

# Not sure whether you should be able to access something in package this way
# might change to match likely error (top of file) when passes
{
    eval_dies_ok 'Empty.no_such_sub_or_prop',
                 'Non-existent method with package';
}

{
    enum SimpleB <a>; # useful for fudging success
    is Simple::B::a.Numeric, 0, 'enum in package'
}

# more sophisticated variants of test exist elsewhere - but seems basic ...
#?rakudo skip 'RT #59484'
#?niecza skip 'Unable to find lexical $?PACKAGE in pkg'
{
    is  eval('package Simp2 {sub pkg { $?PACKAGE }}; Simp2::pkg'),
        'Simp2', 'access to $?PACKAGE variable'
}

{
    lives_ok {Simple::Bar.new.WHO}, 'some WHO implementation';
    #?rakudo skip 'ticket based only on class... RT #60446'
    #?niecza todo
    is ~(Simple::Bar.new.WHO), 'Simple::Bar',
        'WHO implementation with longname';
}

eval_lives_ok 'package A1 { role B1 {}; class C1 does A1::B1 {}} ',
    'can refer to role using package';

{
    eval_lives_ok '{package A2 { role B2 {}; class C2 does B2 {} }}',
        'since role is in package should not need package name';
}

#?niecza skip 'Exception not defined'
{
    my $x;

    try {  eval '$x = RT64828g; grammar RT64828g {}' };
    ok  $!  ~~ Exception, 'reference to grammar before definition dies';
    ok "$!" ~~ / RT64828g /, 'error message mentions the undefined grammar';

    try { eval '$x = RT64828m; module RT64828m {}' };
    ok  $!  ~~ Exception, 'reference to module before definition dies';
    ok "$!" ~~ / RT64828m /, 'error message mentions the undefined module';

    try { eval '$x = RT64828r; role RT64828r {}' };
    ok  $!  ~~ Exception, 'reference to role before definition dies';
    ok "$!" ~~ / RT64828r /, 'error message mentions the undefined role';

    try { eval '$x = RT64828c; class RT64828c {}' };
    ok  $!  ~~ Exception, 'reference to class before definition dies';
    ok "$!" ~~ / RT64828c /, 'error message mentions the undefined class';

    try { eval '$x = RT64828p; package RT64828p {}' };
    ok  $!  ~~ Exception, 'reference to package before definition dies';
    ok "$!" ~~ / RT64828p /, 'error message mentions the undefined package';
}

#RT #65022
{
    eval_lives_ok '{ package C1Home { class Baz {} }; package C2Home { class Baz {} } }',
        'two different packages should be two different Baz';

    eval_lives_ok '{ package E1Home { enum EHomeE <a> }; package E2Home { role EHomeE {}; class EHomeC does E2Home::EHomeE {} } }',
        'two different packages should be two different EHomeE';        
}

# making test below todo causes trouble right now ...
{
    eval_lives_ok 'package InternalCall { sub foo() { return 42 }; foo() }',
        'call of method defined in package';
}

#?rakudo todo 'RT #64606'
#?niecza todo
{
    eval_lives_ok 'package DoMap {my @a = map { $_ }, (1, 2, 3)}}',
        'map in package';
}

my $outer_lex = 17;
{
    package RetOuterLex { our sub outer_lex_val { $outer_lex } };
    is eval('RetOuterLex::outer_lex_val()'), $outer_lex, 'use outer lexical'
}

our $outer_package = 19;
{
    package RetOuterPack { our sub outer_pack_val { $outer_package } };
    is  eval('RetOuterPack::outer_pack_val()'), $outer_package,
        'use outer package var';

    eval_lives_ok
        'my $outer; package ModOuterPack { $outer= 3 }; $outer',
        'Should be able to update outer package var';
}

# change tests to match likely error (top of file) when they pass (RT 64204)
{
    try { eval 'my $x = ::P' };
    ok  ~$! !~~ /<&fairly_conclusive_platform_error>/, 
        'simple package case that should not blow platform';

    try { eval 'A::B' };
    #?niecza todo
    ok  ~$! ~~ /<&likely_perl6_not_found_err>/,
        'another simple package case that should not blow platform';
}

eval_lives_ok q' module MapTester { (1, 2, 3).map: { $_ } } ', 
              'map works in a module (RT #64606)';

# used to be a  pugs regression
{
    BEGIN { @*INC.push: 't/spec/packages' }
    use ArrayInit;
    my $first_call = array_init();
    is array_init(), $first_call,
       'array initialization works fine in imported subs';
}

# RT #68290
{
    eval_dies_ok q[class A { sub a { say "a" }; sub a { say "a" } }],
                 'sub redefined in class dies';
    eval_dies_ok q[package P { sub p { say "p" }; sub p { say "p" } }],
                 'sub redefined in package dies';
    eval_dies_ok q[module M { sub m { say "m" }; sub m { say "m" } }],
                 'sub redefined in module dies';
    eval_dies_ok q[grammar B { token b { 'b' }; token b { 'b' } };],
                 'token redefined in grammar dies';
    eval_dies_ok q[class C { method c { say "c" }; method c { say "c" } }],
                 'method redefined in class dies';
}

{
    eval_lives_ok 'class RT64688_c1;use Test', 'use after class line';
    eval_lives_ok 'class RT64688_d1 { use Test }', 'use in class block';
    eval_lives_ok 'module RT64688_m1;use Test', 'use after module line';
    eval_lives_ok 'module RT64688_m2 { use Test }', 'use in module block';
    eval_lives_ok 'package RT64688_p2 { use Test }', 'use in package block';
    eval_lives_ok 'grammar RT64688_g1;use Test', 'use after grammar line';
    eval_lives_ok 'grammar RT64688_g2 { use Test }', 'use in grammar block';
    eval_lives_ok 'role RT64688_r1;use Test', 'use after role line';
    eval_lives_ok 'role RT64688_r2 { use Test }', 'use in role block';
}

#?niecza skip 'Export tags NYI'
{
    @*INC.unshift: 't/spec/packages';
    eval_lives_ok 'use LoadFromInsideAModule',
        'can "use" a class inside a module';
    eval_lives_ok 'use LoadFromInsideAClass',
        'can "use" a class inside a class';

    # RT #65738
    use Foo;
    use OverrideTest;
    is test_tc('moin'), 'Moin',
        'overrides from one module do not affect a module that is loaded later on';
}

# also checks RT #73740
#?niecza skip 'Unable to locate module PM6 in @path'
{
    eval_lives_ok 'use PM6', 'can load a module ending in .pm6';
    is eval('use PM6; pm6_works()'), 42, 'can call subs exported from .pm6 module';
}

# package Foo; is perl 5 code;
# RT #75458
{
    eval_dies_ok "package Perl5Code;\n'this is Perl 5 code'",
        'package Foo; is indicator for Perl 5 code';
}

#RT 80856
eval_dies_ok 'module RT80856 is not_RT80856 {}',
             'die if module "is" a nonexistent';

{
    isa_ok Int.WHO, Stash, 'SomeType.WHO is a Stash';
    is Int.WHO.WHAT.gist, '(Stash)', 'and Stash correctly .gist-ifies';
}


# RT #98856
#?niecza todo
eval_lives_ok q[
    package NewFoo { }
    class   NewFoo { }
], 'can re-declare a class over a package of the same name';

# RT #73328
eval_dies_ok q[
    my package A {
        package B;
        1+1;
    }
], 'Too late for semicolon form';

# RT #74592
#?niecza skip 'Nominal type check failed in binding $l in infix:<===>; got My74592, needed Any'
{
    my $p = my package My74592 { };
    ok $p === My74592, 'return value of "my" package declaration';

    $p = our package Our74592 { };
    ok $p === Our74592, 'return value of "Our" package declaration';
}


# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/export.t���������������������������������������������������������0000664�0001750�0001750�00000001462�12224265625�017636� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S11/Exportation>

use Test;

plan 7;

# (Automatic s:g/::/$PATH_SEPARATOR_OF_CUR_OS/)++
use t::spec::packages::Export_PackB;

ok t::spec::packages::Export_PackB::does_export_work(),
  "'is export' works correctly even when not exporting to Main (1)";

# t::spec::packages::Export_PackA::exported_foo should not have been exported into
# our namespace.
dies_ok { exported_foo() },
  "'is export' works correctly even when not exporting to Main (2)";

{
    use t::spec::packages::Export_PackC;
    lives_ok { foo_packc() }, "lexical export works";
}
dies_ok { foo_packc() }, "lexical export is indeed lexical";


sub moose {
    use t::spec::packages::Export_PackD;
    is(this_gets_exported_lexically(), 'moose!', "lexical import survives pad regeneration")
}

moose();
moose();
moose();

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/joined-namespaces.t����������������������������������������������0000664�0001750�0001750�00000000647�12224265625�021706� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push: 't/spec/packages/' }

plan 3;

use Fancy::Utilities;
ok eval('class Fancy { }; 1'), 'can define a class A when module A::B has been used';

eval_lives_ok 'my class A::B { ... }; A::B.new(); class A::B { };',
    'can stub lexical classes with joined namespaces';

# RT #71260
class Outer::Inner { };
dies_ok { eval 'Outer.foo' },
    'can sensibly die when calling method on package';
�����������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/nested-use.t�����������������������������������������������������0000664�0001750�0001750�00000001546�12224265625�020374� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 9;

BEGIN {
   @*INC.unshift('t/spec/packages');
}

lives_ok {
    require Foo;
}, '... we can require Foo';

lives_ok {
    require Bar;
}, '... we can require Bar (which requires Foo)';

lives_ok {
    require FooBar;
}, '... we can require FooBar (which requires Bar (which requires Foo))';

my $foobar = ::FooBar.new();

{
    my $val;
    lives_ok {
        $val = $foobar.foobar()
    }, '... the FooBar::foobar method resolved';
    is($val, 'foobar', '... the FooBar::foobar method resolved');
}

{
    my $val;
    lives_ok {
        $val = $foobar.bar()
    }, '... the Bar::bar method resolved';
    is($val, 'bar', '... the Bar::bar method resolved');
}

{
    my $val;
    lives_ok {
        $val = $foobar.foo()
    }, '... the Foo::foo method resolved';
    is($val, 'foo', '... the Foo::foo method resolved');
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/README�����������������������������������������������������������0000664�0001750�0001750�00000000257�12224265625�017011� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/spec/S10-packages/README

The packages these tests use are stored in t/spec/packages to avoid the use of
a hyphen in the package name, which is not allowed without quoting.
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/require-and-use.t������������������������������������������������0000664�0001750�0001750�00000003113�12224265625�021316� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S11/Runtime Importation>

use Test;

plan 18;
#?pugs emit force_todo 1,2,4,5,7,9,11;

#?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 @tests = (
  "t::spec::packages::RequireAndUse1", { $^a == 42 },
  "t::spec::packages::RequireAndUse2", { $^a != 23 },
  "t::spec::packages::RequireAndUse3", { $^a != 23 },
);

for @tests -> $mod, $expected_ret {

  my @strings = (
    "use $mod",
    "require '{ $mod.split("::").join("/") ~ ".pm" }'",
  );

  for @strings -> $str {
    diag $str;
    my $retval = try { eval $str };

    ok defined($retval) && $retval != -1 && $expected_ret($retval),
      "require or use's return value was correct ({$str})";
    # XXX: Keys of %*INC not yet fully decided (module name? module object?),
    # IIRC.
    ok defined(%*INC{$mod}) && %*INC{$mod} != -1 && $expected_ret(%*INC{$mod}),
      "\%*INC was updated correctly ({$str})";
  }
}

our $loaded   = 0;
our $imported = 0;

eval q{use t::spec::packages::LoadCounter; 1} orelse die "error loading package: $!";
is($loaded,   1, "use loads a module");
is($imported, 1, "use calls &import");

eval q{use t::spec::packages::LoadCounter; 1} orelse die "error loading package: $!";
is($loaded,   1, "a second use doesn't load the module again");
is($imported, 2, "a second use does call &import again");

eval q{no t::spec::packages::LoadCounter; 1} orelse die "error no'ing package: $!";
is($loaded,   1, "&no doesn't load the module again");
is($imported, 1, "&no calls &unimport");


# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S10-packages/scope.t����������������������������������������������������������0000664�0001750�0001750�00000005720�12224265625�017427� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# test that packages work.  Note that the correspondance between type
# objects as obtained via the ::() syntax and packages is only hinted
# at in L<S10/Packages/or use the sigil-like>
plan 23;

# 4 different ways to be imported
# L<S10/Packages/A bare>
{
    package Test1 {
        our sub ns  { "Test1" }
        our sub pkg { $?PACKAGE }
        our sub test1_export is export { "export yourself!" }
    }
    package Test2 {
        our sub ns { "Test2" }
        our sub pkg { $?PACKAGE }
        our $scalar = 42;
    }
    package Test3 {
        our sub pkg { $?PACKAGE }
    }
}

use t::spec::packages::PackageTest;

# test that all the functions are in the right place

# sanity test
# L<S10/Packages/package for Perl>
#?pugs todo "currently appends ()"
is($?PACKAGE, "Main", 'The Main $?PACKAGE was not broken by any declarations');

# block level
is(Test1::ns, "Test1", "block-level package declarations");
cmp_ok(Test1::pkg, &infix:<===>, ::Test1::, 'block-level $?PACKAGE var');
#?pugs todo
dies_ok { eval 'test1_export' }, "export was not imported implicitly";

# declared packages
is(Test2::ns, "Test2", "declared package");
cmp_ok(Test2::pkg, &infix:<===>, ::Test2::, 'declared package $?PACKAGE');

# string eval'ed packages
is(Test3::pkg, ::Test3::, 'eval\'ed package $?PACKAGE');
cmp_ok(Test3::pkg, &infix:<===>, ::Test3::, 'eval\'ed package type object');

# this one came from t/packages/Test.pm
#?pugs todo
is(t::spec::packages::PackageTest::ns, "t::packages::PackageTest", "loaded package");
#?pugs todo
cmp_ok(t::spec::packages::PackageTest::pkg, &infix:<===>, ::t::packages::PackageTest::, 'loaded package $?PACKAGE object');
my $x;
lives_ok { $x = test_export() }, "export was imported successfully";
is($x, "party island", "exported OK");

# exports
dies_ok { ns() }, "no ns() leaked";

# now the lexical / file level packages...
my $pkg;
#?pugs todo 'feature'
dies_ok  { $pkg = Our::Package::pkg },
    "Can't see `our' packages out of scope";
lives_ok { $pkg = t::spec::packages::PackageTest::get_our_pkg() },
    "Package in scope can see `our' package declarations";
is($pkg, Our::Package, 'correct $?PACKAGE');
#?pugs todo 'feature'
ok(!($pkg === ::Our::Package),
   'not the same as global type object');

# oh no, how do we get to that object, then?
# perhaps %t::spec::packages::PackageTest::<Our::Package> ?

#?pugs todo 'feature'
dies_ok { $pkg = t::spec::packages::PackageTest::cant_see_pkg() },
    "can't see package declared out of scope";
lives_ok { $pkg = t::spec::packages::PackageTest::my_pkg() },
    "can see package declared in same scope";
is($pkg, ::My::Package::, 'correct $?PACKAGE');
ok($pkg !=== ::*My::Package::, 'not the same as global type object');

# Check temporization of variables in external packages
{
  {
    #?pugs todo 'bug'
    ok(eval('temp $Test2::scalar; 1'), "parse for temp package vars");
    $Test2::scalar++;
  }
  #?pugs todo 'bug'
  is($Test2::scalar, 42, 'temporization of external package variables');
}

# vim: ft=perl6
������������������������������������������������rakudo-2013.12/t/spec/S10-packages/use-with-class.t�������������������������������������������������0000664�0001750�0001750�00000002260�12237474612�021164� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use MONKEY_TYPING;

use Test;

# L<S11/Compile-time Importation>

plan 9;

# test that 'use' imports class names defined in importet packages

use t::spec::packages::UseTest;

ok Stupid::Class.new(), 'can instantiate object of "imported" class';

{
    my $o = Stupid::Class.new(attrib => 'a');
    is $o.attrib, 'a', 'can access attribute';
    is $o.getter, 'a', 'can access method';
    $o.setter('b');
    is $o.attrib, 'b', 'can set through setter';
    lives_ok { $o.attrib = 'c' }, 'can set trough assignment';
    is $o.attrib, 'c', 'setting actually worked';
}

{
    augment class Stupid::Class {
        method double { $.attrib ~ $.attrib };
    }
    my $o = Stupid::Class.new( attrib => 'd' );
    is $o.double, 'dd', 'can extend "imported" class';

}

# class loading inside a method
# RT #73886
{
    BEGIN { @*INC.unshift: 't/spec/packages' }
    class MethodLoadingTest {
        method doit {
            use Foo;
            Foo.new.foo();
        }
    }
    is MethodLoadingTest.doit(), 'foo', 'can load class from inside a method';

}

# RT #73910
{
    use Foo;
    lives_ok { class Bar { } }, 'declaring a class after use-ing a module (RT #73910)'
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/export.t����������������������������������������������������������0000664�0001750�0001750�00000010315�12224265625�017526� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 36;

# L<S11/"Exportation"/>

sub exp_no_parens    is export                   { 'r_exp_no_parens' }
sub exp_empty_parens is export()                 { 'r_exp_empty_parens' }
sub exp_ALL          is export( :ALL )           { 'r_exp_ALL' }
sub exp_DEFAULT      is export( :DEFAULT )       { 'r_exp_DEFAULT' }
sub exp_ALL_DEFAULT  is export( :ALL, :DEFAULT ) { 'r_exp_ALL_DEFAULT' }
sub exp_MANDATORY    is export( :MANDATORY )     { 'r_exp_MANDATORY' }
sub exp_my_tag       is export( :my_tag )        { 'r_exp_my_tag' }


##  exp_no_parens
is( exp_no_parens(), 'r_exp_no_parens',
    'exp_no_parens() is defined' );
is( EXPORT::ALL::exp_no_parens(), 'r_exp_no_parens',
    'EXPORT::ALL::exp_no_parens() is defined' );

ok( &exp_no_parens === &EXPORT::ALL::exp_no_parens,
    'exp_no_parens -- values agree' );
ok( &exp_no_parens =:= &EXPORT::ALL::exp_no_parens,
    'exp_no_parens -- containers agree' );


##  exp_empty_parens
ok( &exp_empty_parens === &EXPORT::ALL::exp_empty_parens,
    'exp_empty_parens -- values agree' );
ok( &exp_empty_parens =:= &EXPORT::ALL::exp_empty_parens,
    'exp_empty_parens -- containers agree' );


##  exp_ALL
ok( &exp_ALL === &EXPORT::ALL::exp_ALL,
    'exp_ALL -- values agree' );
ok( &exp_ALL =:= &EXPORT::ALL::exp_ALL,
    'exp_ALL -- containers agree' );


##  exp_DEFAULT
ok( &exp_DEFAULT === &EXPORT::ALL::exp_DEFAULT,
    'exp_DEFAULT -- values agree' );
ok( &exp_DEFAULT =:= &EXPORT::ALL::exp_DEFAULT,
    'exp_DEFAULT -- containers agree' );

ok( &exp_DEFAULT === &EXPORT::DEFAULT::exp_DEFAULT,
    'exp_DEFAULT -- values agree' );
ok( &exp_DEFAULT =:= &EXPORT::DEFAULT::exp_DEFAULT,
    'exp_DEFAULT -- containers agree' );


##  exp_ALL_DEFAULT
ok( &exp_ALL_DEFAULT === &EXPORT::ALL::exp_ALL_DEFAULT,
    'exp_ALL_DEFAULT -- values agree' );
ok( &exp_ALL_DEFAULT =:= &EXPORT::ALL::exp_ALL_DEFAULT,
    'exp_ALL_DEFAULT -- containers agree' );

ok( &exp_ALL_DEFAULT === &EXPORT::DEFAULT::exp_ALL_DEFAULT,
    'exp_ALL_DEFAULT -- values agree' );
ok( &exp_ALL_DEFAULT =:= &EXPORT::DEFAULT::exp_ALL_DEFAULT,
    'exp_ALL_DEFAULT -- containers agree' );


##  exp_MANDATORY
ok( &exp_MANDATORY === &EXPORT::ALL::exp_MANDATORY,
    'exp_MANDATORY -- values agree' );
ok( &exp_MANDATORY =:= &EXPORT::ALL::exp_MANDATORY,
    'exp_MANDATORY -- containers agree' );

ok( &exp_MANDATORY === &EXPORT::MANDATORY::exp_MANDATORY,
    'exp_MANDATORY -- values agree' );
ok( &exp_MANDATORY =:= &EXPORT::MANDATORY::exp_MANDATORY,
    'exp_MANDATORY -- containers agree' );

ok( ! &EXPORT::DEFAULT::exp_MANDATORY,
    'exp_MANDATORY -- EXPORT::DEFAULT::exp_MANDATORY does not exist' );


##  exp_my_tag
ok( &exp_my_tag === &EXPORT::ALL::exp_my_tag,
    'exp_my_tag -- values agree' );
ok( &exp_my_tag =:= &EXPORT::ALL::exp_my_tag,
    'exp_my_tag -- containers agree' );

ok( &exp_my_tag === &EXPORT::my_tag::exp_my_tag,
    'exp_my_tag -- values agree' );
ok( &exp_my_tag =:= &EXPORT::my_tag::exp_my_tag,
    'exp_my_tag -- containers agree' );

ok( ! &EXPORT::DEFAULT::exp_my_tag,
    'exp_my_tag -- EXPORT::DEFAULT::exp_my_tag does not exist' );


{
    package Foo {
        sub Foo_exp_parens is export()  { 'r_Foo_exp_parens' }
    }

    ##  make sure each side isn't undefined
    is( Foo::Foo_exp_parens(), 'r_Foo_exp_parens',
        'Foo_exp_parens() is defined' );
    is( Foo::Foo_exp_parens, 'r_Foo_exp_parens',
        'Can call Foo_exp_parens (without parens)' );
    is( Foo::Foo_exp_parens.(), 'r_Foo_exp_parens',
        'Can call Foo_exp_parens.()' );
    is( Foo::EXPORT::ALL::Foo_exp_parens(), 'r_Foo_exp_parens',
        'Foo_exp_parens() is defined' );

    ok( &Foo::Foo_exp_parens === &Foo::EXPORT::ALL::Foo_exp_parens,
        'Foo_exp_parens() -- values agree' );
    ok( &Foo::Foo_exp_parens =:= &Foo::EXPORT::ALL::Foo_exp_parens,
        'Foo_exp_parens() -- containers agree' );
}

{
    class Bar {
        multi method bar ($baz = 'default') is export {
            return $baz;
        };
    }

    my $a = Bar.new;
    is($a.bar, "default", '$a.bar gets default value');
    is($a.bar("sixties"), "sixties", '$a.bar() gets passed value');
    is(Bar::bar($a), "default", 'Bar::bar($a) gets default value');
    is(Bar::bar($a, "moonlight"), "moonlight", 'Bar::bar($a, ) gets default value');
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/importing.t�������������������������������������������������������0000664�0001750�0001750�00000003155�12224265625�020221� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 16;

# L<S11/"Compile-time Importation"/>

{
    use t::spec::packages::S11-modules::Foo;

    ok( &foo, 'Foo::foo is defined (explicitly :DEFAULT)' );
    is( foo(), 'Foo::foo', 'Foo::foo is the sub we expect' );

    ok( &bar, 'Foo::bar is defined (explicitly :DEFAULT and :others)' );
    is( bar(), 'Foo::bar', 'Foo::bar is the sub we expect' );

    ok( &baz, 'Foo::baz is defined (:MANDATORY)' );
    is( baz(), 'Foo::baz', 'Foo::baz is the sub we expect' );

    ok( &bop, 'Foo::bop is defined (implicitly :DEFAULT)' );
    is( bop(), 'Foo::bop', 'Foo::bop is the sub we expect' );

    multi waz($x) { 'Foo::wazhere' }   #OK not used
    #?pugs skip 'Cannot cast from VUndef to VCode'
    ok( &waz, 'Foo::waz multi is defined (implicitly :DEFAULT)' );
    is( waz(), 'Foo::waz', 'Foo::waz is the sub we expect' );
    is( waz(1), 'Foo::wazhere', 'Foo::waz imported does not wipe out our other waz multis' );

    #?pugs todo
    dies_ok { eval 'qux()' }, 'qux() not imported';
    #?pugs todo
    dies_ok { eval 'gaz()' }, 'gaz() not imported';
}

#?pugs skip 'Undeclared variable'
dies_ok( { eval '&foo' }, 'Foo::foo is undefined in outer scope' );

#?pugs todo
{
    BEGIN { @*INC.push('t/spec/packages') };
    class TestImportInClass {
        use A::B;
        method doit {
            A::B::D.new();
        }
    }
    lives_ok { TestImportInClass.doit() },
             "can instantiate class that's loaded from inside another class";

}

#?pugs todo
eval_dies_ok 'use t::spec::packages::S11-modules::Foo :NoSucTag;',
             'die while trying to import a non-existent export tag';

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/import-multi.t����������������������������������������������������0000664�0001750�0001750�00000006436�12224265625�020660� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;

plan 19;

# L<S11/Importing without loading>

# without protos
{
    module A {
        multi sub Afoo( Int $a ) is export { 'sub A::Afoo Int' };
        multi sub Abar( Int $a )           { 'sub A::Abar Int' };
    }
    import A;

    is Afoo( 7 ), 'sub A::Afoo Int', 'A) merge multis without protos';
    dies_ok { eval 'Abar( 7 )' },    "A) doesn't import non-exported multis";
    dies_ok { eval 'Afoo( "a" )' },  "A) doesn't dispatch to wrong signature";
}

# with proto in module
{
    module B {
        proto sub Bfoo( Mu )     is export { * };
        multi sub Bfoo( Int $a ) is export { 'sub B::Bfoo Int' };
    }
    import B;

    is Bfoo( 7 ), 'sub B::Bfoo Int', 'B) merge multis with proto in module';
}

# with proto before import
{
    proto sub Cfoo( Mu ) { * };
    multi sub Cfoo( Str $a ) { 'sub C::Cfoo Str' };
    module C {
        multi sub Cfoo( Int $a ) is export { 'sub C::Cfoo Int' };
    }
    import C;

    is Cfoo( 7 ),   'sub C::Cfoo Int', 'C) merge multis with proto before import';
    is Cfoo( 'a' ), 'sub C::Cfoo Str', 'C) our multi is still there';
}

# with proto after import
{
    module D {
        multi sub Dfoo( Int $a ) is export { 'sub D::Dfoo Int' };
    }
    import D;
    #?rakudo todo "huh?"
    throws_like 'proto sub Dfoo( Mu ) { * }', X::Redeclaration, symbol => 'Dfoo';

    multi sub Dfoo( Str $a ) { 'sub D::Dfoo Str' };

    is Dfoo( 7 ),   'sub D::Dfoo Int', 'D) merge multis with proto after import';
    is Dfoo( 'a' ), 'sub D::Dfoo Str', 'D) our multi is still there';
}

# with proto before import and in module
{
    proto sub Efoo( Mu ) { * };
    multi sub Efoo( Str $a ) { 'sub E::Efoo Str' };
    module E {
        proto sub Efoo( Mu )     is export { * };
        multi sub Efoo( Int $a ) is export { 'sub E::Efoo Int' };
    }
    import E;

    is Efoo( 7 ),   'sub E::Efoo Int', 'E) merge multis with proto before import and in module';
    is Efoo( 'a' ), 'sub E::Efoo Str', 'E) our multi is still there';
}

# with proto after import and in module
{
    module F {
        proto sub Ffoo( Mu )     is export { * };
        multi sub Ffoo( Int $a ) is export { 'sub F::Ffoo Int' };
    }
    import F;
    #?rakudo skip "it just dies, can't check using throws_like"
    throws_like 'proto sub Ffoo( Mu ) { * }', X::Redeclaration, symbol => 'Ffoo';
    multi sub Ffoo( Str $a ) { 'sub F::Ffoo Str' };

    is Ffoo( 7 ),   'sub F::Ffoo Int', 'F) merge multis with proto after import and in module';
    is Ffoo( 'a' ), 'sub F::Ffoo Str', 'F) our multi is still there';
}

#?rakudo skip 'A symbol "&Gfoo" has already been exported'
{
    module G1 {
        multi sub Gfoo( Int $a ) is export { 'sub G1::Gfoo Int' };
    }
    import G1;

    module G2 {
        multi sub Gfoo( Str $a ) is export { 'sub G2::Gfoo Str' };
    }
    import G2;

    is Gfoo( 7 ), 'sub G::Gfoo', 'G) merge multis';
}

# trait_mod:<is>
{
    role Awesome-Things { };
    multi trait_mod:<is> ( Routine $r, :$awesome! ) { $r does Awesome-Things };

    module H {
        sub Hfoo is awesome is export {
            'sub H::Hfoo'
        };
    }
    import H;

    ok &Hfoo ~~ Awesome-Things, 'H) trait "is awesome" applied';
    is Hfoo(), 'sub H::Hfoo',   'H) standard traits like "is export" still work';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/import.t����������������������������������������������������������0000664�0001750�0001750�00000004172�12224265625�017523� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 14;

# L<S11/Importing without loading>

# TODO: add tagged import testing

{
    module A {
        sub Afoo() is export { 'sub A::Afoo' };
        sub Abar()           { 'sub A::Abar' };
        constant pub is export = 42;
        constant priv          = 23;
    }
    import A;

    is Afoo(), 'sub A::Afoo', 'import imports things marked as "is export"';
    dies_ok {eval(q{ Abar() })}, "doesn't import non-exported routines";
    # RT #114246
    is pub, 42, 'can import constants';
    dies_ok { eval 'priv' }, 'cannot access non-exported constants';
}

#?rakudo skip 'import plus inline module'
{
    import (module B {
        sub Bfoo() is export { 'sub B::Bfoo' };
        sub Bbar()           { 'sub B::Bbar' };
    });

    is Bfoo(), 'sub B::Bfoo', 'impporting from inline module';
    dies_ok {eval(q{ Bbar() })}, "not importing not-exported routines";
}

{
    module C {
        sub Cfoo() is export { 'sub C::Cfoo' };
        sub Cbar() is export { 'sub C::Cbar' };
    }
    import C;

    is Cfoo(), 'sub C::Cfoo',
       'import imports things implicitly from named module';
    is Cbar(), 'sub C::Cbar',
       'import imports more things implicitly from named module';
}

#?rakudo skip 'import plus inline module'
{
    import (module D {
        sub Dfoo() is export { 'sub D::Dfoo' };
        sub Dbar() is export { 'sub D::Dbar' };
    });

    is Dfoo(), 'sub D::Dfoo',
       'import imports things implicitly from inlined module';
    is Dbar(), 'sub D::Dbar',
       'import imports more things implicitly from inlined module';
}

{
    module E {
        sub e1 is export(:A) { 'E::e1' }
        sub e2 is export(:B) { 'E::e2' }
    }
    import E :B;
    dies_ok { eval 'e1' }, 'importing by tag is sufficiently selective';
    is e2(), 'E::e2',      'importing by tag';
    {
        import E :ALL;
        is e1() ~ e2(), 'E::e1E::e2', 'import :ALL';
    }
}

# RT #118965 - multiple overlapping imports should not bomb

{
    module F {
        sub f1() is export(:here, :there) { 42 };
    }
    import F :here, :there;
    is f1(), 42, 'can import the same symbol through multiple tags';

}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/import-tag.t������������������������������������������������������0000664�0001750�0001750�00000001602�12224265625�020267� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

# L<S11/"Compile-time Importation"/>

{
    use t::spec::packages::S11-modules::Foo :others;

    dies_ok { eval 'foo()' }, 'foo() not imported - not tagged :others';

    ok( &bar, 'Foo::bar is defined (explicitly :DEFAULT and :others)' );
    is( bar(), 'Foo::bar', 'Foo::bar is the sub we expect' );

    ok( &baz, 'Foo::baz is defined (:MANDATORY)' );
    is( baz(), 'Foo::baz', 'Foo::baz is the sub we expect' );

    dies_ok { eval 'bop()' }, 'bop() not imported';

    ok( &qux, 'Foo::qux is defined (explicitly :others)' );
    is( qux(), 'Foo::qux', 'Foo::qux is the sub we expect' );

    dies_ok { eval 'waz()' }, 'waz() not imported';

    ok( &gaz, 'Foo::gaz multi is defined (implicitly :others)' );
    is( gaz(), 'Foo::gaz1', 'Foo::gaz is the sub we expect' );
    is( gaz(1), 'Foo::gaz2', 'Foo::gaz($x) is the sub we expect' );
    
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/InnerModule.pm����������������������������������������������������0000664�0001750�0001750�00000000350�12224265625�020575� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module InnerModule;
use v6;

sub foo is export(:DEFAULT) {'Inner::foo'}
sub bar is export {'Inner::bar'}
sub baz is export(:MANDATORY) {'Inner::baz'}
# sub qux is export(:sometag) {'Inner::qux'}
sub quux is export { 'Inner::quux' }
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/lexical.t���������������������������������������������������������0000664�0001750�0001750�00000000557�12224265625�017635� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 2;

# can't  use eval_lives_ok or eval_dies_ok here, because it runs
# the eval() in a different lexical scope, thus never finding lexical
# imports.

{
    use t::spec::packages::S11-modules::Foo;
    is foo(), 'Foo::foo', 'could import foo()';
}
dies_ok {eval('foo()') }, 'sub is only imported into the inner lexical scope';

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/module-file.t�����������������������������������������������������0000664�0001750�0001750�00000000465�12224265625�020414� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module Foo::Bar;
use v6;
use Test;

# L<S11/"Modules"/There are two basic declaration syntaxes>

plan 3;

is($?PACKAGE, 'Foo::Bar', '$?PACKAGE for "module Foo::Bar;"');
is($?CLASS,   'Main',     '$?CLASS for "module Foo::Bar;"');
is($?MODULE,  'Foo::Bar', '$?MODULE for "module Foo::Bar;"');

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/module.t����������������������������������������������������������0000664�0001750�0001750�00000001144�12224265625�017472� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S11/"Modules"/"There are two basic declaration syntaxes:">

plan 7;

is($?MODULE, 'Main', '$?MODULE for main module');

module Foo {
    is($?PACKAGE, 'Foo',  '$?PACKAGE for "module Foo {}"');
    is($?CLASS,   'Main', '$?CLASS unchanged for "module Foo {}"');
    is($?MODULE,  'Foo',  '$?MODULE for "module Foo {}"');

    module Bar {
        is($?PACKAGE, 'Foo::Bar', '$?PACKAGE for "module Foo::Bar {}"');
        is($?CLASS,   'Main',     '$?CLASS unchanged for "module Foo::Bar {}"');
        is($?MODULE,  'Foo::Bar', '$?MODULE for "module Foo::Bar {}"');
    }
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/need.t������������������������������������������������������������0000664�0001750�0001750�00000000433�12224265625�017120� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;
plan 2;

{
    need t::spec::packages::Export_PackA;

    is t::spec::packages::Export_PackA::exported_foo(),
       42, 'Can "need" a module';
    eval_dies_ok 'exported_foo()',
                 '"need" did not import the default export list';
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/nested.t����������������������������������������������������������0000664�0001750�0001750�00000001347�12224265625�017474� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 6;

# test that classes and roles declared in modules get into the correct
# namespace

# Used to be a Rakudo bug, RT #63956

BEGIN { @*INC.unshift('t/spec/packages/') };

eval_lives_ok 'use A::A', 'Can load classes from nested modules';
eval_lives_ok 'use A::A; A::B::D ~~ A::B::B or die()', 
              '... and the composition worked';
eval_lives_ok 'use A::A; A::B::D.new()',
              '... and instantiation works';

eval_lives_ok 'use A; A.new()', 'RT 62162';

eval_lives_ok 'use RoleA',
              'can use multiple "Role $name" statements (in multiple files) RT 67976';

{
    use RoleA;
    role RoleB {...}

    class MyFu does RoleB {}
    ok MyFu ~~ RoleB, 'Composition worked';
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/OuterModule.pm����������������������������������������������������0000664�0001750�0001750�00000000073�12224265625�020622� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������module OuterModule;
use v6;

use InnerModule :ALL :EXPORT;
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/re-export.t�������������������������������������������������������0000664�0001750�0001750�00000000706�12224265625�020135� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 8;

# L<S11/"Compile-time Importation"/"In the absence of a specific scoping specified by the caller">

use OuterModule :ALL;

is(foo(), 'Inner::foo', 're-exporting works using is export(:DEFAULT)');
is(bar(), 'Inner::bar', 're-exporting works using is export');
is(baz(), 'Inner::baz', 're-exporting works using is export(:MANDATORY)');
# is(qux(), 'Inner::qux', 're-exporting works using is export(:sometag)');

# vim: ft=perl6
����������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/require.t���������������������������������������������������������0000664�0001750�0001750�00000004670�12224265625�017670� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 13;

# L<S11/"Runtime Importation"/"Alternately, a filename may be mentioned directly">

lives_ok { require "t/spec/S11-modules/InnerModule.pm"; },
         'can load InnerModule from a path at run time';
#?pugs skip 'parsefail'
is GLOBAL::InnerModule::EXPORT::DEFAULT::<&bar>(), 'Inner::bar', 'can call our-sub from required module';

my $name = 't/spec/S11-modules/InnerModule.pm';

#?rakudo todo 'variable form plus imports NYI'
#?pugs 2 skip "parsefail"
lives_ok { require $name '&bar'; },
         'can load InnerModule from a variable at run time';
is GLOBAL::InnerModule::EXPORT::DEFAULT::<&bar>(), 'Inner::bar', 'can call our-sub from required module';

# L<S11/"Runtime Importation"/"To specify both a module name and a filename, use a colonpair">
#?pugs skip "parsefail"
{
    require InnerModule:file($name) <&bar>;
    is bar(), 'Inner::bar', 'can load InnerModule by name and path, with import list';
}

#RT #118407
#?rakudo skip "Trying to import from 'InnerModule', but the following symbols are missing: quux"
#?pugs skip 'parsefail'
{ 
    require InnerModule:file($name) <quux>;
    is quux(), 'Inner::quux', "can import quux without ampersand (&quux)";
}

# no need to do that at compile time, since require() really is run time
@*INC.unshift: 't/spec/packages';

# Next line is for final test.
#?pugs emit #
GLOBAL::<$x> = 'still here';

lives_ok { require Fancy::Utilities; },
         'can load Fancy::Utilities at run time';
is Fancy::Utilities::lolgreet('me'),
   'O HAI ME', 'can call our-sub from required module';

# L<S11/"Runtime Importation"/"It is also possible to specify the module name indirectly by string">
#?pugs todo
lives_ok { my $name = 'A'; require ::($name) }, 'can require with variable name';

#?pugs skip 'Must only use named arguments to new() constructor'
{
    require ::('Fancy::Utilities');
    is ::('Fancy::Utilities')::('&lolgreet')('tester'), "O HAI TESTER",
       'can call subroutines in a module by name';
}

# L<S11/"Runtime Importation"/"Importing via require also installs names into the current lexical scope">

#?pugs skip 'NYI'
{
    require Fancy::Utilities <&allgreet>;
    is allgreet(), 'hi all', 'require with import list';
}

#?pugs skip 'parsefail'
is GLOBAL::<$x>, 'still here', 'loading modules does not clobber GLOBAL';

# tests the combination of chdir+require
lives_ok { chdir "t/spec/packages"; require "Foo.pm"; },
         'can change directory and require a module';

# vim: ft=perl6
������������������������������������������������������������������������rakudo-2013.12/t/spec/S11-modules/use-perl-6.t������������������������������������������������������0000664�0001750�0001750�00000000251�12224265625�020102� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S11/Versioning/which is short for>

use Perl:ver<6.*>;
use Test;

plan 1;
ok "'use Perl:ver<6.*>' works (and means the same as 'use v6')";

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/augment-and-initialization.t�����������������������������������0000664�0001750�0001750�00000002462�12224265625�024155� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;



use Test;


# These tests are not specified by p6l, But these should be right...
# L<S12/"Attributes">

plan 8;

diag('Test for class attribute initialization');


{
	class T1 { }
	class T2 { }
        #?niecza todo
	eval_lives_ok 'use MONKEY_TYPING; augment class T1 { has $.t = 1 }; 1',
		"Try to initialize public attribute";

        #?niecza todo
        eval_lives_ok q'
		use MONKEY_TYPING;
		augment class T2 {
		    has $!t = 2;
		    method get { $!t };
		}; 1 }',
		"Try to initialize private attribute";


	my T1 $o1;
	my T2 $o2;

	$o1 = T1.new();
	$o2 = T2.new();
        #?niecza skip 'Unable to resolve method t in class T1'
	is $o1.t, 1,
		"Testing value for initialized public attribute.";
	dies_ok { $o2.t },
		"Try to access the initialized private attribute.";
        #?niecza todo
	is try { $o2.get }, 2,
		"Testing value for initialized private attribue.";

	$o1 = T1.new( t => 3 );
	$o2 = T2.new( t => 4 );
        #?niecza skip 'Unable to resolve method t in class T1'
	is $o1.t, 3,
		"Testing value for attributes which is initialized by constructor.";
	dies_ok { $o2.t },
		"Try to access the private attribute which is initialized by constructor.";
        #?niecza todo
	is try { $o2.get }, 4,
		"Testing value for private attribue which is initialized by constructor.";
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/class.t��������������������������������������������������������0000664�0001750�0001750�00000006226�12224265625�020037� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Class Attributes

=end pod

#L<S12/Class attributes/"Class attributes are declared">
#L<S12/Class methods/Such a metaclass method is always delegated>

plan 25;

class Foo {
    our $.bar = 23;
    our $.yada = 13;
} 

my $test = 0;
ok ($test = Foo.bar), 'accessors for class attributes work';
is $test, 23, 'class attributes really work';

class Baz is Foo {};

my $test2 = 0;
lives_ok { $test2 = Baz.bar }, 'inherited class attribute accessors work';
is $test2, 23, 'inherited class attributes really work';

my $test3 = 0;
lives_ok { Baz.yada = 42; $test3 = Baz.yada }, 'inherited rw class attribute accessors work';
is $test3, 42, 'inherited rw class attributes really work';

class Quux is Foo { has $.bar = 17; };

my $test4 = 0;
#?pugs 99 todo 'class attributes'
lives_ok { $test4 = Quux.new() },
    'Can instantiate with overridden instance method';
is $test4.bar, 17, 'Instance call gets instance attribute, not class attribute';
my $test5 = 0;
dies_ok {$test5 = Quux.bar}, 'class attribute accessor hidden by accessor in subclass; we do not magically ignore it';

# L<S12/Class methods/"you can associate a method with the current
# metaclass instance">

#?niecza skip 'method ^foo'
{
    class T1 {
        our $c = 0;
        method ^count($obj) {   #OK not used
            return $c;
        }
        method mi { ++$c };
        method md { --$c };
    }

    my ($a, $b, $c) = map { T1.new() }, 1..3;
    is $c.mi,       1, 'can increment class variable in instance method';
    is $b.mi,       2, '.. and the class variable is really shared';
    #?rakudo 6 skip 'nom regression - method ^foo'
    is $a.count,    2, 'can call the class method on an object';
    is T1.count,    2, '... and on the proto object';
    is T1.^count,   2, '... and on the proto object with Class.^method';
    is $a.^count,   2, '... and $obj.^method';
    is T1.HOW.count(T1), 2, '... and by explicitly using .HOW with proto object';
    is $a.HOW.count($a), 2, '... and by explicitly using .HOW with instance';

}

{
    class Oof {
        my $.x;
    }
    my $x = Oof.new();
    $x.x = 42;
    is($x.x, 42, "class attribute accessors work");
    my $y = Oof.new();
    is($y.x, 42, "class attributes shared by all instances");
}

# RT #57336
#?niecza skip 'Exception'
{
    # TODO: Test that the exceptions thrown here are the right ones
    #       and not the result of some other bug.

    my $bad_code;

    $bad_code = '$.a';
    try eval $bad_code;
    ok $! ~~ Exception, "bad code: '$bad_code'";

    $bad_code ='$!a';
    try eval $bad_code;
    ok $! ~~ Exception, "bad code: '$bad_code'";
    
    $bad_code = 'class B0rk { has $.a; say $.a; }';
    try eval $bad_code;
    ok $! ~~ Exception, "bad code: '$bad_code'";
    
    $bad_code = 'class Chef { my $.a; say $.a; }';
    try eval $bad_code;
    ok $! ~~ Exception, "bad code: '$bad_code'";
}

#?niecza skip "Two definitions of method b"
{
    class A { 
        has $.b = 1; 
        method b() { 2; } 
    };
    is A.new.b, 2, "don't create accessor if the class declares an explicit method of that name";


    role B { 
        has $.b = 1; 
        method b() { 2; } 
    };
    is B.new.b, 2;
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/clone.t��������������������������������������������������������0000664�0001750�0001750�00000012043�12224265625�020024� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 34;

# L<S12/Cloning/You can clone an object, changing some of the attributes:>
class Foo { 
    has $.attr; 
    method set_attr ($attr) { $.attr = $attr; }
    method get_attr () { $.attr }
}

my $a = Foo.new(:attr(13));
isa_ok($a, Foo);
is($a.get_attr(), 13, '... got the right attr value');

my $c = $a.clone();
isa_ok($c, Foo);
is($c.get_attr(), 13, '... cloned object retained attr value');

my $val;
lives_ok {
    $val = $c === $a;
}, "... cloned object isn't identity equal to the original object";
ok($val.defined && !$val, "... cloned object isn't identity equal to the original object");

my $d;
lives_ok {
    $d = $a.clone(attr => 42)
}, '... cloning with supplying a new attribute value';

my $val2;
lives_ok {
   $val2 = $d.get_attr()
}, '... getting attr from cloned value';
is($val2, 42, '... cloned object has proper attr value');

# Test to cover RT#62828, which exposed a bad interaction between while loops
# and cloning.
#?pugs skip "Cannot 'shift' scalar"
{
    class A {
        has $.b;
    };
    while shift [A.new( :b(0) )] -> $a {
        is($a.b, 0, 'sanity before clone');
        my $x = $a.clone( :b($a.b + 1) );
        is($a.b, 0, 'clone did not change value in original object');
        is($x.b, 1, 'however, in the clone it was changed');
        last;
    }
}

# RT 88254
#?pugs todo
#?niecza todo "Exception: Representation P6cursor does not support cloning"
{
    my ($p, $q);
    $p = 'a' ~~ /$<foo>='a'/;
    
    # previously it was timeout on Rakudo
    lives_ok { $q = $p.clone }, 'Match object can be cloned';
    
    is ~$q{'foo'}, 'a', 'cloned Match object retained named capture value';
}

# test cloning of array and hash attributes
{
    # array
    my class ArrTest {
        has @.array;
    }

    # hash
    my class HshTest {
        has %.hash;
    }

    # when cloning with new versions of attributes, it should not update the original
    my $a1 = ArrTest.new(:array<a b>);
    my $a2 = $a1.clone(:array<c d>);
    #?rakudo todo "clone currently messes up original"
    is_deeply $a1.array, ['a', 'b'], 'original object has its original array';
    is_deeply $a2.array, ['c', 'd'], 'cloned object has the newly-provided array';

    my $b1 = HshTest.new(hash=>{'a' => 'b'});
    my $b2 = $b1.clone(hash=>{'c' => 'd'});
    #?rakudo todo "clone currently messes up original"
    is_deeply $b1.hash, {'a' => 'b'}, 'original object has its original hash';
    is_deeply $b2.hash, {'c' => 'd'}, 'cloned object has the newly-provided hash';

    # when cloning without new versions of attributes, it should not deep-copy the array/hash
    my $a3 = ArrTest.new(:array<a b>);
    my $a4 = $a3.clone;
    is_deeply $a3.array, ['a', 'b'], 'original array attr sanity test';
    is_deeply $a4.array, ['a', 'b'], 'cloned array attr sanity test';
    #?pugs emit # can't modify constant...
    push $a3.array, 'c';
    #?pugs 2 skip "need previous statement"
    is_deeply $a3.array, ['a', 'b', 'c'], 'array on original is updated';
    is_deeply $a4.array, ['a', 'b', 'c'], 'array on copy is updated';

    my $b3 = HshTest.new(hash=>{'a' => 'b'});
    my $b4 = $b3.clone;
    is_deeply $b3.hash, {'a' => 'b'}, 'original hash attr sanity test';
    is_deeply $b4.hash, {'a' => 'b'}, 'cloned hash attr sanity test';
    $b3.hash{'c'} = 'd';
    is_deeply $b3.hash, {'a' => 'b', 'c' => 'd'}, 'hash on original is updated';
    is_deeply $b4.hash, {'a' => 'b', 'c' => 'd'}, 'hash on copy is updated';
}

# test cloning of custom class objects
{
    my class LeObject { 
        has $.identifier; 
        has @.arr; 
        has %.hsh; 
    }

    my class LeContainer { has LeObject $.obj; }

    my $cont = LeContainer.new(obj=>LeObject.new(identifier=>'1234', :arr<a b c>, :hsh{'x'=>'y'}));
    my $cont_clone_diff = $cont.clone(obj=>LeObject.new(identifier=>'4567', :arr<d e f>, :hsh{'z'=>'a'}));
    my $cont_clone_same = $cont.clone;

    # cont_clone_diff should contain a new value, altering its contained values should not alter the original
    is_deeply $cont_clone_diff.obj.arr, ['d', 'e', 'f'], 'cloned object sanity';
    is_deeply $cont.obj.arr, ['a', 'b', 'c'], 'original object is untouched';

    # change the cloned objects contained object, the original should be intact afterwards
    #?pugs emit # can't modify constant item
    $cont_clone_diff.obj.arr = 'g', 'h', 'i';
    #?pugs 2 skip "need previous statement"
    is_deeply $cont_clone_diff.obj.arr, ['g', 'h', 'i'], 'cloned object sanity';
    is_deeply $cont.obj.arr, ['a', 'b', 'c'], 'original object is untouched';

    # change attributes on contained object should change clones if a new object was not assigned
    is_deeply $cont_clone_same.obj.arr, ['a', 'b', 'c'], 'cloned object has identical value';
    is_deeply $cont.obj.arr, ['a', 'b', 'c'], 'original object sanity test';
   
    #?pugs emit # can't modify constant item
    $cont.obj.arr = 'j', 'k', 'l';
    #?pugs 2 skip "need previous statement"
    is_deeply $cont_clone_same.obj.arr, ['j', 'k', 'l'], 'cloned object has new value';
    is_deeply $cont.obj.arr, ['j', 'k', 'l'], 'original object has new value';
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/defaults.t�����������������������������������������������������0000664�0001750�0001750�00000006702�12224265625�020540� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 34;

# L<S12/Attribute default values/The value on the right is evaluated at object build time>

my $got_a_num = 0;  sub get_a_num  { $got_a_num++;  42 }
my $got_a_str = 0;  sub get_a_str  { $got_a_str++;  "Pugs" }

# Everything on the RHS of the = is implicitly a closure.
# Providing a closure means the attribute is a closure!
{
    $got_a_num = 0;
    $got_a_str = 0;
    
    class Spaceship {
        has $.num  = get_a_num();
        has $.str  = { get_a_str() };
    };

    is $got_a_num, 0, "default should not be called at compile-time";
    is $got_a_str, 0, "default should not be called at compile-time";
    
    my Spaceship $spaceship .= new;
    
    is $got_a_num, 1, "default should be called only once in construction";
    is $spaceship.num,  42, "attribute default worked";
    is $got_a_num, 1, "default should be called only once";

    is $got_a_str, 0, "default should not have been called yet";
    ok $spaceship.str ~~ Callable, "attribute default is a closure";
    is $got_a_str, 0, "default should not have been called yet";
    is $spaceship.str()(), "Pugs", "attribute can be called";
    is $got_a_str, 1, "and now get_a_str has run";

    my Spaceship $spaceship2 .= new;
    
    is $got_a_num, 2, "construction of second object also only calls default closure once";
    is $spaceship2.num,  42, "attribute default worked";
    is $got_a_num, 2, "default should be called only once";

    is $got_a_str, 1, "construction of second object still doesn't call closure";
    is $spaceship2.str.(), "Pugs", "attribute default worked, even called the other way";
    is $got_a_str, 2, "get_a_str now called twice";
}

{
    $got_a_num = 0;
    $got_a_str = 0;
    
    class Starship {
        has $.num  = get_a_num();
        has $.str  = { get_a_str() };
    };

    is $got_a_num, 0, "default should not be called at compile-time";
    is $got_a_str, 0, "default should not be called at compile-time";
    
    my Starship $starship .= new(num => 10);
    
    is $got_a_num, 0, "default should not be called if value provide";
    is $starship.num,  10, "attribute default worked";
    is $got_a_num, 0, "default should still not be called";

    is $got_a_str, 0, "default should not have been called yet";
    ok $starship.str ~~ Callable, "attribute default is a closure";
    is $got_a_str, 0, "default should not have been called yet";
    is $starship.str()(), "Pugs", "attribute can be called";
    is $got_a_str, 1, "and now get_a_str has run";

    my Starship $starship2 .= new(str => "Niecza");
    
    is $got_a_num, 1, "construction of second object only calls default closure once";
    is $starship2.num,  42, "attribute default worked";
    is $got_a_num, 1, "default should be called only once";

    is $got_a_str, 1, "construction of second object still doesn't call closure";
    is $starship2.str, "Niecza", "attribute default was not used";
    is $got_a_str, 1, "get_a_str now called twice";
}

#?niecza skip "'self' used where no object is available"
{
    class Towel {
        has $.self_in_code = { self.echo };

        method echo { "echo" }
    };

    my Towel $towel .= new;

    is $towel.self_in_code()(), "echo", "self is the object being initialized";
}

#?niecza skip "'self' used where no object is available"
{
    class Cake {
        has $.a = "echo";
        has $.self_in_code = self.a;
    };

    my Cake $cake .= new;

    is $cake.self_in_code, "echo", "self is the object being initialized";
}

# vim: ft=perl6
��������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/delegation.t���������������������������������������������������0000664�0001750�0001750�00000017420�12224265625�021043� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 65;

=begin desc

Delegation tests from L<S12/Delegation>

=end desc

# L<S12/Delegation>

class Backend1 {
    method hi() { 42 };
    method cool() { 1337 };
    method with_params($x) { $x xx 2 };
}
role Backend2 { method hi() { 23 }; method cool() {  539 } }
class Frontend { has $.backend is rw handles "hi" }
class Frontend2 { has $.backend handles <with_params> };
ok Backend1.new, "class definition worked";

is Backend1.new.hi, 42, "basic sanity (1)";
is Backend2.new.hi, 23, "basic sanity (2)";

{
  my $a;
  ok ($a = Frontend.new), "basic instantiation worked (1)";
  dies_ok { $a.hi }, "calling a method on no object didn't succeed (1)";
  ok ($a.backend = Backend1.new()), "setting a handler object (1)";
  ok (!($a ~~ Backend1)), "object wasn't isa()ed (1)";
  #?pugs skip 'no such method hi'
  is $a.hi, 42, "method was successfully handled by backend object (1)";
}

{
  my $a;
  ok ($a = Frontend.new), "basic instantiation worked (2)";
  dies_ok { $a.hi }, "calling a method on no object didn't succeed (2)";
  ok ($a.backend = Backend2.new()), "setting a handler object (2)";
  ok (!($a ~~ Backend2)), "object wasn't isa()ed (2)";
  #?pugs skip 'no such method hi'
  is $a.hi, 23, "method was successfully handled by backend object (2)";
}

#?pugs skip 'no such method with_params'
{
    my $a = Frontend2.new( backend => Backend1.new() );
    is $a.with_params('abc'), ('abc' xx 2), 'Delegation works with parameters';
}

# L<S12/Delegation/You can specify multiple method names:>
class MultiFrontend { has $.backend is rw handles <hi cool> }
ok MultiFrontend.new, "class definition using multiple method names worked";
{
  my $a;
  ok ($a = MultiFrontend.new), "basic instantiation worked (5)";
  dies_ok { $a.hi   }, "calling a method on no object didn't succeed (5-1)";
  dies_ok { $a.cool }, "calling a method on no object didn't succeed (5-2)";
  ok ($a.backend = Backend1.new()), "setting a handler object (5)";
  ok (!($a ~~ Backend1)),             "object wasn't isa()ed (5)";
  #?pugs skip 'no such method hi'
  is ($a.hi),     42, "method was successfully handled by backend object (5-1)";
  #?pugs skip 'no such method cool'
  is ($a.cool), 1337, "method was successfully handled by backend object (5-2)";
}

# L<S12/Delegation/you put a pair>
class PairTest {
    has $.backend1 is rw handles :hello<hi>;
    has $.backend2 is rw handles (:ahoj<hi>, :w00t('cool'));
}
{
    my $a = PairTest.new;
    $a.backend1 = Backend1.new();
    $a.backend2 = Backend2.new();
    dies_ok { $a.hi   }, "calling method with original name fails";
    dies_ok { $a.cool }, "calling method with original name fails";
    #?pugs 3 skip 'no such method'
    is $a.hello, 42, "calling method with mapped name works";
    is $a.ahoj, 23, "calling method with mapped name works";
    is $a.w00t, 539, "calling method with mapped name works";
}

# L<S12/Delegation/If you say>
{
  class ClassFrontend { has $.backend is rw handles Backend2 };
  ok ClassFrontend.new, "class definition using a Class handle worked";
  {
    my $a;
    ok ($a = ClassFrontend.new), "basic instantiation worked (4)";
    dies_ok { $a.hi }, "calling a method on no object didn't succeed (4)";
    ok ($a.backend = Backend1.new()), "setting a handler object (4)";
    ok (!($a ~~ Backend1)),             "object wasn't isa()ed (4-1)";
    ok (!($a ~~ Backend2)),             "object wasn't isa()ed (4-2)";
    #?pugs skip 'no such method'
    is $a.hi, 42, "method was successfully handled by backend object (4)";
  }
}
{
    role R1 { method awesome { "yeah!" } }
    class Backend3 does R1 { method sucks { "boo" } }
    class RoleFrontend { has $.backend is rw handles R1; }
    my $a = RoleFrontend.new();
    ok !$a.does(R1), "having a handles role doesn't make the class do the role";
    dies_ok { $a.awesome }, "calling a method on no object didn't succeed";
    $a.backend = Backend3.new();
    #?pugs skip 'no such method'
    is $a.awesome, "yeah!", "method in role was successfully handled by backend object";
    dies_ok { $a.sucks }, "but method in backend class but not role not handled";
}

# L<S12/Delegation/"Any other kind of argument" "smartmatch selector for method">
{
  class ReFrontend { has $.backend is rw handles /^hi|oo/ };
  ok ReFrontend.new, "class definition using a smartmatch handle worked";
 
  {
    my $a;
    ok ($a = ReFrontend.new), "basic instantiation worked (3)";
    dies_ok { $a.hi }, "calling a method on no object didn't succeed (3)";
    ok ($a.backend = Backend1.new()), "setting a handler object (3)";
    ok (!($a ~~ Backend1)),             "object wasn't isa()ed (3)";
    #?pugs 2 skip 'no such method'
    is $a.hi, 42, "method was successfully handled by backend object (3)";
    is $a.cool, 1337, "method was successfully handled by backend object (3)";
  }
}
{
    class WorrevaFrontend {
        has $.backend is rw handles *;
        has $.backend2 is rw handles *;
        method test { 1 }
        method hi { 2 }
    }
    ok WorrevaFrontend.new, "class definition using a smartmatch on * worked";
    my $a = WorrevaFrontend.new();
    $a.backend = Backend1.new();
    $a.backend2 = Backend2.new();
    is $a.test, 1, "didn't try to delegate method in the class even with handles *...";
    is $a.hi, 2, "...even when it exists in the target class";
    #?pugs skip 'no such method'
    is $a.cool, 1337, "...but otherwise it delegates, and first * wins";
}

# delegation with lvalue routines
{
    class BackendRw {
        has $.a is rw;
        has $.b is rw;
        has $.c;
    }
    class FrontendRw {
        has BackendRw $.backend handles <a b c>;
        submethod BUILD {
            $!backend = BackendRw.new();
        }
    }
    my $t = FrontendRw.new();
    #?pugs todo
    lives_ok { $t.a = 'foo' }, 'can assign to lvalue delegated attribute';
    dies_ok  { $t.c = 'foo' }, '... but only to lvaues attributes';
    #?pugs skip 'no such method'
    is $t.a, 'foo', 'assignment worked';
    #?pugs todo
    is $t.backend.a, 'foo', 'can also query that through the backend';
    #?pugs skip 'no such method'
    nok $t.c.defined, 'died assignment had no effect';
}

# arrays, hashes
#?pugs skip "Can't modify constant item: VUndef"
{
    class PseudoArray {
        has @!data handles <Str push pop elems shift unshift>;
    }
    my $x = PseudoArray.new();
    $x.push: 3, 4;
    $x.push: 6;
    is ~$x, '3 4 6',    'delegation of .Str and .push to array attribute';
    $x.pop;
    is ~$x, '3 4',      'delegation of .pop';
    $x.unshift('foo');
    is ~$x, 'foo 3 4',  'delegation of .unshift';
    is $x.shift, 'foo', 'delegation of .shift (1)';
    is ~$x, '3 4',      'delegation of .shift (2)';
    is $x.elems, 2,     'delegation of .elems';
}

#?pugs skip "Can't modify constant item: VUndef"
{
    class PseudoHash { has %!data handles <push Str> };
    my $h = PseudoHash.new;
    $h.push: 'a' => 5;
    is $h.Str, ~{a => 5}, 'delegation of .Str and .push to hash';
}

# This test cannot work; autoviv requires Hash-like methods in
# Any, which means that the 'handles Hash' fallback never occurs.
#{
#    class TypePseudoHash { has %!data handles Hash }
#    my $h = TypePseudoHash.new;
#    $h<a> = 'c';
#    $h<b> = 'd';
#    is $h<a b>.join('|'), 'c|d', 'can do handles + type object (1)';
#}

#?pugs skip "Can't modify constant item: VUndef"
{
    role OtherRole {
        method c() { 3 }
    }
    role RBackend does OtherRole {
        method a() { 1 }
        method b() { 2 }
    }
    class PunnedRBackend does RBackend { };

    class RFrontend {
        has $!backend handles RBackend = PunnedRBackend.new;
    }

    my $a = RFrontend.new;
    is $a.a(), 1, 'got all methods via "handles $typeObject" (1)';
    is $a.b(), 2, 'got all methods via "handles $typeObject" (2)';
    is $a.c(), 3, 'got all methods via "handles $typeObject" (next role)';
    dies_ok { $a.d() }, '... but non existing methods still die';
}

# vim: syn=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/inheritance.t��������������������������������������������������0000664�0001750�0001750�00000002411�12224265625�021213� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 7;

# test relation between attributes and inheritance

class A {
    has $.a;
}

class B is A {
    method accessor {
        return $.a
    }
}

my $o;
lives_ok {$o = B.new(a => 'blubb') }, 'Can initialize inherited attribute';
is $o.accessor, 'blubb',              'accessor can use inherited attribute';

class Artie61500 {
    has $!p = 61500;
}
#?pugs todo
eval_dies_ok 'class Artay61500 is Artie61500 { method bomb { return $!p } }',
    'Compile error for subclass to access private attribute of parent';

class Parent {
    has $!priv = 23;
    method get { $!priv };
    has $.public is rw;
    method report() { $!public }
}

class Child is Parent {
    has $!priv = 42;
    has $.public is rw;
}

#?pugs todo
is Child.new().Parent::get(), 23,
   'private attributes do not leak from child to parent class (1)';

#?pugs todo
is Child.new().get(), 23,
   'private attributes do not leak from child to parent class (2)';

my $child = Child.new();
$child.public = 5;
#?pugs todo
nok $child.report.defined,
    'If parent and child have an attribute of the same name, they do not share storage location';

# RT #61500
#?pugs todo
{
    eval_dies_ok 'class A { has $!foo = 7 }; class B is A { method x { say $!foo } }; B.new.x', 'rt 61500';
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/instance.t�����������������������������������������������������0000664�0001750�0001750�00000046275�12224265625�020546� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 140;

=begin pod

Class attributes tests from L<S12/Attributes>

=end pod

#?pugs todo
eval_dies_ok 'has $.x;', "'has' only works inside of class|role definitions";

# L<S12/Attributes/the automatic generation of an accessor method of the same name>

class Foo1 { has $.bar; };

{
    my $foo = Foo1.new();
    ok($foo ~~ Foo1, '... our Foo1 instance was created');
    my $val;
    #?pugs 2 todo 'feature'
    lives_ok {
        $val = $foo.can("bar")
    }, '.. checking autogenerated accessor existence';
    ok($val, '... $foo.can("bar") should have returned true');
    nok($foo.bar().defined, '.. autogenerated accessor works');
    nok($foo.bar.defined, '.. autogenerated accessor works w/out parens');
}

# L<S12/Attribute default values/Pseudo-assignment to an attribute declaration specifies the default>

{
    class Foo2 { has $.bar = "baz"; };
    my $foo = Foo2.new();
    ok($foo ~~ Foo2, '... our Foo2 instance was created');
    #?pugs skip 'can'
    ok($foo.can("bar"), '.. checking autogenerated accessor existence');
    is($foo.bar(), "baz", '.. autogenerated accessor works');
    is($foo.bar, "baz", '.. autogenerated accessor works w/out parens');
    #?niecza todo
    #?pugs todo
    dies_ok { $foo.bar = 'blubb' }, 'attributes are ro by default';
}

# L<S12/Attributes/making it an lvalue method>


{
    class Foo3 { has $.bar is rw; };
    my $foo = Foo3.new();
    ok($foo ~~ Foo3, '... our Foo3 instance was created');
    my $val;
    #?pugs todo
    lives_ok {
        $val = $foo.can("bar");
    }, '.. checking autogenerated accessor existence';
    #?pugs todo
    ok $val, '... $foo.can("bar") should have returned true';
    nok($foo.bar().defined, '.. autogenerated accessor works');
    lives_ok {
        $foo.bar = "baz";
    }, '.. autogenerated mutator as lvalue works';
    is($foo.bar, "baz", '.. autogenerated mutator as lvalue set the value correctly');    
}

# L<S12/Attributes/Private attributes use an exclamation to indicate that no public accessor is>


{
    class Foo4 { has $!bar; };
    my $foo = Foo4.new();
    ok($foo ~~ Foo4, '... our Foo4 instance was created');
    #?pugs eval 'todo'
    ok(!$foo.can("bar"), '.. checking autogenerated accessor existence', );
}


{
    class Foo4a { has $!bar = "baz"; };
    my $foo = Foo4a.new();
    ok($foo ~~ Foo4a, '... our Foo4a instance was created');
    #?pugs eval 'todo'
    ok(!$foo.can("bar"), '.. checking autogenerated accessor existence');
}


# L<S12/Attributes>


{
    class Foo5 {
        has $.tail is rw;
        has @.legs;
        has $!brain;

        method set_legs  (*@legs) { @.legs = @legs }
        method inc_brain ()      { $!brain++ }
        method get_brain ()      { $!brain }
    };
    my $foo = Foo5.new();
    ok($foo ~~ Foo5, '... our Foo5 instance was created');
        
    lives_ok {
        $foo.tail = "a";
    }, "setting a public rw attribute";
    is($foo.tail, "a", "getting a public rw attribute");
   
    lives_ok { $foo.set_legs(1,2,3) }, "setting a public ro attribute (1)";
    is($foo.legs.[1], 2, "getting a public ro attribute (1)");
    
    #?rakudo 2 todo 'ro on list attributes'
    #?niecza 2 todo 'ro on list attributes'
    #?pugs 2 todo 
    dies_ok {
        $foo.legs = (4,5,6);
    }, "setting a public ro attribute (2)";
    is($foo.legs.[1], 2, "getting a public ro attribute (2)");
    
    lives_ok { $foo.inc_brain(); }, "modifiying a private attribute (1)";
    is($foo.get_brain, 1, "getting a private attribute (1)");
    lives_ok {
        $foo.inc_brain();
    },  "modifiying a private attribute (2)";
    is($foo.get_brain, 2, "getting a private attribute (2)");
}

# L<S12/Semantics of C<bless>/If you name an attribute as a parameter, that attribute is initialized directly, so>

{
    class Foo6 {
        has $.bar is rw;
        has $.baz is rw;
        has $!hidden;

        submethod BUILD(:$!bar, :$!baz, :$!hidden) {}
        method get_hidden() { $!hidden }
    }

    my $foo = Foo6.new(bar => 1, baz => 2, hidden => 3);
    ok($foo ~~ Foo6, '... our Foo6 instance was created');
        
    is($foo.bar,        1, "getting a public rw attribute (1)"  );
    is($foo.baz,        2, "getting a public ro attribute (2)"  );
    is($foo.get_hidden, 3, "getting a private ro attribute (3)" );
}

# check that doing something in submethod BUILD works

{
    class Foo6a {
        has $.bar is rw;
        has $.baz is rw;
        has $!hidden;

        submethod BUILD (:$!hidden, :$!bar = 10, :$!baz?) {
            $!baz = 5;
        }
        method get_hidden() { $!hidden }
    }

    my $foo = Foo6a.new(bar => 1, hidden => 3);
    ok($foo ~~ Foo6a, '... our Foo6a instance was created');
        
    is($foo.bar,        1, "getting a public rw attribute (1)"  );
    is($foo.baz,        5, "getting a public rw attribute (2)"  );
    is($foo.get_hidden, 3, "getting a private ro attribute (3)" );
}

# check that assignment in submethod BUILD works with a bare return, too
{
    class Foo6b {
        has $.bar is rw;
        has $.baz is rw;

        submethod BUILD (:$!bar = 10, :$!baz?) {
            $!baz = 9;
            return;
        }
    }

    my $foo = Foo6b.new(bar => 7);
    ok($foo ~~ Foo6b, '... our Foo6b instance was created');
        
    is($foo.bar,        7, "getting a public rw attribute (1)"  );
    is($foo.baz,        9, "getting a public rw attribute (2)"  );
}

# L<S12/Attributes>
class Foo7e { has $.attr = 42 }
is Foo7e.new.attr, 42, "default attribute value (1)";

{
    my $was_in_supplier = 0;
    sub forty_two_supplier() { $was_in_supplier++; 42 }
    class Foo10e { has $.attr = forty_two_supplier() }
    is eval('Foo10e.new.attr'), 42, "default attribute value (4)";
    #?pugs todo
    is      $was_in_supplier, 1,  "forty_two_supplier() was actually executed";
    eval('Foo10e.new');
    #?pugs todo
    is      $was_in_supplier, 2,  "forty_two_supplier() is executed per instantiation";
}

# check that doing something in submethod BUILD works
{
    class Foo7 {
        has $.bar is rw;
        has $.baz;

        submethod BUILD (:$!bar = 5, :$!baz = 10 ) {
            $!baz = 2 * $!baz;
        }
    }

    my $foo7 = Foo7.new();
    is( $foo7.bar, 5,
        'optional attribute should take default value without passed-in value' );
    is( $foo7.baz, 20,
        '... optional non-attribute should too' );
    $foo7    = Foo7.new( :bar(4), :baz(5) );
    is( $foo7.bar, 4,
        'optional attribute should take passed-in value over default' );
    is( $foo7.baz, 10,
        '... optional non-attribute should too' );
}


# check that args are passed to BUILD
{
    class Foo8 {
        has $.a;
        has $.b;
        
        submethod BUILD(:$foo, :$bar) {
            $!a = $foo;
            $!b = $bar;
        }
    }

    my $foo = Foo8.new(foo => 'c', bar => 'd');
    ok($foo.isa(Foo8), '... our Foo8 instance was created');
        
    is($foo.a, 'c', 'BUILD received $foo');
    is($foo.b, 'd', 'BUILD received $bar');
}

# check mixture of positional/named args to BUILD

{
    class Foo9 {
        has $.a;
        has $.b;
        
        submethod BUILD($foo, :$bar) {
            $!a = $foo;
            $!b = $bar;
        }
    }

    dies_ok({ Foo9.new('pos', bar => 'd') }, 'cannot pass positional to .new');
}

# check $self is passed to BUILD
{
    class Foo10 {
        has $.a;
        has $.b;
        has $.c;
    
        submethod BUILD($self: :$foo, :$bar) {
            $!a = $foo;
            $!b = $bar;
            $!c = 'y' if $self.isa(Foo10);
        }
    }

    {
        my $foo = Foo10.new(foo => 'c', bar => 'd');
        ok($foo.isa(Foo10), '... our Foo10 instance was created');
        
        is($foo.a, 'c', 'BUILD received $foo');
        is($foo.b, 'd', 'BUILD received $bar');
        is($foo.c, 'y', 'BUILD received $self');
    }
}

{
    class WHAT_ref {  };
    class WHAT_test {
        has WHAT_ref $.a;
        has WHAT_test $.b is rw;
    }
    my $o = WHAT_test.new(a => WHAT_ref.new(), b => WHAT_test.new());
    isa_ok $o.a.WHAT, WHAT_ref, '.WHAT on attributes';
    isa_ok $o.b.WHAT, WHAT_test, '.WHAT on attributes of same type as class';
    my $r = WHAT_test.new();
    lives_ok {$r.b = $r}, 'type check on recursive data structure';
    isa_ok $r.b.WHAT, WHAT_test, '.WHAT on recursive data structure';

}

#?niecza skip 'self closure'
#?pugs skip 'undeclared variable'
{
    class ClosureWithself {
        has $.cl = { self.foo }
        method foo { 42 }
    }
    is ClosureWithself.new.cl().(), 42, 'use of self in closure on RHS of attr init works';
}


# Tests for clone.
{
    class CloneTest { has $.x is rw; has $.y is rw; }
    my $a = CloneTest.new(x => 1, y => 2);
    my $b = $a.clone();
    is $b.x, 1, 'attribute cloned';
    is $b.y, 2, 'attribute cloned';
    $b.x = 3;
    is $b.x, 3, 'changed attribute on clone...';
    #?niecza todo "original not affected"
    is $a.x, 1, '...and original not affected';
    my $c = $a.clone(x => 42);
    is $c.x, 42, 'clone with parameters...';
    #?niecza todo "original not affected"
    is $a.x, 1, '...leaves original intact...';
    is $c.y, 2, '...and copies what we did not change.';
}

# tests for *-1 indexing on classes, RT #61766
{
    class ArrayAttribTest {
        has @.a is rw;
        method init {
            @.a = <a b c>;
        }
        method m0 { @.a[0] };
        method m1 { @.a[*-2] };
        method m2 { @.a[*-1] };
    }
    my $o = ArrayAttribTest.new;
    $o.init;
    is $o.m0, 'a', '@.a[0] works';
    #?pugs 2 todo
    is $o.m1, 'b', '@.a[*-2] works';
    is $o.m2, 'c', '@.a[*-1] works';

    # RT #75266
    is ArrayAttribTest.new(a => <x y z>).a[2.0], 'z',
        'Can index array attributes with non-integers';
}

{
    class AttribWriteTest {
        has @.a;
        has %.h; 
        method set_array1 {
            @.a = <c b a>;
        }
        method set_array2 {
            @!a = <c b a>;
        }
        method set_hash1 {
            %.h = (a => 1, b => 2);
        }
        method set_hash2 {
            %!h = (a => 1, b => 2);
        }
    }

    my $x = AttribWriteTest.new; 
    # see Larry's reply to 
    # http://groups.google.com/group/perl.perl6.language/browse_thread/thread/2bc6dfd8492b87a4/9189d19e30198ebe?pli=1
    # on why these should fail.
    #?rakudo 2 todo 'ro array/hash with accessor'
    #?niecza 2 todo 'ro array/hash with accessor'
    #?pugs   2 todo
    dies_ok { $x.set_array1 }, 'can not assign to @.array attribute';
    dies_ok { $x.set_hash1 },  'can not assign to %.hash attribute';
    lives_ok { $x.set_array2 }, 'can assign to @!array attribute';
    lives_ok { $x.set_hash2 },  'can assign to %!hash attribute';
}

# test that whitespaces after 'has (' are allowed.
# This used to be a Rakudo bug (RT #61914)
#?niecza skip 'Unhandled parameter twigil .'
#?pugs skip 'parsefail'
{
    class AttribWsTest {
        has ( $.this,
        $.that,
        );
    }
    my AttribWsTest $o .= new( this => 3, that => 4);
    is $o.this, 3, 'could use whitespace after "has ("';
    is $o.that, 4, '.. and a newline within the has() declarator';
}

# test typed attributes and === (was Rakudo RT#62902).
#?pugs todo
{
    class TA1 { }
    class TA2 {
        has TA1 $!a;
        method foo { $!a === TA1 }
    }
    ok(TA2.new.foo, '=== works on typed attribute initialized with proto-object');
}

# used to be pugs regression
{
    class C_Test { has $.a; }
    sub f() { C_Test.new(:a(123)) }
    sub g() { my C_Test $x .= new(:a(123)); $x }

    is(C_Test.new(:a(123)).a, 123, 'C_Test.new().a worked');

    my $o = f();
    is($o.a, 123, 'my $o = f(); $o.a worked');

    is((try { f().a }), 123, 'f().a worked (so the pugsbug is fixed (part 1))');

    is((try { g().a }), 123, 'g().a worked (so the pugsbug is fixed (part 2))');
}

# was also a pugs regression:
# Modification of list attributes created with constructor fails

#?pugs skip 'cannot shift scalar'
{
    class D_Test { 
        has @.test is rw; 
        method get () { shift @.test }
    }

    my $test1 = D_Test.new();
    $test1.test = [1];
    is($test1.test, [1], "Initialized outside constructor");
    is($test1.get ,  1 , "Get appears to have worked");
    is($test1.test,  [], "Get Worked!");

    my $test2 = D_Test.new( :test([1]) );
    is($test2.test, [1], "Initialized inside constructor");
    is($test2.get ,  1 , "Get appears to have worked");
    is($test2.test,  [], "Get Worked!");
}

# test typed attributes
# TODO: same checks on private attributes
{
    class TypedAttrib {
        has Int @.a is rw;
        has Int %.h is rw;
        has Int @!pa;
        has Int %!ph;
        method pac { @!pa.elems };
        method phc { %!ph.elems };
    }
    my $o = try { TypedAttrib.new };
    ok $o.defined, 'created object with typed attributes';
    is $o.a.elems, 0, 'typed public array attribute is empty';
    is $o.h.elems, 0, 'typed public hash attribute is empty';
    is $o.pac, 0, 'typed private array attribute is empty';
    is $o.phc, 0, 'typed private hash attribute is empty';

    #?niecza skip "Unable to resolve method of in class Array"
    #?pugs skip '.of'
    ok $o.a.of === Int, 'array attribute is typed';
    lives_ok { $o.a = (2, 3) }, 'Can assign to typed drw-array-attrib';
    lives_ok { $o.a[2] = 4 },   'Can insert into typed rw-array-attrib';
    lives_ok { $o.a.push: 5 }, 'Can push onto typed rw-array-attrib';
    is $o.a.join('|'), '2|3|4|5', 
        '... all of the above actually worked (not only lived)';

    #?niecza 4 todo 'typed arrays'
    #?pugs todo
    dies_ok { $o.a = <foo bar> }, 'type enforced on array attrib (assignment)';
    #?pugs todo
    dies_ok { $o.a[2] = $*IN   }, 'type enforced on array attrib (item assignment)';
    #?pugs todo
    dies_ok { $o.a.push: [2, 3]}, 'type enforced on array attrib (push)';
    #?pugs todo
    dies_ok { $o.a[42]<foo> = 3}, 'no autovivification (typed array)';

    #?rakudo todo 'over-eager auto-vivification bugs'
    #?niecza todo
    #?pugs todo
    is $o.a.join('|'), '2|3|4|5', 
        '... all of the above actually did nothing (not just died)';

    #?niecza skip "Unable to resolve method of in class Hash"
    #?pugs skip '.of'
    ok $o.h.of === Int, 'hash attribute is typed';
    lives_ok {$o.h = { a => 1, b => 2 } }, 'assign to typed hash attrib';
    lives_ok {$o.h<c> = 3},                'insertion into typed hash attrib';
    #?pugs todo
    lives_ok {$o.h.push: (d => 4) },       'pushing onto typed hash attrib';

    #?pugs todo
    is_deeply $o.h<a b c d>, (1, 2, 3, 4),   '... all of them worked';

    #?niecza 3 todo
    #?pugs todo
    dies_ok  {$o.h = { :a<b> }  },         'Type enforced (hash, assignment)';
    #?pugs todo
    dies_ok  {$o.h<a> = 'b'  },            'Type enforced (hash, insertion)';
    dies_ok  {$o.h.push: (g => 'f') },     'Type enforced (hash, push)';
    #?niecza 2 todo
    #?pugs todo
    dies_ok  {$o.h<blubb><bla> = 3 },      'No autovivification (typed hash)';
    #?rakudo todo 'huh?'
    #?pugs todo
    is $o.h<a b c d>, (1, 2, 3, 4),   'hash still unchanged';
}

# attribute initialization based upon other attributes
#?niecza skip 'Variable $.a used where no self is available'
#?pugs skip 'Class prototype occured where its instance object expected'
{
    class AttrInitTest {
        has $.a = 1;
        has $.b = 2;
        has $.c = $!a + $!b;
    }
    is AttrInitTest.new.c, 3,         'Can initialize one attribute based on another (1)';
    is AttrInitTest.new(a => 2).c, 4, 'Can initialize one attribute based on another (2)';
    is AttrInitTest.new(c => 9).c, 9, 'Can initialize one attribute based on another (3)';
}

# attributes with & sigil
#?pugs skip 'method'
{
    class CodeAttr1 { has &!m = sub { "ok" }; method f { &!m() } }
    is CodeAttr1.new.f, "ok", '&!m = sub { ... } works and an be called';

    class CodeAttr2 { has &.a = { "woot" }; method foo { &!a() } }
    is CodeAttr2.new.foo, "woot", '&.a = { ... } works and also declares &!a';
    is CodeAttr2.new.a().(), "woot", '&.a has accessor returning closure';

    class CodeAttr3 { has &!m = method { "OH HAI" }; method f { self.&!m() } }
    is CodeAttr3.new.f, 'OH HAI', '&!m = method { ... } and self.&!m() work';
}

{
    # from t/oo/class_inclusion_with_inherited_class.t
    # used to be a pugs regression

    role A {
        method t ( *@a ) {
            [+] @a;
        }
    }

    class B does A {}

    class C does A {
        has $.s is rw;
        has B $.b is rw;
        submethod BUILD {
            $!b = B.new;
            $!s = $!b.t(1, 2, 3);
        }
    }

    is C.new.s, 6, "Test class include another class which inherited from same role";
}

# RT #68370
{
    class RT68370 {
        has $!a;
        method rt68370 { $!a = 68370 }
    }

    dies_ok { RT68370.rt68370() },
        'dies: trying to modify instance attribute when invocant is type object';
}

# Binding an attribute (was RT #64850)
#?pugs skip 'Bind to undeclared variable'
{
    class RT64850 {
        has $.x;
        method foo { $!x := 42 }
    }
    my $a = RT64850.new; 
    $a.foo;
    is $a.x, 42, 'binding to an attribute works';
}

#?rakudo skip 'dubious test - the initializer becomes a submethod here, implying a scope'
{
    class InitializationThunk {
        has $.foo = my $x = 5;
        method bar { $x };
    }

    is InitializationThunk.new.bar, 5, 'a lexical is not tied to a thunk';
}

# http://rt.perl.org/rt3/Ticket/Display.html?id=69202
{
    class TestMethodAll {
        has $.a;
        method x(Str $x) {};   #OK not used
        method all() { $!a }
    }
    is TestMethodAll.new(a => 5).all, 5, 'Can call a method all()';
}


# RT #74186
{
    sub outer { 42 };
    class AttribLex {
        sub inner { 23 };
        has $.outer = outer();
        has $.inner = inner();
    }
    is AttribLex.new.outer, 42, 'Can use outer lexicals in attribut initialization';
    is AttribLex.new.inner, 23, 'Can use lexicals in attribut initialization';
}

# RT #85502
{
    class AttribListAssign {
        has $.a;
        has $.b;
        method doit {
            ($!a, $!b) = <post office>;
        }
    }
    my $x = AttribListAssign.new;
    $x.doit;
    is $x.a, 'post', 'list assignment to attributes (1)';
    isa_ok $x.a, Str, 'list assignment to attributes (type)';
    is $x.b, 'office', 'list assignment to attributes (2)';

}

# RT #68498
{
    class Foo { has $.bar = "baz"; submethod BUILD {} }
    is Foo.new.bar, 'baz',
        'presence of BUILD does not prevent assignment of default values';

}

# RT #108670
#?pugs todo
eval_dies_ok 'my class AccessorClash { has @.a; has &.a }',
    'cannot have two attributes with same accessor name';
# RT #74274
eval_dies_ok q[class A { has $!a }; my $a = A.new(a => 42);
    my $method = method { return $!a }; $a.$method()],
    'cannot sneak in access to private attribute through the backdoor';

# RT #74636
#?pugs todo
{
    my class HasArray {
        has @.a;
    }
    my %h = a => <a b c>;
    my $c = 0;
    ++$c for HasArray.new(a => %h<a>).a;
    is $c, 3, 'Correct flattening behavior for array attributes';
}

# RT #110096
#?niecza skip 'Attribute $!x declared outside of any class'
{
    class AttrInSub {
        sub f {
            has $.x;
        }
    }
    is AttrInSub.new(x => 42).x, 42, 'Attribute declaration can be in sub-scope too';

}

# RT #107232
{
    my class Shadowing {
        has $x;
        method ignores_attr() {
            my $x = 42;
            return $x;
        }
    }
    is Shadowing.new.ignores_attr(), 42, 'can shadow an attribute with a lexical';

}

done();

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/mutators.t�����������������������������������������������������0000664�0001750�0001750�00000002644�12224265625�020610� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# this tests that you can define mutators, that do more interesting
# things than merely assigning the value!

use Test;

plan 12;

our $count = 0;

class MagicVal {
    has Int $.constant;
    has Int $.varies = 0;

    method varies returns Int is rw {
        $count++;
        return Proxy.new(
            # note that FETCH and STORE cannot go through the accessors
            # of $.varies again, because that would lead to infinite
            # recursion. Use the low-level attribute here instead
            FETCH => method ()     { $!varies += 2 },
            STORE => method ($new) { $!varies = $new + 1 },
        );
    }
}

my $mv = MagicVal.new(:constant(6), :varies(6));

is($mv.constant, 6, "normal attribute");
is($mv.constant, 6, "normal attribute");
dies_ok { $mv.constant = 7 }, "can't change a non-rw attribute";
is($mv.constant, 6, "attribute didn't change value");

is($count, 0, "mutator not called yet");
#?rakudo skip 'Can not get attribute $!varies declared in class MagicVal with this object'
{
    is($mv.varies, 8, "mutator called during object construction");
    is($count, 1, "accessor was called");
    is($mv.varies, 10, "attribute with mutating accessor");
    is($count, 2, "accessor was called");

    $count = 0;
    $mv.varies = 13;
    is($count, 1, "mutator was called");
    is($mv.varies, 16, "attribute with overridden mutator");
    is($count, 2, "accessor and mutator were called");
}
��������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/recursive.t����������������������������������������������������0000664�0001750�0001750�00000004622�12224265625�020737� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 23;

=begin pod

Test attributes with recursively typed attributes

=end pod

#L<S12/Attributes>
{
    class A {
        has A $.attr is rw;
    };

    my A $a;
    my A $b;
    lives_ok {
        $a .= new();
        $b .= new(:attr($a));
    }, 'Can instantiate class with recursively-typed attribute';
    isa_ok $a, A, 'Sanity check, $a is of type A';
    ok $b.attr === $a, "Recursively-typed attribute stores correctly";
    lives_ok { $a.attr = $b; }, "Cycles are fine";
    ok $b.attr.attr === $b, "Cycles resolve correctly";
}

#L<S12/Class attributes/"Class attributes are declared">
{
    class B {
        my B $.attr;
    };
    
    my B $a;
    #?pugs todo
    lives_ok {
        $a .= new();
        B.attr = $a;
    }, "Can instantiate class with recursively-typed class lexical";
    #?pugs skip 'Undeclared variable'
    ok B.attr === $a, "Recursively-typed class lexical stores correctly";
    
}

#L<S12/Invocants/current lexically-determined class ::?CLASS>
#?niecza skip 'A type must be provided ???'
{
    class C {
        has ::?CLASS $.attr is rw;
    };

    my C $a;
    my C $b;
    lives_ok {
        $a .= new();
        $b .= new(:attr($a));
    }, 'Can instantiate class with ::?CLASS attribute';
    is $b.attr, $a, '::?CLASS attribute stores correctly';
    lives_ok { $a.attr = $b; }, '::?CLASS cycles are fine';
    ok $b.attr.attr === $b, '::?CLASS cycles resolve correctly';
    lives_ok { $a.attr .= new(); }, 'Can instantiate attribute of type ::?CLASS';
    isa_ok $a.attr, C, '::?CLASS instantiates to correct class';


    class D is C { };
    my D $d;
    lives_ok {
        $d .= new();
        $d.attr .= new();
    }, 'Can instantiate derived class with ::?CLASS attribute';
    #?pugs todo 'bug'
    isa_ok $d.attr, C, '::?CLASS is lexical, not virtual';
}

# RT #67236
{
    class Z {
        has Z @.a is rw;
        has Z %.h is rw;
    }

    my $z1 = Z.new;
    #?pugs todo
    #?niecza todo "https://github.com/sorear/niecza/issues/183"
    isa_ok $z1.a[0], Z, "check type-object";
    lives_ok { $z1.a[0] = Z.new }, 'can assign';
    isa_ok $z1.a[0], Z;
    #?pugs todo
    #?niecza todo "https://github.com/sorear/niecza/issues/183"
    isa_ok $z1.h<k>, Z, "check type-object";
    lives_ok { $z1.h<k> = Z.new }, 'can assign';
    isa_ok $z1.h<k>, Z;

    my $z2 = Z.new;
    lives_ok { $z2.a.push( Z.new ) }, 'can push';
    isa_ok $z2.a[0], Z;
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/trusts.t�������������������������������������������������������0000664�0001750�0001750�00000006157�12224265625�020301� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# Referencing various parts of Synopsis 12.
# L<S12/Trusts/"if that other class has indicated that it trusts the
# class">
#
# XXX tests attribute access with method syntax, which is probably
# wrong. Needs spec clarification.

plan 15;

class A {
    trusts B;

    has $!foo;
    has @!bar;
    has %!baz;
}

class B {
    has A $!my_A;

    submethod BUILD () {
        my $an_A = A.new();

        try {
            $an_A!A::foo = 'hello';
        };
        is( $!.defined ?? 1 !! 0, 0, 'A trusts B, B can set an A scalar attr; '~($!//'') );

        try {
            $an_A!A::bar = [1,2,3];
        };
        is( $!.defined ?? 1 !! 0, 0, 'A trusts B, B can set an A array attr; '~($!//'') );

        try {
            $an_A!baz = {'m'=>'v'};
        };
        is( $!.defined ?? 1 !! 0, 0, 'A trusts B, B can set an A hash attr; '~($!//'') );

        $!my_A = $an_A;
    }

    method read_from_A() {
        my ($foo, @bar, %baz);
	my $an_A = $!my_A;   #OK not used

        try {
            $foo = $!an_A!A::foo;
        };
        #?pugs 2 todo 'feature'
        is( $!.defined ?? 1 !! 0, 0, 'A trusts B, B can get an A scalar attr; '~($!//''));
        is( $foo, 'hello', 'value read by B from an A scalar var is correct');

        try {
            @bar = $!an_A!A::bar;
        };
        #?pugs 2 todo 'feature'
        is( $!.defined ?? 1 !! 0, 0, 'A trusts B, B can get an A array attr; '~($!//''));
        is_deeply( @bar, [1,2,3], 'value read by B from an A scalar var is correct');

        try {
            %baz = $!an_A!A::baz;
        };
        #?pugs 2 todo 'feature'
        is( $!.defined ?? 1 !! 0, 0, 'A trusts B, B can get an A hash attr; '~($!//'') );
        is_deeply( %baz, {'m'=>'v'}, 'value read by B from an A scalar var is correct' );
    }
}

class C {
    has A $!my_A;

    submethod BUILD () {
        my $an_A = A.new();

        try {
            $an_A!A::foo = 'hello';
        };
        #?pugs todo 'feature'
        is( $!.defined ?? 1 !! 0, 1, 'A does not trust C, C can not set an A scalar attr; '~($!//'') );

        try {
            $an_A!A::bar = [1,2,3];
        };
        #?pugs todo 'feature'
        is( $!.defined ?? 1 !! 0, 1, 'A does not trust C, C can not set an A array attr; '~($!//'') );

        try {
            $an_A!A::baz = {'m'=>'v'};
        };
        #?pugs todo 'feature'
        is( $!.defined ?? 1 !! 0, 1, 'A does not trust C, C can not set an A hash attr; '~($!//'') );

        $!my_A = $an_A;
    }

    method read_from_A() {
        my ($foo, @bar, %baz);
	my $an_A = $!my_A;

        try {
            $foo = $an_A!A::foo;
        };
        is( $!.defined ?? 1 !! 0, 1, 'A does not trust C, C can not get an A scalar attr; '~($!//'') );

        try {
            @bar = $an_A!A::bar;
        };
        is( $!.defined ?? 1 !! 0, 1, 'A does not trust C, C can not get an A array attr; '~($!//'') );

        try {
            %baz = $an_A!A::baz;
        };
        is( $!.defined ?? 1 !! 0, 1, 'A does not trust C, C can not get an A hash attr; '~($!//'') );
    }
}

my $my_B = B.new();
$my_B.read_from_A();

my $my_C = C.new();
$my_C.read_from_A();

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-attributes/undeclared.t���������������������������������������������������0000664�0001750�0001750�00000003062�12224265625�021033� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

    access or assign on undeclared attribute will raise an error.

=end pod

plan 10;


dies_ok { class A { method set_a { $.a = 1 }}; A.new.set_a; },
    "Test Undeclared public attribute assignment from a class";
dies_ok { role B { method set_b { $.b = 1 }};class C does B { }; C.new.set_b; },
    "Test Undeclared public attribute assignment from a role";

#?pugs 2 todo 'bug'
eval_dies_ok ' class D { method d { $!d = 1 }}; D.new.d; ',
    "Test Undeclared private attribute assignment from a class";
eval_dies_ok ' role E { method e { $!e = 1 }};class F does E { }; F.new.e; ',
    "Test Undeclared private attribute assignment from a role";

##### access the undeclared attribute
dies_ok { class H { method set_h { $.h }}; H.new.set_h; },
    "Test Undeclared public attribute access from a class";
dies_ok { role I { method set_i { $.i }};class J does I { }; J.new.set_i; },
    "Test Undeclared public attribute access from a role";

#?pugs 2 todo 'bug'
eval_dies_ok ' class K { method k { $!k }}; K.new.k; ',
    "Test Undeclared private attribute access from a class";
eval_dies_ok ' role L { method l { $!l }};class M does L { }; M.new.l; ',
    "Test Undeclared private attribute access from a role";

## skip class 'Q' here to avoid quote operator conflict.

eval_dies_ok ' role R { method r { $!r := 1 }};class S does R { }; S.new.r; ',
    "Test Undeclared private attribute binding from a role";
eval_dies_ok ' class T { method t { $!t := 1 }}; ::T.new.t; ',
    "Test Undeclared private attribute binding from a class";

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/anonymous.t���������������������������������������������������������0000664�0001750�0001750�00000004146�12224265625�017700� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S12/Classes/"Perl 6 supports multiple inheritance, anonymous classes">
plan 17;

# Create and instantiate empty class; check .WHAT works and stringifies to
# empty string.
my $c1 = class { };
my $t1 = $c1.new();
ok(defined($t1),     'instantiated the class');
ok($t1 ~~ $c1,       'isa check works');
#?rakudo todo 'Anonymous class stringification (?)'
#?niecza todo
is($c1.WHAT().gist, '()',  '.WHAT.gist stringifies to ()');

# Anonymous classes with methods.
my $c2 = class { method foo { 42 }; method bar { 28 } };
my $t2 = $c2.new();
is($t2.foo, 42,      'can call methods on anonymous classes');
is($t2.bar, 28,      'can call methods on anonymous classes');

# Anonymous classes with attributes.
my $c3 = class { has $.x };
my $t3 = $c3.new(x => 42);
is($t3.x, 42,        'anonymous classes can have attributes');

{
    my $class;
    lives_ok { $class = class { method meth() { return 42 } }} ,
    "anonymous class creation";

    my $a;
    ok ($a = $class.new), "instantiation of anonymous class";
    is $a.meth, 42, "calling a method on an instance of an anonymous class (1)";

    # And the same w/o using a $class variable:
    is (class { method meth() { return 42 } }).new.meth, 42,
    "calling a method on an instance of an anonymous class (2)";
}

# Anonymous classes can inherit from named classes.
{
    class TestParent { method foo { 42 } }
    my $x = class :: is TestParent { }
    ok($x ~~ TestParent, 'anonymous class isa TestParent');
    is($x.foo, 42,       'inherited method from TestParent');
}

# RT #64888
{
    sub rt64888 {
        (
         class {
             method Stringy() { 'RT #64888' }
             method Numeric() { 64888 }
         }
        ).new
    }
    my $i1;
    my $i2;

    lives_ok { $i1 = rt64888() }, 'can get anonymous class instance once';
    lives_ok { $i2 = rt64888() }, 'can get anonymous class instance twice';

    #?niecza todo
    is ~$i1, 'RT #64888', 'anonymous class stringified works';
    is +$i1, 64888, 'anonymous class numified works';
}

# RT #80024
eval_dies_ok q[anon class C { }; C.WHAT; ], 'anon class is actually anon';

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/attributes.t��������������������������������������������������������0000664�0001750�0001750�00000010232�12224265625�020027� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 31;

# L<S12/Fancy method calls/"For a call on your own private method">

class Counter {
    has $!x;
    method init { $!x = 41 }
    method get { $!x }
    method inc { $!x++ }
}

my $c = Counter.new();
dies_ok { $c.x }, 'no public accessor for private attribute';
$c.init();
is($c.get(), 41, 'can assign and get from within the class');
$c.inc();
is($c.get(), 42, 'can auto-increment an attribute');

{
    class WithAlias {
        has $x;
        method set($a) { $x = $a }
        method get { $!x }
    }

    my $wa = WithAlias.new();
    $wa.set(99);
    is($wa.get, 99, 'has with no twigil creates alias');
}

#?niecza skip 'Unhandled parameter twigil !'
{
    class ManyTest {
        has ($a, $b);
        has ($.c, $.d);
        has ($!e, $!f);
        submethod BUILD(:$!a, :$!b, :$!c, :$!d, :$!e, :$!f) { }
        method t1 {
            $a + $b
        }
        method t2 {
            $!a + $!b
        }
        method t3 {
            $!e + $!f
        }
    }

    my $m = ManyTest.new(a => 1, b => 2, c => 3, d => 4, e => 5, f => 6);
    is($m.c, 3, 'list attribute declaration of publics works');
    is($m.d, 4, 'list attribute declaration of publics works');
    is($m.t1, 3, 'list attribute declaration of alias works');
    is($m.t2, 3, 'list attribute declaration of alias works');
    is($m.t3, 11, 'list attribute declaration of privates works');
}

class Foo {
    has %.bar is rw;
    method set_bar {
        %.bar<a> = 'baz';
    }
}
my $foo = Foo.new;
isa_ok($foo.bar, Hash,    'hash attribute initialized');
$foo.set_bar();
is($foo.bar<a>, 'baz',    'hash attribute initialized/works');
my %s = $foo.bar;
is(%s<a>, 'baz',          'hash attribute initialized/works');
$foo.bar<b> = 'wob';
is($foo.bar<b>, 'wob',    'hash attribute initialized/works');

class Bar {
    has @.bar is rw;
    method set_bar {
        @.bar[0] = 100;
        @.bar[1] = 200;
    }
}
my $bar = Bar.new;
isa_ok($bar.bar.WHAT, Array, 'array attribute initialized');
$bar.set_bar();
is($bar.bar[0], 100,       'array attribute initialized/works');
is($bar.bar[1], 200,       'array attribute initialized/works');
my @t = $bar.bar;
is(@t[0], 100,             'array attribute initialized/works');
is(@t[1], 200,             'array attribute initialized/works');
$bar.bar[2] = 300;
is($bar.bar[2], 300,       'array attribute initialized/works');

# RT #73808
#?niecza skip 'Unhandled parameter twigil !'
{
    class RT73808 {
        has ($!a, $!b);
        method foo {
            $!a = 1;
            $!b = 3;
            return $!a + $!b;
        }
    }
    is RT73808.new.foo, 4,
        'Providing a list of attributes to a single "has" works';
}

# RT 81718
eval_dies_ok q[
    class RT81718 {
        has $.bughunt is rw;
        sub bomb { "life is a $.bughunt" }
        method meta_bomb { "the good " ~ bomb() }
    }
], 'no attr access for sub inside class';

# RT 74850
#?niecza skip "Unhandled exception: Unable to resolve method ctxzyg in type Method"
#?rakudo skip "Cannot use .= to initialize an attribute"
{
    class A { };
    class B { has A $.foo .= new };
    isa_ok B.new.foo, A, 'class attribute can be initialized using .=';
}

#RT #115280
{
    eval_lives_ok '(class A { has $.x }).new.x.HOW',
        "HOW on attributes lives, custom class";
    eval_lives_ok '(1/2).numerator.HOW',
        "HOW on attributes lives, builtin";
}

#RT #114234
#?niecza skip '$b declared but not used. FIXME later.'
{
    eval_lives_ok q{
        my class A { state $b; }
    }, "No segfault on state variables";
}

#RT #75010
{

    my @y=1,2,3;
    is_deeply( [@y], [ 1, 2, 3 ], 'Plain array' );
    is_deeply( [@y[1 .. +@y]], [ 2, 3, Any ], 'Array from 2-nd element to end+1' );
    is_deeply( [@y[1 ..^ +@y]], [ 2, 3 ], 'Array from 2-nd element to end' );

    class AB {
        has @.x; 
        method aa { 
            my @y=1,2,3; 
            is_deeply( [@y[1 .. +@y]], [ 2, 3, Any ], 'Plain array in the method' );
            is_deeply( [@.x], [ 1, 2, 3 ], 'Array from 2-nd element to end+1 in the method' );
            is_deeply( [@.x[1 ..^ +@.x]], [ 2, 3 ], 'Array from 2-nd element to end in the method' );
        }
    };

    my AB $y.=new(:x(1,2,3)); 
    $y.aa;

}
# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/augment-supersede.t�������������������������������������������������0000664�0001750�0001750�00000003760�12224265625�021306� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 11;

# L<S12/"Open vs Closed Classes"/"Otherwise you'll get a class redefinition error.">


use MONKEY_TYPING;
{
    class Foo {
        method a {'called Foo.a'}
    }
    augment class Foo {
        method b {'called Foo.b'}
    }

    my $o = Foo.new;
    is($o.a, 'called Foo.a', 'basic method call works');
    is($o.b, 'called Foo.b', 'added method call works');

    dies_ok { eval('augment class NonExistent { }') },
        'augment on non-existent class dies';
}

# RT #74910
{
    my class LexFoo { };
    augment class LexFoo { method b { 'called LexFoo.b' } };
    is LexFoo.b, 'called LexFoo.b', 'can augment lexical class';
}

# RT #76104
{
    augment class Hash {
        method foo() { self.keys };
    }
    is { a => 1 }.foo, 'a', 'can augment Hash';
}

# RT #66694
eval_dies_ok q[
    class MethodClash { method foo() { 3 } };
    augment class MethodClash { method foo() { 3 } };
], 'cannot override a method by monkey-typing';

# RT #76600
eval_lives_ok q[
    use MONKEY_TYPING;
    role Bar { has $.counter; }
    class Pub does Bar { has $.saloon; }
    augment class Pub { method snug() { } }
], 'augmenting a class which has a role composed works';


#?rakudo skip 'redeclaration of symbol Bar'
{
    use MONKEY_TYPING;
    class Bar {
        method c {'called Bar.c'}
    }
    supersede class Bar {
        method d {'called Bar.d'}
    }

    my $o = Bar.new;
    eval_dies_ok('$o.c', 'overridden method is gone completely');
    is($o.d, 'called Bar.d', 'new method is present instead');
}

# RT #75432
{
    lives_ok {
        class A { multi method a() { }};
        augment class A { multi method a() { } }
    }, 'RT #75432'
}

# RT #71456
# some integers produces from ranges didn't have 
# methods that augment added. Weird.

{
    augment class Int {
        method prime { True };
    }
    my $primes = 0;
    lives_ok {
        for 1..5 {
            $primes++ if .prime;
        }
    }, 'integers produced from ranges have augmented methods';
}

# vim: ft=perl6
����������������rakudo-2013.12/t/spec/S12-class/basic.t�������������������������������������������������������������0000664�0001750�0001750�00000010220�12224265625�016717� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 37;

=begin pod

Very basic class tests from L<S12/Classes>

=end pod

# L<S12/Classes>
class Foo {}

#?pugs todo
is Foo.perl, 'Foo', 'Classname.perl produces the class name';

my $foo = Foo.new();
ok($foo ~~ Foo, '... smartmatch our $foo to the Foo class');

# note that S12 says that .isa() should be called on metaclasses.
# However, making it an object .isa() means that classes are free to
# override the behaviour without playing with the metamodel via traits
ok($foo.isa(Foo), '.isa(Foo)');
ok($foo.isa(::Foo), '.isa(::Foo)');
#?niecza todo
ok($foo.isa("Foo"), '.isa("Foo")');
ok(!$foo.isa("Bar"), '!.isa("Bar")');

{
    my $foo_clone = $foo.clone();
    ok($foo_clone ~~ Foo, '... smartmatch our $foo_clone to the Foo class');
}

# Definedness of proto-objects and objects.
ok(!Foo.defined,    'proto-objects are undefined');
my Foo $ut1;
ok(!$ut1.defined,   'proto-objects are undefined');
ok(Foo.new.defined, 'instances of the object are defined');

class Foo::Bar {}

my $foo_bar = Foo::Bar.new();
ok($foo_bar ~~ Foo::Bar, '... smartmatch our $foo_bar to the Foo::Bar class');

ok($foo_bar.isa(Foo::Bar), '.isa(Foo::Bar)');
ok(!$foo_bar.isa(::Foo), '!Foo::Bar.new.isa(::Foo)');


# L<S12/Classes/An isa is just a trait that happens to be another class>
class Bar is Foo {}

ok(Bar ~~ Foo, '... smartmatch our Bar to the Foo class');

my $bar = Bar.new();
ok($bar ~~ Bar, '... smartmatch our $bar to the Bar class');
ok($bar.isa(Bar), "... .isa(Bar)");
ok($bar ~~ Foo, '... smartmatch our $bar to the Foo class');
ok($bar.isa(Foo), "new Bar .isa(Foo)");

{
    my $bar_clone = $bar.clone();
    ok($bar_clone ~~ Bar, '... smartmatch our $bar_clone to the Bar class');
    ok($bar_clone.isa(Bar), "... .isa(Bar)");
    ok($bar_clone ~~ Foo, '... smartmatch our $bar_clone to the Foo class');
    ok($bar_clone.isa(Foo), "... .isa(Foo)");
}

# Same, but with the "is Foo" declaration inlined
#?rakudo skip 'Calling is will never work with argument types (Foo)'
#?niecza skip 'No value for parameter \$expected in Test is'
{
    class Baz { is Foo }
    ok(Baz ~~ Foo, '... smartmatch our Baz to the Foo class');
    my $baz = Baz.new();
    ok($baz ~~ Baz, '... smartmatch our $baz to the Baz class');
    ok($baz.isa(Baz), "... .isa(Baz)");
}

# test that lcfirst class names and ucfirst method names are allowed

{
    class lowerCase {
        method UPPERcase {
            return 'works';
        }
    }
    is lowerCase.new.UPPERcase, 'works',
       'type distinguishing is not done by case of first letter';
}

eval_dies_ok 'my $x; $x ~~ NonExistingClassName',
             'die on non-existing class names';

# you can declare classes over vivified namespaces, but not over other classes

class One::Two::Three { }  # auto-vivifies package One::Two
class One::Two { }
ok(One::Two.new, 'created One::Two after One::Two::Three');
#?pugs todo
dies_ok { eval 'class One::Two { }' }, 'cannot redeclare an existing class';
eval_lives_ok q[BEGIN {class Level1::Level2::Level3 {};}; class Level1::Level2 {};], 'RT 62898';

#?niecza skip "Methods must be used in some kind of package"
{
    class A61354_1 {
        eval('method x { "OH HAI" }')
    };
    is A61354_1.x, "OH HAI", "can just use eval to add method to class";
}

# RT #67784
{
    class class {}
    #?rakudo skip 'RT #67784'
    #?niecza todo
    isa_ok( class.new, 'class' );
}

# RT #64686
eval_dies_ok 'class Romeo::Tango {}; Romeo::Juliet.rt64686',
             'call to missing method in A::B dies after class A::C defined';

# RT 72286
eval_dies_ok 'class WritableSelf { method f { self = 5 } }; WritableSelf.new.f',
            'self is not writable';

# RT 65022
eval_lives_ok 'class Test1 { class A {};}; class Test2 {class A {};};',
                'RT65022 - Nested classes in different classes can have the same name';

# RT #76270
#?pugs skip 'class'
{
    my $x = class Named { };
    isa_ok $x, Named, 'named class declaration returns the class object';
}

# RT #72916
#?pugs todo
{
    #?niecza todo 'Exception: Unable to resolve method add_method in type ClassHOW'
    eval_lives_ok 'Rat.^add_method("lol", method ($what) { say "lol$what" }) ~~ Method',
          'add_method returns a Method object';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/declaration-order.t�������������������������������������������������0000664�0001750�0001750�00000000627�12224265625�021246� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 2;


=begin pod

A class can only derive already declared classes.

=end pod

# L<S12/Classes/"bare class names must be predeclared">

# need eval_lives_ok here because class declarations happen at compile time
eval_lives_ok ' class A {}; class B is A {}; ', "base before derived: lives";
eval_dies_ok ' class D is C {}; class C {}; ', "derived before base: dies";

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/extending-arrays.t��������������������������������������������������0000664�0001750�0001750�00000002130�12224265625�021123� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use MONKEY_TYPING;

use Test;

plan 11;

augment class Array { method test_method  { 1 }; };
augment class Hash { method test_method  { 1 }; };

my @named_array;

ok @named_array.test_method, "Uninitialized array";

@named_array = (1,2,3);

ok @named_array.test_method, "Populated array";

ok try { [].test_method }, "Bare arrayref";


my $arrayref = [];

$arrayref = [];

ok $arrayref.test_method, "arrayref in a variable";

my %named_hash;

ok %named_hash.test_method, "Uninitialized hash";
%named_hash = (Foo => "bar");

ok %named_hash.test_method, "Populated hash";

ok try { ~{foo => "bar"}.test_method }, "Bare hashref";


my $hashref = {foo => "bar"};

ok $hashref.test_method, "Named hashref";

# Now for pairs.

is(try { (:key<value>).value; }, 'value', "method on a bare pair");

my $pair = :key<value>;

is $pair.value, 'value', "method on a named pair";

{
    augment class Parcel {
        method twice {
            gather {
                take $_ * 2 for self.list;
            }
        }
    }

    is (1, 2, 3).twice.join('|'), "2|4|6", 'can extend class Parcel';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/inheritance-class-methods.t�����������������������������������������0000664�0001750�0001750�00000001045�12224265625�022700� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;
plan 5;

# L<S12/Class methods/>

class C {method h {42}}
class B is C { method g { self.f } };
class A is B { method f {1; } };

class AA {method i {108}}
class D is A is AA {method f {2} }

is(A.g(), 1, 'inheritance works on class methods');
is(A.h(), 42, '>1 level deep inheritance works on class methods');
is(D.h(), 42, 'multiple inheritance works on class methods (1)');
is(D.i(), 108, 'multiple inheritance works on class methods (2)');
is(D.f(), 2, 'method from class is selected over inherited method');

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/inheritance.t�������������������������������������������������������0000664�0001750�0001750�00000012731�12224265625�020140� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 39;

# L<S12/Single inheritance/An "isa" is just a trait that happens to be another class>

class Foo {
    has $.bar is rw;
    has $.value is rw;
    method baz { return 'Foo::baz' }
    method getme($self:) returns Foo { return $self }
}

class Foo::Bar is Foo {
    has $.bar2 is rw;
    method baz { return 'Foo::Bar::baz' }
    method fud { return 'Foo::Bar::fud' }
    method super_baz ($self:) { return $self.Foo::baz() }
}

class Unrelated {
    method something { 'bad' };
}

my $foo_bar = Foo::Bar.new();
isa_ok($foo_bar, Foo::Bar);

ok(!defined($foo_bar.bar2()), '... we have our autogenerated accessor');
ok(!defined($foo_bar.bar()), '... we inherited the superclass autogenerated accessor');

lives_ok { $foo_bar.bar = 'BAR' }, '... our inherited the superclass autogenerated accessor is rw';
is($foo_bar.bar(), 'BAR', '... our inherited the superclass autogenerated accessor is rw');

lives_ok { $foo_bar.bar2 = 'BAR2'; }, '... our autogenerated accessor is rw';

is($foo_bar.bar2(), 'BAR2', '... our autogenerated accessor is rw');

is($foo_bar.baz(), 'Foo::Bar::baz', '... our subclass overrides the superclass method');

is($foo_bar.super_baz(), 'Foo::baz', '... our subclass can still access the superclass method through Foo::');
is($foo_bar.fud(), 'Foo::Bar::fud', '... sanity check on uninherited method');

is($foo_bar.getme, $foo_bar, 'can call inherited methods');
is($foo_bar.getme.baz, "Foo::Bar::baz", 'chained method dispatch on altered method');

ok(!defined($foo_bar.value), 'value can be used for attribute name in derived classes');
my $fud;

lives_ok { $fud = $foo_bar.getme.fud }, 'chained method dispatch on altered method';
is($fud, "Foo::Bar::fud", "returned value is correct");

is $foo_bar.Foo::baz, 'Foo::baz', '$obj.Class::method syntax works';
#?pugs todo
dies_ok { $foo_bar.Unrelated::something() },
    'Cannot call unrelated method with $obj.Class::method syntax';

# See thread "Quick OO .isa question" on p6l started by Ingo Blechschmidt:
# L<"http://www.nntp.perl.org/group/perl.perl6.language/22220">

ok  Foo::Bar.isa(Foo),      "subclass.isa(superclass) is true";
ok  Foo::Bar.isa(Foo::Bar), "subclass.isa(same_subclass) is true";
#?pugs skip 'No compatible multi variant found: "&isa"'
ok Foo::Bar.HOW.isa(Foo::Bar, Foo),      "subclass.HOW.isa(superclass) is true";
#?pugs skip 'No compatible multi variant found: "&isa"'
ok Foo::Bar.HOW.isa(Foo::Bar, Foo::Bar), "subclass.HOW.isa(same_subclass) is true";

#?pugs todo
{
    my $test = '$obj.$meth is canonical (audreyt says)';
    class Abc {
        method foo () { "found" }
    }
    class Child is Abc { }
    is( eval('my $meth = "foo"; my $obj= Child.new; $obj."$meth"()'), 'found', $test);
}

# Erroneous dispatch found by TimToady++

class X {
    method j () { 'X' }
};
class Z is X {}
class Y is X {
    method k () { Z.new.j() }
    method j () { 'Y' }
};

is(Z.new.j(), 'X', 'inherited method dispatch works');
is(Y.new.k(), 'X', 'inherited method dispatch works inside another class with same-named method');

{
    my class A {
      has @.x = <a b c>;
      has $.w = 9;

      method y($i) { return @.x[$i]; }
    }

    my class B is A {
      has $.w = 10;
      method z($i) { return $.y($i); }
    }

    is( B.new.z(1), 'b', 'initializer carries through' );
    is( B.new.w, 10, 'initializer can be overridden by derived classes' );
}

# test that you can inherit from a class with :: in the name.
{
    class A::B {
        method ab { 'a'; };
    };

    class A::B::C is A::B {
        method abc { 'b'; };
    }
    my $o = A::B::C.new;

    ok defined($o), 'can instantiate object from class A::B::C';
    is $o.ab,  'a', 'can access inherited method';
    is $o.abc, 'b', 'can access directly defined method';
}

# Make sure inheritance from Mu works (got broken in Rakudo once).
eval_lives_ok 'class NotAny is Mu { }; NotAny.new', 'inheritance from Mu works';
{
    class DirectMu is Mu { };
    ok DirectMu !~~ Any, 'class inheriting from Mu is not Any';
    #?niecza skip 'Unable to resolve method parents in class ClassHOW'
    #?pugs skip 'No such method in class Class: "&parents"'
    ok !( any(DirectMu.^parents).gist eq '(Any)'), 'and Any does not appear in the list of parents either';
}

#?pugs todo
eval_dies_ok 'class RT64642 is ::Nowhere {}', 'dies: class D is ::C {}';

# check that inheriting from Array works
#?pugs skip "Can't modify constant item: VUndef"
{
    class ArrayChild is Array {
        method summary() { self.join(', ') }
    }

    my $a = ArrayChild.new;
    $a.push('foo');
    $a.push('bar');
    is $a.join('|'), 'foo|bar', 'inheritance from Array';
    is $a.summary, 'foo, bar', 'and ArrayChild methods work';

    my @a := ArrayChild.new;
    @a.push: 3, 5;
    is @a.summary, '3, 5', 'new methods still work in @ variables';

}

# RT #82814
#?pugs skip 'callsame'
{
    my class A {
        method new { self.bless }
    };
    my class B is A {
        has $.c is rw;
        method new {
            my $obj = callsame;
            $obj.c = 42;
            return $obj
        }
    }
    is B.new.c, 42, 'nextsame in constructor works';
}

# RT 75376
#?pugs skip 'No such subroutine: "&RT75376::B"'
#?niecza skip "Pathed definitions require our scope"
{
    my class RT75376::A { };
    lives_ok { our class RT75376::B is RT75376::A { } },
        'our-scoped class can inherit from my-scoped class';
    ok (RT75376::B.^mro[0] ~~ RT75376::B and RT75376::B.^mro[1] ~~ RT75376::A),
        'our-scoped class inherited from my-scoped class has proper inheritance hierarchy';
}

# vim: ft=perl6
���������������������������������������rakudo-2013.12/t/spec/S12-class/instantiate.t�������������������������������������������������������0000664�0001750�0001750�00000002365�12224265625�020174� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 7;

# L<S12/Construction and Initialization>
# Basic instantiation.
class Foo1 { };
my $foo1 = Foo1.new();
ok(defined($foo1), 'instantiated a class');

# Instantiation with initializing attributes.
class Foo2 {
    has $.a;
    has $.b;
    method check {
        $!a + $!b
    }
}
my $foo2 = Foo2.new(:a(39), :b(3));
is($foo2.check(), 42, 'initializing attributes in new');

# RT #62732
#?pugs skip   'Exception NYI'
{
    try { eval 'NoSuchClass.new()' };
    #?niecza skip 'Exception NYI'
    ok  $!  ~~ Exception, 'death to instantiating nonexistent class';
    ok "$!" ~~ / NoSuchClass /,
       'error for "NoSuchClass.new()" mentions NoSuchClass';

    try { eval 'NoSuch::Subclass.new()' };
    #?niecza skip 'Exception NYI'
    ok  $!  ~~ Exception, 'death to instantiating nonexistent::class';
    #?rakudo todo 'error reporting'
    #?niecza todo
    ok "$!" ~~ / 'NoSuch::Subclass' /,
       'error for "NoSuch::Subclass.new()" mentions NoSuch::Subclass';
}

# RT 65224

#instantiation from class name unexpectedly creates a class object instead of Str object
{
    class Foo { };
    my $x = 'Foo';
    my $y = $x.new;
    is($y.WHAT.gist, Str.gist, "instantiating from class name string creates a Str object");
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/interface-consistency.t���������������������������������������������0000664�0001750�0001750�00000002334�12224265625�022144� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S12/Interface Consistency>

plan 8;

class Foo {
    our &m1 = method m1($a) {   #OK not used
        1
    }
    our &m2 = method m2($a, *%foo) {   #OK not used
        %foo.keys.elems
    }
}

lives_ok { Foo.new.m1(1, :x<1>, :y<2>) }, 'implicit *%_ means we can pass extra nameds';
ok &Foo::m1.signature.perl ~~ /'*%_'/,    '*%_ shows up in .perl of the Signature';
lives_ok { Foo.new.m2(1, :x<1>, :y<2>) }, 'explicit *%_ means we can pass extra nameds';
ok &Foo::m2.signature.perl !~~ /'*%_'/,   'With explicit one, *%_ not in .perl of the Signature';

class Bar is Foo is hidden {
    our &m1 = method m1($a) {   #OK not used
        2
    }
}

dies_ok { Bar.new.m1(1, :x<1>, :y<2>) },  'is hidden means no implicit *%_';
ok &Bar::m1.signature.perl !~~ /'*%_'/,   '*%_ does not show up in .perl of the Signature';


class Baz is Bar {
    method m1($a) {   #OK not used
        nextsame;
    }
}

is Baz.new.m1(42), 1, 'is hidden on Bar means we skip over it in deferal';


class Fiz is Foo {
    method m1($a) {   #OK not used
        4
    }
}
class Faz hides Fiz {
    method m1($a) {   #OK not used
        nextsame;
    }
}

is Faz.new.m1(42), 1, 'hides Fiz means we skip over Fiz in deferal';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/lexical.t�����������������������������������������������������������0000664�0001750�0001750�00000004030�12224265625�017261� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 14;

=begin pod

Tests for lexical classes delcared with 'my class'

=end pod

# L<S12/Classes>

# A few basic tests.
eval_lives_ok 'my class A {}', 'my class parses OK';
eval_lives_ok '{ my class B {} }; { my class B {} }',
              'declare classes with the same name in two scopes.';
eval_lives_ok '{ my class B {}; B.new; }',
              'can instantiate lexical class';
#?pugs todo
eval_dies_ok  '{ my class B {}; B.new; }; B.new',
              'scope is correctly restricted';

{
    my class WeissBier {
        has $.name;
        method describe() { 'outstanding flavour' }
    }
    my $pint = WeissBier.new(name => 'Erdinger');
    ok $pint ~~ WeissBier,                    'can smart-match against lexical class';
    is $pint.name, 'Erdinger',                'attribute in lexical class works';
    is $pint.describe, 'outstanding flavour', 'method call on lexical class works';
    is WeissBier.gist, '(WeissBier)',         'lexical type object stringifies correct';

    my class LessThanAmazingWeissBier is WeissBier {
        method describe() { 'tastes like sweetcorn' }
    }
    ok LessThanAmazingWeissBier ~~ WeissBier,      'inehritance between lexical classes works';
    my $ltapint = LessThanAmazingWeissBier.new(name => 'Baltika 7');
    ok $ltapint ~~ LessThanAmazingWeissBier,       'can smart-match class that inherits';
    ok $ltapint ~~ WeissBier,                      'can smart-match against parent class too';
    is $ltapint.describe, 'tastes like sweetcorn', 'can call overridden method';
    is $ltapint.name, 'Baltika 7',                 'can call inherited method that accesses inherited attribute';
}

# RT #69316
#?pugs skip 'bless'
{
    class Forest {
        class Frog {
            method speak { "ribbit ribbit" }
        };
        has Frog $.frog;
        method new() {
            my Frog $frog .=  new;
            self.bless(:$frog);
        };
    }
    is Forest.new.frog.speak, 'ribbit ribbit',
        'can construct objects of inner class in outer constructor';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/literal.t�����������������������������������������������������������0000664�0001750�0001750�00000000776�12224265625�017311� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 2;

# L<S12/Classes/"class or type name using">

# TODO: move that to t/spec/ as well
BEGIN { @*INC.unshift('t/spec/packages/'); }

# Testing class literals
use  Foo;
my $test1;

ok ($test1 = ::Foo) ~~ Foo, "::Foo is a valid class literal";

# Test removed per L<"http://www.nntp.perl.org/group/perl.perl6.language/22220">
# Foo.isa(Class) is false.
#isa_ok($test1, "Class", "It's a class");

my $x = eval 'Foo';
ok($x ===  ::Foo, "Foo is now a valid class literal");

# vim: ft=perl6
��rakudo-2013.12/t/spec/S12-class/magical-vars.t������������������������������������������������������0000664�0001750�0001750�00000006421�12224265625�020214� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 17;

# L<S02/Names/"Which class am I in?">

class Foo {
  method get_self_normal()    { self }
  method get_class_normal()   { $?CLASS }
  method get_package_normal() { $?PACKAGE }

  method get_class_pvar()   { ::?CLASS }
  method get_package_pvar() { ::?PACKAGE }

  method dummy()     { 42 }
}

role Bar {
  method get_self_normal()    { self }
  method get_class_normal()   { $?CLASS }
  method get_role_normal()    { $?ROLE }
  method get_package_normal() { $?PACKAGE }

  method get_class_pvar()   { ::?CLASS }
  method get_role_pvar()    { ::?ROLE }
  method get_package_pvar() { ::?PACKAGE }

  method dummy()     { 42 }
}

class SimpleClass does Bar {}

{
  my $foo_obj = Foo.new;
  my $class   = $foo_obj.get_class_normal;
  my $package = $foo_obj.get_package_normal;
  is( $package.gist, Foo.gist, '$?PACKAGE should be the package name' );

  ok( $class ~~ Foo, 'the thing returned by $?CLASS in our class smartmatches against our class' );
  my $forty_two;
  lives_ok { my $obj = $class.new; $forty_two = $obj.dummy },
    'the class returned by $?CLASS in our class was really our class (1)';
  is $forty_two, 42, 'the class returned by $?CLASS in our class way really our class (2)';
}

{
  my $foo1 = Foo.new;
  my $foo2 = $foo1.get_self_normal;

  ok $foo1 === $foo2, 'self in classes works';
}

{
  my $bar   = SimpleClass.new;
  my $class = $bar.get_class_normal;
  my $package = $bar.get_package_normal;

  is( $package.gist, Bar.gist, '$?PACKAGE should be the role package name - it is not generic like $?CLASS');

  #?pugs todo 'bug'
  ok $class ~~ ::SimpleClass, 'the thing returned by $?CLASS in our role smartmatches against our class';
  my $forty_two;
  lives_ok { my $obj = $class.new; $forty_two = $obj.dummy },
    'the class returned by $?CLASS in our role way really our class (1)';
  is $forty_two, 42, 'the class returned by $?CLASS in our role way really our class (2)';
}

{
  my $bar1 = SimpleClass.new;
  my $bar2 = $bar1.get_self_normal;

  ok $bar1 === $bar2, 'self in roles works';
}

{
  my $bar  = SimpleClass.new;
  my $role = $bar.get_role_normal;

  ok $role ~~ Bar, 'the returned by $?ROLE smartmatches against our role';
}

# Now the same with type vars
#?pugs todo 'oo'
{
  ok Foo.new.get_class_pvar === ::Foo,
    "::?CLASS in classes works";
  ok SimpleClass.new.get_class_pvar === ::SimpleClass,
    "::?CLASS in roles works";
  ok SimpleClass.new.get_role_pvar === ::Bar,
    "::?ROLE in roles works";
}

# Per L<"http://www.nntp.perl.org/group/perl.perl6.language/23541">:
#     On Sat, Oct 15, 2005 at 07:39:36PM +0300, wolverian wrote:
#     : On Sat, Oct 15, 2005 at 08:25:15AM -0700, Larry Wall wrote:
#     : > [snip]
#     : >
#     : > Of course, there's never been any controversy here about what to call
#     : > "self", oh no... :-)
#     : 
#     : IMHO just call it "self" (by default) and be done with it. :) 
#
#     Let it be so.
#
#     Larry
{
  class Grtz {
    method get_self1 { self }
    method get_self2 ($self:) { $self }
    method foo       { 42 }
    method run_foo   { self.foo }
  }
  my $grtz = Grtz.new;

  ok $grtz.get_self1 === $grtz.get_self2,
    'self is an alias for $self (1)';
  is $grtz.run_foo, 42,
    'self is an alias for $self (2)';
}

{
  eval_dies_ok 'self' , "there is no self outside of a method";
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/mro.t���������������������������������������������������������������0000664�0001750�0001750�00000002377�12254121465�016445� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 4;

{
    class A      {
        has $.tracker is rw = '';
        method x { $.tracker ~= 'A' }
    };
    class B is A      { method x { $.tracker ~= 'B'; nextsame } };
    class C is A      { method x { $.tracker ~= "C"; nextsame } };
    class D is B is C { method x { $.tracker ~= "D"; nextsame } }
    class E is C      { method x { $.tracker ~= "E"; nextsame } };
    class F is D is E { method x { $.tracker ~= "F"; nextsame } };
    my $x = F.new;
    $x.x;
    is $x.tracker, 'FDBECA', 'got the right MRO for 6 classes';
    # not really spec yet
    #?niecza skip '.^mro'
    is $x.^mro.gist, '(F) (D) (B) (E) (C) (A) (Any) (Mu)',
       '.^mro';
}

{
    # from http://192.220.96.201/dylan/linearization-oopsla96.html
    class grid { };
    class horizontal is grid { };
    class vertical   is grid { }
    class hv is horizontal is vertical   { }
    class vh is vertical   is horizontal { }
    eval_dies_ok 'class confused is vh is hv { }',
        'Cannot do multi inheritance that causes inconsistent MRO';
}

# RT #77274
eval_lives_ok q[
    class GrandParent { };
    class Parent is GrandParent { };
    class Me is Parent is GrandParent { };
    Me.new;
], 'a class can inherit both from its parent and then from its grand parent';
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/namespaced.t��������������������������������������������������������0000664�0001750�0001750�00000003150�12224265625�017742� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 13;

=begin pod

Classes with names containing double colons and nested classes.

=end pod

class Foo::Bar {
    method baz {
        return 42;
    }
}

{
    my $foobar = Foo::Bar.new();
    is($foobar.baz, 42, 'methods can be called on classes with namespaces with ::');
}

class A {
    class B {
        method x { 2 }
        has $.y = 'b';
        method z { $!y }
    };
    method x { 1 }
    has $.y = 'a';
    method z { $!y }
};
{
    ok(A.new,           'could instantiate outer class');
    is(A.new.x,    1,   'called correct method on class A');
    is(A.new.y,    'a', 'could access attribute in class A');
    is(A.new.z,    'a', 'method access correct attribute in class A');
    #?pugs 5 skip 'No such subroutine: &A::B'
    ok(A::B.new,        'could instantiate nested class');
    is(A::B.new.x, 2,   'called correct method on class A::B');
    is(A::B.new.y, 'b', 'could access attribute in class A::B');
    is(A::B.new.z, 'b', 'method access correct attribute in class A::B');
    eval_dies_ok(q{ B.new },  'class A::B not available outside of class as B');
}

class C {
    grammar D {
        rule test { a+ }
    }
}
#?pugs skip 'No such subroutine: &C::D'
{
    ok(C::D ~~ Grammar,            'C::D is a grammar');
    #?niecza skip 'Cannot dispatch to a method on D because it is not inherited or done by Cursor'
    ok('aaa' ~~ /<C::D::test>/,    'could call rule in nested grammar');
    #?niecza skip 'Cannot dispatch to a method on D because it is not inherited or done by Cursor'
    ok(!('bbb' ~~ /<C::D::test>/), 'rule in nested grammar behaves correctly');
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/open_closed.t�������������������������������������������������������0000664�0001750�0001750�00000003306�12224265625�020137� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use MONKEY_TYPING;

use Test;

plan 9;

# syn r14552

# L<S12/"Open vs Closed Classes"/"a pragma for selecting global semantics of the underlying object-oriented engine">

use oo :closed :final;

class Foo {
    method a {'called Foo.a'}
}

eval_dies_ok('augment class Foo {method b {"called Foo.b"}}}', 'adding to closed class dies');

class Bar is open {
    method c {'called Bar.c'}
}
augment class Bar {
    method d {'called Bar.d'}
}

{
    my $o = Bar.new;
    is($o.c, 'called Bar.c', 'old method is still present');
    is($o.d, 'called Bar.d', 'new method is also present');
}

{
    # S12 gives the example of 'use class :open' as well as 'use oo :closed'
    # this seems weird to me.
    use class :open;
    class Baz {method e {'called Baz.e'}}
    augment class Baz {
        method f {'called Baz.f'}
    }

    my $o = Baz.new;
    is($o.e, 'called Baz.e', 'old method is still present');
    is($o.f, 'called Baz.f', 'new method is present as well');
}

# L<S12/"Open vs Closed Classes"/"or by lexically scoped pragma around the class definition">
# and just when you thought I ran out of generic identifiers
use class :open<Qux>;
class Qux {method g {'called Qux.g'}}
{
    augment class Qux {
        method h {'called Qux.i'}
    }
    my $o = Qux.new;
    is($o.g, 'called Qux.g', 'old is still present');
    is($o.h, 'called Qux.h', 'new method is present as well');
}

# L<S12/"Open vs Closed Classes"/"declaring individual classes closed or final">
# try a few things that come to mind to make sure it's not lurking
eval_dies_ok('class ClosedAlpha is closed {}', '"is closed" is not implemented');
eval_dies_ok('class ClosedBeta  is final  {}', '"is final"  is not implemented');

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/open.t��������������������������������������������������������������0000664�0001750�0001750�00000002706�12224265625�016611� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use MONKEY_TYPING;

use Test;
plan 8;

# L<S12/Open vs Closed Classes>

class Something {
    has $.attribute;
    method in_Something { 'a' ~ $.attribute };
}

my $x = Something.new(attribute => 'b');

is $x.in_Something, 'ab', 'basic OO sanity';

# although we use curlies here to be better fudge-able, remeber
# that 'augment' class extensions are *not* lexically scoped
{
    augment class Something {
        method later_added {
            'later'
        }
        method uses-other-methods {
            'blubb|' ~ self.in_Something;

        }
    }

    my $y = Something.new(attribute => 'c');
    is $y.later_added, 'later', 'can call method that was later added';
    is $y.uses-other-methods, 'blubb|ac', 'can call new method that calls other methods';

    is $x.later_added, 'later', 'can call method on object that was instantiated earlier';
    is $x.uses-other-methods, 'blubb|ab', 'works with other method too';
}

# now try to extend "core" types
# RT #75114
{
    augment class Str {
        method mydouble {
            self.uc ~ self.lc;
        }
    }

    is 'aBc'.mydouble, 'ABCabc', 'can extend Str';
}

# RT #75114
{
    augment class Int {
        method triple { self * 3 }
    }
    is 3.triple, 9, 'can extend Int';
}

{
    augment class Array {
        method last-and-first {
            self[self - 1] ~ self[0]
        }
    }

    my @a = 1, 3, 7, 0;
    is @a.last-and-first, '01', 'can extend class Array';
}

# vim: ft=perl6
����������������������������������������������������������rakudo-2013.12/t/spec/S12-class/parent_attributes.t�������������������������������������������������0000664�0001750�0001750�00000001206�12224265625�021401� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 3;

=begin description

=head1 Initialization of parent attributes

These are some tests for "Construction and Initialization" section of Synopsis
12, based on example code from Jonathan Worthington's Rakudo tests for
parent attribute initialization

=end description

# L<S12/Construction and Initialization/>

class Foo {
    has $.x is rw;
    method boo { $.x }
}

class Bar is Foo {
    method set($v) { $.x = $v }
}

my Foo $u .= new(x => 5);
is($u.boo, 5, 'set attribute');

$u= Bar.new(Foo{ x => 12 });
is($u.boo, 12, 'set parent attribute');
$u.set(9);
is($u.boo, 9,  'reset parent attribute');

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/rw.t����������������������������������������������������������������0000664�0001750�0001750�00000001535�12224265625�016277� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 5;

# L<S12/Attributes/If you declare the class as>

class Foo {
    has $.readonly_attr;
}

{
    my Foo $foo .= new;
    #?pugs todo 'bug'
    dies_ok { $foo.readonly_attr++ }, "basic sanity";
}


class Bar is rw {
    has $.readwrite_attr;
    has $.but_not_this is readonly;
}

{
    my Bar $bar .= new(but_not_this => 42);
    
    lives_ok { $bar.readwrite_attr++ },
        "'is rw' on the class declaration applies to all attributes (1)";
    is $bar.readwrite_attr, 1,
        "'is rw' on the class declaration applies to all attributes (2)";

    #?pugs todo
    dies_ok { $bar.but_not_this = 42 },
        "'is readonly' on a specific attribute can overrule the is rw on the class (1)";
    is $bar.but_not_this, 42,
        "'is readonly' on a specific attribute can overrule the is rw on the class (2)";
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/self-inheritance.t��������������������������������������������������0000664�0001750�0001750�00000000663�12224265625�021070� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 2;

=begin pod

xinming audreyt: class A is A { };    <---  This error is reported at compile time or runtime?
xinming I mean, it will reported when it sees `class A is A` or, when A.new is invoked
audreyt I suspect compile time is the correct answer

=end pod

eval_dies_ok 'role RA does RA { }; 1', "Testing `role A does A`";
eval_dies_ok 'class CA is CA { }; 1', "Testing `class A is A`";


# vim: ft=perl6
�����������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/stubs.t�������������������������������������������������������������0000664�0001750�0001750�00000002143�12224265625�017003� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S12/Classes/You can predeclare a stub class>

plan 8;

eval_lives_ok q[ class StubA { ... }; class StubA { method foo { } }; ],
              'Can stub a class, and later on declare it';
eval_lives_ok q[ role StubB { ... }; role StubB { method foo { } }; ],
              'Can stub a role, and later on declare it';
eval_lives_ok q[ module StubC { ... }; module StubC { sub foo { } }; ],
              'Can stub a module, and later on declare it';

#?niecza todo 'broken in nom-derived stub model'
#?rakudo todo 'nom regression'
eval_lives_ok q[ package StubD { ... }; class StubD { method foo { } }; ],
              'Can stub a package, and later on implement it as a method';

# not quite class stubs, but I don't know where else to put the tests...

lives_ok { sub {...} }, 'not execued stub code is fine';
dies_ok { (sub {...}).() ~ '' }, 'execued stub code goes BOOM when used';
dies_ok { use fatal; (sub { ... }).() }, 'exeucted stub code goes BOOM under fatal';

eval_dies_ok q[my class StubbedButNotDeclared { ... }], 'stubbing a class but not providing a definition dies';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-class/type-object.t�������������������������������������������������������0000664�0001750�0001750�00000000612�12224265625�020067� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

is Any.Str,     '',      'Any.Str is empty string';
is Any.Stringy, '',      'Any.Str is empty string';
is Any.gist,    '(Any)', 'Any.gist has those parens';

# maybe a bit too retrictive?
is Any.perl,    'Any',   'Any.perl does not have parens';

is Any.^name,   'Any',   '.^name';

isa_ok (class A { }).new, A, 'can instantiate return value of class declaration';
����������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-construction/autopairs.t��������������������������������������������������0000664�0001750�0001750�00000001241�12224265625�021275� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 4;


#L<S02/"Literals"/"There is now a generalized adverbial form">

{
    eval_lives_ok('my $a; class Ta { has $.a }; my Ta $c .= new(:$a)',
            'class instantiation with autopair, no spaces');
    eval_lives_ok('my $a; class Tb { has $.a }; my Tb $Tb .= new(:$a )',
            'class instantiation with autopair, spaces');
    #?rakudo 2 todo 'nom regression'
    eval_lives_ok('my $a; role Tc { has $.a }; my Tc $c .= new(:$a)',
            'role instantiation with autopair, no spaces');
    eval_lives_ok('my $a; role Td { has $.a }; my Td $c .= new(:$a )',
            'role instantiation with autopair, spaces');
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-construction/BUILD.t������������������������������������������������������0000664�0001750�0001750�00000005142�12224265625�020131� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 9;

# L<S12/Semantics of C<bless>/The default BUILD and BUILDALL>

{
    my Str $calls = '';
    my Str $gather = '';
    my Int $parent-counter = 0;
    my Int $child-counter = 0;
    
    class Parent {
        submethod BUILD (:$a) {
            $parent-counter++;
            $calls ~= "Parent";
            $gather ~= "Parent(a): ($a)";
        }
    }

    class Child is Parent {
        submethod BUILD (:$a, :$b) {
            $child-counter++;
            $calls ~= " | Child";
            $gather ~= " | Child(a, b): ($a, $b)";
        }
    }

    my $obj = Child.new(:b(5), :a(7));

    is $parent-counter, 1, "Called Parent's BUILD method once";
    is $child-counter, 1, "Called Child's BUILD method once";
    is $calls, 'Parent | Child', 
        'submethods were called in right order (Parent first)';
    #?niecza todo "Worrisome"
    is $gather, 'Parent(a): (7) | Child(a, b): (7, 5)', 
        'submethods were called with the correct arguments';
}

# assigning to attributes during BUILD
# multiple inheritance
{
    my $initlist = '';
    sub reg($x) { $initlist ~= $x };
    
    class A_Parent1 {
        submethod BUILD() {
            reg('A_Parent1');
        }
    }

    class A_Parent2 {
        submethod BUILD() {
            reg('A_Parent2');
        }
    }

    class A_Child is A_Parent1 is A_Parent2 {
        submethod BUILD() {
            reg('A_Child');
        }
    }

    class A_GrandChild is A_Child {
        submethod BUILD() {
            reg('A_GrandChild');
        }
    }

    my $x;
    lives_ok { $x = A_GrandChild.new() }, 
        "can call child's methods in parent's BUILD";
    ok ?($initlist eq 'A_Parent1A_Parent2A_ChildA_GrandChild' 
                    | 'A_Parent2A_Parent1A_ChildA_GrandChild'),
    'initilized called in the right order (MI)';
}

# RT #63900
{
    # I think this test is obsolete given the above tests, but maybe I'm missing something
    my %counter;
    class RT63900_P {
        submethod BUILD {
            %counter{ 'BUILD' }++;
        }
    }
    class RT63900_C is RT63900_P {
    }

    my $c = RT63900_C.new();
    is %counter<BUILD>, 1, 'BUILD called once';
}

#?rakudo todo 'method BUILD should warn'
#?niecza todo
{
    BEGIN { @*INC.push: 't/spec/packages' }
    use Test::Util;
    is_run
        'class Foo { method BUILD() { ... } }',
        { out => '', err => /BUILD/ & /submethod/ },
        'method BUILD produces a compile-time warning';
}

# RT #95340
{
    class C { has %!p; submethod BUILD(:%!p) {} };
    lives_ok { C.new }, 'can call BUILD without providing a value for a !-twigiled named parameter';
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-construction/construction.t�����������������������������������������������0000664�0001750�0001750�00000005244�12250462647�022031� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 18;

# L<S12/"Construction and Initialization">

class OwnConstr {
    has $.x = 13;
    my $in_own = 0;
    method own() {
        $in_own++;
        return self.bless(self.CREATE(), :x(42));
    }
    method in_own {
        $in_own;
    }
}
ok OwnConstr.new ~~ OwnConstr, "basic class instantiation";
is OwnConstr.new.x, 13,        "basic attribute access";
# As usual, is instead of todo_is to suppress unexpected succeedings
is OwnConstr.in_own, 0,                   "own constructor was not called";

ok OwnConstr.own ~~ OwnConstr, "own construction instantiated its class";
is OwnConstr.own.x, 42,        "attribute was set from our constructor";
is OwnConstr.in_own, 2,        "own constructor was actually called";


# L<"http://www.mail-archive.com/perl6-language@perl.org/msg20241.html">
# provide constructor for single positional argument

class Foo {
  has $.a;
  
  method new ($self: Str $string) {
    $self.bless(a => $string);
  }
}


ok Foo.new("a string") ~~ Foo, '... our Foo instance was created';

#?pugs todo 'feature'
is Foo.new("a string").a, 'a string', "our own 'new' was called";


# Using ".=" to create an object
{
  class Bar { has $.attr }
  my Bar $bar .= new(:attr(42));
  is $bar.attr, 42, "instantiating an object using .= worked (1)";
}
# Using ".=()" to create an object
{ 
  class Fooz { has $.x }
  my Fooz $f .= new(:x(1));
  is $f.x, 1, "instantiating an object using .=() worked";
}

{
  class Baz { has @.x is rw }
  my Baz $foo .= new(:x(1,2,3));
  lives_ok -> { $foo.x[0] = 3 }, "Array initialized in auto-constructor is not unwritable...";
  is $foo.x[0], 3, "... and keeps its value properly."
}	

# RT #64116
#?niecza skip 'System.NullReferenceException: Object reference not set to an instance of an object'
{
    class RT64116 { has %.env is rw };

    my $a = RT64116.CREATE;

    lives_ok { $a.env = { foo => "bar" } }, 'assign to attr of .CREATEd class';
    is $a.env<foo>, 'bar', 'assignment works';
}

# RT #76476
{
    use MONKEY_TYPING;
    class MonkeyNew { has $.x is rw };
    augment class MonkeyNew {
        method new() {
            self.bless(:x('called'));
        }
    };
    is MonkeyNew.new().x, 'called', 'monkey-typed .new() method is called';
}

#?niecza skip "Malformed has (int NYI, I think)"
{
    class NativeInt {
        has int $.attr;
    }
    lives_ok -> { NativeInt.new(:attr(123)) }, ".new with a native int attribute";
    class NativeNum {
        has num $.attr;
    }
    lives_ok -> { NativeNum.new(:attr(0e0)) }, ".new with a native num attribute";
    class NativeStr {
        has str $.attr;
    }
    lives_ok -> { NativeStr.new(:attr<foo>) }, ".new with a native str attribute";
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-construction/destruction.t������������������������������������������������0000664�0001750�0001750�00000002207�12224265625�021634� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 6;

# L<S12/"Semantics of C<bless>"/"DESTROY and DESTROYALL work the
# same way, only in reverse">

my $in_destructor = 0;
my @destructor_order;

class Foo
{
    submethod DESTROY { $in_destructor++ }
}

class Parent
{
    submethod DESTROY { push @destructor_order, 'Parent' }
}

class Child is Parent
{
    submethod DESTROY { push @destructor_order, 'Child' }
}

my $foo = Foo.new();
isa_ok($foo, Foo, 'basic instantiation of declared class' );
ok( ! $in_destructor,    'destructor should not fire while object is active' );

my $child = Child.new();
undefine $child;

# no guaranteed timely destruction, so replace $a and try to force some GC here
for 1 .. 100
{
    $foo = Foo.new();
}

#?pugs 2 skip 'broken after Object -> Mu conversion'
ok( $in_destructor, '... only when object goes away everywhere'               );
is( +@destructor_order, 2, '... only as many as available DESTROY submethods' );
#?pugs 2 skip 'order is not guaranteed in pugs'
is(  @destructor_order[0], 'Child',  'Child DESTROY should fire first'        );
is(  @destructor_order[1], 'Parent', '... then parent'                        );

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-construction/named-params-in-BUILD.t��������������������������������������0000664�0001750�0001750�00000000761�12224265625�023102� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 3;
# L<S12/Semantics of C<bless>/The default BUILD and BUILDALL>

class Foo {
    has $.v;
    submethod BUILD (Str :$value) {
        $!v = $value;
    }
}

my $obj = Foo.new( value => 'bar' );

is( $obj.v, 'bar', 
    'BUILD arg declared as named and invoked with literal pair should'
    ~ ' contain only the pair value' );
isa_ok($obj.v, Str, 'same arg should be of declared type' );
isa_ok($obj, Foo, 'The object was constructed of the right type');

# vim: ft=perl6
���������������rakudo-2013.12/t/spec/S12-construction/new.t��������������������������������������������������������0000664�0001750�0001750�00000007001�12224265625�020057� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 25;

class Parent {
    has $.x;
}

class Child is Parent {
    has $.y;
}

my $o;
lives_ok { $o =  Child.new(:x(2), :y(3)) }, 
         'can instantiate class with parent attributes';

is $o.y, 3, '... worked for the child';
is $o.x, 2, '... worked for the parent';

# RT #76490
#?rakudo 3 todo 'parent attributes in initialization'
#?niecza 3 todo
lives_ok { $o = Child.new( :y(4), Parent{ :x<5> }) }, 
         'can instantiate class with explicit specification of parent attrib';

is $o.y, 4, '... worked for the child';
is $o.x, 5, '... worked for the parent';

class GrandChild is Child {
}

#?rakudo 6 todo 'parent attributes in initialization'
#?niecza 6 todo
lives_ok { $o = GrandChild.new( Child{ :y(4) }, Parent{ :x<5> }) },
         'can instantiate class with explicit specification of parent attrib (many parents)';
is $o.y, 4, '... worked for the class Child';
is $o.x, 5, '... worked for the class Parent';
lives_ok { $o = GrandChild.new( Parent{ :x<5> }, Child{ :y(4) }) }, 
         'can instantiate class with explicit specification of parent attrib (many parents, other order)';
is $o.y, 4, '... worked for the class Child (other order)';
is $o.x, 5, '... worked for the class Parent (other order)';

# RT #66204
{
    class RT66204 {}
    ok ! RT66204.defined, 'NewClass is not .defined';
    dies_ok { RT66204 .= new }, 'class asked to build itself refuses';
    ok ! RT66204.defined, 'NewClass is still not .defined';
}

# RT 71706
{
    class RT71706 {
        class RT71706::Artie {}
    }
    # TODO: check the error message, not just the timing.
    #?rakudo todo "nested package handling does't quite get this one right"
    #?niecza todo
    dies_ok { RT71706::Artie.new }, 'die trying to instantiate missing class';
}

# RT #69676
{
    class NewFromMu {
        has $.x;
        has $.y;

        method new($a, $b) {
            self.Mu::new(:x($a), :y($b));
        }
    }

    my $x;
    lives_ok { $x = NewFromMu.new('j', 'k') }, 'can delegate to self.Mu::new';
    is $x.x, 'j', '... got the right attribute (1)';
    is $x.y, 'k', '... got the right attribute (2)';
}

#?niecza skip "Cannot call new; none of these signatures match"
{
    my class MultiNewFromMu {
        has $.x;
        multi method new($x) {
            self.new(:$x);
        }
    }
    is MultiNewFromMu.new('wirklich!').x, 'wirklich!',
       'Mu.new is a multi method';
}

# RT #68756
{

    class RT68756 {
        has $.a1;
        has $.a2;

        multi method new(Int $number, Str $color) {
            self.bless(:a1($number), :a2($color));
        }
    }


    my RT68756 $foo .= new(2, "geegaw");
    is_deeply [ $foo.a1, $foo.a2 ],
        [2, "geegaw"],
        'multi-constructor class alternate (positional) constructor';

    #?niecza emit # fails 
    my RT68756 $bar .= new(:a1(3), :a2<yoohoo>);
    #?niecza skip 'Without previous line, this is a disaster'
    is_deeply [ $bar.a1, $bar.a2 ],
        [3, "yoohoo"],
        'multi-constructor class alternate default named constructor';
}

# RT #68558
{
    class RT68558 {
        has $.foo;
        method new($foo) { nextwith(:$foo) }
    }
    is RT68558.new('x').foo, 'x', 'Can call nextwith in .new';

}

# RT #100780
#?niecza skip 'dies more thoroughly than okay'
{
    dies_ok { X.new }, 'RT #100780'
}

# RT #74300
#?niecza skip 'No candidates for dispatch to new'
{
    class RT74300 {
        has $.foo;
        multi method new($) {}
    }
    is RT74300.new(:foo<bar>).foo, 'bar', 'multi method($) does not break attribute initialization';
}

done;

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-enums/anonymous.t���������������������������������������������������������0000664�0001750�0001750�00000001246�12224265625�017720� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 7;

# Tests for anonymous enumerations.

# L<S12/Anonymous Enumerations/An anonymous enum just makes sure each string turns into a pair>

my $e = enum < ook! ook. ook? >;
is $e.keys.elems, 3, 'anonymous enum created correct sized hash';
is $e<ook!>,      0, 'anonymous enum created correctly';
is $e<ook.>,      1, 'anonymous enum created correctly';
is $e<ook?>,      2, 'anonymous enum created correctly';
isa_ok $e, EnumMap, 'anonymous enum returns an EnumMap';

my %e1 = enum <foo>;
is %e1.keys.elems, 1, 'single-value anonymous enum created correct sized hash';
is %e1<foo>,       0, 'single-value anonymous enum created correctly';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-enums/as-role.t�����������������������������������������������������������0000664�0001750�0001750�00000001715�12224265625�017233� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 9;

#L<S12/Anonymous Mixin Roles using C<but> or C<does>/they may be used to name a desired property>

enum Maybe <No Yes Dunno>;
class Bar            { }

{
    class Foo does Maybe { }

    my $x = Foo.new(Maybe => No);

    ok($x.No,     'Can test for enum members set by .new()');
    ok(!$x.Yes,   'Can test for enum members set by .new()');
    ok(!$x.Dunno, 'Can test for enum members set by .new()');
}

{
    my $y = Bar.new() does Maybe(Yes);

    ok(!$y.No,    'Can test for enum members set by does Maybe(Yes)');
    ok($y.Yes,    'Can test for enum members set by does Maybe(Yes)');
    ok(!$y.Dunno, 'Can test for enum members set by does Maybe(Yes)');
}

{
    my $z = Bar.new() but Maybe(Dunno);

    ok(!$z.No,    'Can test for enum members set by but Maybe(Dunno)');
    ok(!$z.Yes,   'Can test for enum members set by but Maybe(Dunno)');
    ok($z.Dunno,  'Can test for enum members set by but Maybe(Dunno)');
}


# vim: ft=perl6
���������������������������������������������������rakudo-2013.12/t/spec/S12-enums/basic.t�������������������������������������������������������������0000664�0001750�0001750�00000007057�12224265625�016757� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# Very basic enum tests

# L<S12/Enumerations/the keys are specified as a parenthesized list>

enum Day <Sun Mon Tue Wed Thu Fri Sat>;
{
    is 0 + Day::Sun, 0, 'First item of an enum is 0';
    is 0 + Day::Sat, 6, 'Last item has the right value';
    is 0 + Sun,      0, 'Values exported into namespace too.';
    is 0 + Sat,      6, 'Values exported into namespace too.';
}

{
    # check that the values can be used for ordinary tasks, like
    # constructing ranges
    isa_ok (Mon..Wed), Range, 'Can construct ranges from Enum values';
    ok Mon + Tue == Wed, 'Can do arithmetics with Enum values';
}

#?rakudo skip 'Cannot convert string to number'
#?niecza skip 'enummish but'
{
    my $x = 'Today' but Day::Mon;
    ok $x.does(Day),      'Can test with .does() for enum type';
    ok $x ~~ Day,         'Can smartmatch for enum type';
    ok $x ~~ Day::Mon,    'Can Smartmatch for enum value';
    my $check = 0;
    given $x {
        when Day::Mon { $check = 1 }
        when Day::Tue { $check = 2 }
    }
    is $check, 1,         'given/when with enum values';
    $check = 0;
    given $x {
        when Tue { $check = 1 }
        when Mon { $check = 2 }
    }
    is $check, 2,         'given/when with enum values';
}

{
    # usually we don't test explicit value for .perl, but here
    # it's specced, so we make an exception
    is Day::Mon.perl, 'Day::Mon', '.perl on long form of Enum key';
    is Mon.perl,      'Day::Mon', '.perl on short form of Enum value';

    is Day::Mon.key,  'Mon',      '.key on long form of Enum value';
    is Mon.key,       'Mon',      '.key on short form of Enum value';

    is Day::Mon.WHAT.gist, '(Day)',    '.WHAT.gist on enum value stringifies to the enum name';
}

{
    enum roman (i => 1,   v => 5,
                x => 10,  l => 50,
                c => 100, d => 500,
                m => 1000);
    ok v == 5, 'enum with parens works and non-0 starting point works';
    is v.perl, 'roman::v', '.perl works on enum with parens';
    is v.key,  'v',        '.key works on enum with parens';
}

enum JustOne <Thing>;
{
    ok JustOne::Thing == 0, 'Enum of one element works.';
}

#?niecza skip "Enum must have at least one value"
lives_ok { enum Empty < > }, "empty enum can be constructed";

#?niecza todo "Enum must have at least one value"
eval_lives_ok 'enum Empty2 ()', 'empty enum with () can be constructed';

enum Color <white gray black>;
my Color $c1 = Color::white;
ok($c1 == 0, 'can assign enum value to typed variable with long name');
my Color $c2 = white;
ok($c1 == 0, 'can assign enum value to typed variable with short name');
dies_ok({ my Color $c3 = "for the fail" }, 'enum as a type enforces checks');

# conflict between subs and enums
{
    my sub white { 'sub' };
    ok white == 0, 'short name of the enum without parenthesis is an enum';
    #?niecza skip 'nonworking'
    is white(), 'sub', 'short name with parenthesis is a sub';
}

# L<S12/The C<.pick> Method/"define a .pick method">
{
    lives_ok { my Color $k = Color.pick }, 'Color.pick assigns to Color var';
    isa_ok Color.pick, Color.pick.WHAT, 'Color.pick.isa';

    ok ?(Color.pick == any(Color::white, Color::gray, Color::black)),
            '.pick on enums';
    ok Color.pick(2) == 2, '.pick(2) on enums';
}

{
    enum RT71460::Bug <rt71460 bug71460 ticket71460>;
    ok bug71460 == 1, 'enum element of enum with double colons is in namespace';
}

# RT #77982
{
    enum T1 <a b c>;
    enum T2 <d e f>;
    is T1.enums.keys.sort.join('|'), 'a|b|c', 'enum keys (1)';
    is T2.enums.keys.sort.join('|'), 'd|e|f', 'enum keys (2)';
}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-enums/misc.t��������������������������������������������������������������0000664�0001750�0001750�00000002735�12224265625�016627� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# RT #63826
{
    class EnumClass     { enum C <a b c> }
    is +EnumClass::C::a, 0, 'enum element in class has the right value';

    module EnumModule   { enum M <a b c> }
    is +EnumModule::M::b, 1, 'enum element in module has the right value';

    package EnumPackage { enum P <a b c> }
    is +EnumPackage::P::c, 2, 'enum element in package has the right value';

    role EnumRole       { enum R <a b c> }
    #?rakudo skip 'RT 63826'
    is +EnumRole::R::a, 0, 'enum element in role has the right value';

    grammar EnumGrammar { enum G <a b c> }
    is +EnumGrammar::G::b, 1, 'enum element in grammar has the right value';
}

# RT 66648
{
    enum RT66648 <a b c>;
    dies_ok { RT66648.c }, 'die attempting to access enum item as method';
}

# RT #70894

{
    enum SomeEnum <a b c>;
    lives_ok {SomeEnum::.keys}, 'keys on enum stash works';

}

# L<S12/Miscellaneous Rules>
# see also: RT #63650
{
    enum Maybe <OK FAIL>;
    sub OK { 'sub OK' };
    is OK,    'OK',     'enum key wins in case of conflict';
    is +OK,   0,        'enum key wins in case of conflict (numeric)';
    #?niecza skip 'No value for parameter $key in CORE CommonEnum.postcircumfix:<( )>'
    is OK(),  'sub OK', 'but () is still a function call';
    is FAIL,  'FAIL',   'non-conflicting enum key';
    is +FAIL, 1,        'non-conflicting enum key (numeric)';
    # RT #112202
    #?niecza todo
    lives_ok { OK.^methods }, 'can call .^methods on an enum';
}

done;

# vim: ft=perl6
�����������������������������������rakudo-2013.12/t/spec/S12-enums/non-int.t�����������������������������������������������������������0000664�0001750�0001750�00000001170�12224265625�017246� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 6;

{
    my enum A (a => 'foo', b => 'bar');
    is a.Str, 'foo', 'stringy enum first value';
    is b.Str, 'bar', 'stringy enum first value';
}

eval_dies_ok 'my enum B (a => 1, b => "bar")',
             'mixed type enums are forbidden';

#?rakudo todo 'NYI'
#?niecza todo
eval_lives_ok 'my Cool enum C (a => 1, b => "bar")',
             '... unles that type covers both enum value types';

#?niecza todo
eval_dies_ok 'my Str enum D (a => 1)',
             'violating an explict type constraint dies';

{
    my enum E ( a => 'x', 'b');
    is E::b.Str, 'y', 'Str enum correctly uses string-increment';
}
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-enums/pseudo-functional.t�������������������������������������������������0000664�0001750�0001750�00000001450�12224265625�021324� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 11;

# L<S12/Anonymous Mixin Roles using C<but> or C<does>/enumeration supplies the type name as a coercion>

enum day (:Sun(1), 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');

is day(Tue), day(3), 'day(Tue) same as day(3)';

{
    my $today_tue = 'Today' but day(Tue);
    my $today_3   = 'Today' but day(3);

    is $today_tue, $today_3, 'day(Tue) same as day(3) in variables';
}

my $x = 'Today' but day(Tue);

ok $x.day ~~ day,  'day(Tue).day is a day';
ok $x.day == Tue,  'day(Tue) == Tue';
lives_ok { day($x) }, 'day($x) lives';
ok $x.Tue,         'day(Tue).Tue';

ok $x.day != Wed, 'day(Tue) != Wed';

nok $x.does(Wed), '! day(Tue).does(Wed)';
nok $x.Wed,       '! day(Tue).does(Wed)';
nok 8.does(day),  '8 is not a day';
nok 8 ~~ day,     '8 does not match day';

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-enums/thorough.t����������������������������������������������������������0000775�0001750�0001750�00000006553�12231454405�017532� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use MONKEY_TYPING;

use Test;


=begin description

Enum tests from L<S12/Enumerations>

=end description

#?pugs 999 skip
# L<S12/Enumerations/keys are specified as a parenthesized list>
enum day <Sun Mon Tue Wed Thu Fri Sat>;

is day.gist, '(day)', 'enum itself stringififes';
ok day.WHAT === day,  'enum.WHAT returned a value';
ok day.perl, 'enum.perl returned a value';

sub test_stuff($x) {
  #?niecza skip 'No candidates for dispatch to infix:<does>'
  ok $x.does(day::Tue),    "basic enum mixing worked ($x-2)";
  is $x.day, 2,            "automatically created accessor worked ($x)";
  is day::Tue, 2,          "enum provided a correct mapping ($x)";
  ok $x ~~ day,            "smartmatch worked correctly ($x-1)";
  ok $x ~~ Tue,            "smartmatch worked correctly ($x-2)";
  ok $x ~~ day::Tue,       "smartmatch worked correctly ($x-3)";
  ok $x !~~  Wed,          "smartmatch worked correctly ($x-4)";
  #?niecza skip 'No candidates for dispatch to infix:<does>'
  ok $x.does(Tue),         ".does worked correctly ($x-1)";
  #?niecza skip 'No candidates for dispatch to infix:<does>'
  ok $x.does(day),         ".does worked correctly ($x-2)";
  ok $x.Tue,               ".Tue() worked correctly ($x)";
  ok $x.Tue.WHAT === day,  '$obj.Tue.WHAT returns the proper type object';
  ok $x.Tue.perl,          '$obj.Tue.perl returns a true valuee';
}

#?rakudo skip 'NYI'
{
  my $x = 1;
  is $x, 1, "basic sanity (1)";
  # L<S12/Enumerations/on the right side of a but or does.>
  #?niecza skip 'No candidates for dispatch to infix:<does>'
  ok $x does day(Tue), "basic enum mixing worked (1-1)";
  test_stuff($x);
}


#?rakudo skip 'does day::Tue'
{
  my $x = 3;
  is $x, 3, "basic sanity (3)";
  ok $x does day::Tue, "basic enum mixing worked (3-1)";
  test_stuff($x);
}

#?DOES 16
#?rakudo skip 'does &day::("Tue")'
{
  my $x = 4;
  is $x, 4, "basic sanity (4)";
  # L<S12/Enumerations/Mixing in the full enumeration type produces a
  # read-write attribute>
  ok $x does day,            "basic enum mixing worked (4-0)";
  ok $x.day = &day::("Tue"), "basic enum mixing worked (4-1)";
  test_stuff($x);
}

# used to be Rakudo regression, RT #64098
#?DOES 2
{
    augment class Mu {
        method f { 'inMu' };
    }

    augment class Bool {
        method f { 'inBool' };
    }
    is True.f, 'inBool', 'method on short name pick up the one from the enum';
    is Bool::True.f, 'inBool', 'method on long name pick up the one from the enum';
}

ok True.perl ~~/^ 'Bool::True'/, 'True.perl';
ok Bool::True.perl ~~/^ 'Bool::True'/, 'Bool::True.perl';

{
    enum Negation << :isnt<isnt> :arent<arent> :amnot<amnot> :aint<aint> >>;
    my Negation $foo;
    lives_ok { $foo = Negation::isnt }, 'simple assignment from enum';
    is $foo, Negation::isnt, 'assignment from enum works';
}

# RT #66886
{
    enum RT66886 <b>;
    eval_dies_ok 'RT66886::c', 'accessing non-value of enum dies proper-like';
}

# RT #65658
{
    enum RT65658 <Todo Bug Feature Ticket>;
    is RT65658(2), RT65658::Feature, 'can index enum by number';
    is RT65658((Todo + 3.2).Int), RT65658::Ticket, 'enum and math and index';
}

# RT #71196
{
    #?niecza skip 'Two terms in a row'
    eval_lives_ok 'enum X is export <A B C>', 'marking enum export does not die';
}

# RT #101900
{
    eval_dies_ok "enum rt_101900 < a b >; class A { }; say A but rt_101900::a",
        "Cannot mixin an enum into a class";
}

done;

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/attributes.t������������������������������������������������0000664�0001750�0001750�00000005360�12224265625�021630� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 30;

=begin pod

Tests for .^attributes from L<S12/Introspection>.

=end pod

# L<S12/Introspection/"The .^attributes method">

class A {
    has Str $.a = "dnes je horuci a potrebujem pivo";
}
class B is A {
    has Int $!b = 42;
}
class C is B {
    has $.c is rw
}

my @attrs = C.^attributes();
is +@attrs, 3, 'attribute introspection gave correct number of elements';

is @attrs[0].name,         '$!c',  'first attribute had correct name';
is @attrs[0].type.gist,    '(Mu)', 'first attribute had correct type';
is @attrs[0].has-accessor, True,   'first attribute has an accessor';
ok !@attrs[0].build,               'first attribute has no build value';
ok @attrs[0].rw,                   'first attribute is rw';
ok !@attrs[0].readonly,            'first attribute is not readonly';

is @attrs[1].name,         '$!b',   'second attribute had correct name';
is @attrs[1].type.gist,    '(Int)', 'second attribute had correct type';
is @attrs[1].has-accessor, False,   'second attribute has no accessor';
ok @attrs[1].build ~~ Code,         'second attribute has build block';
is @attrs[1].build().(C, $_), 42,
                              'second attribute build block gives expected value';

is @attrs[2].name,         '$!a',   'third attribute had correct name';
is @attrs[2].type.gist,    '(Str)', 'third attribute had correct type';
is @attrs[2].has-accessor, True,    'third attribute has an accessor';
ok @attrs[2].build ~~ Code,         'third attribute has build block';
is @attrs[2].build().(C, $_), "dnes je horuci a potrebujem pivo",
                                    'third attribute build block gives expected value';
ok !@attrs[2].rw,                   'third attribute is not rw';
ok @attrs[2].readonly,              'third attribute is readonly';

@attrs = C.^attributes(:local);
is +@attrs,        1,     'attribute introspection with :local gave just attribute in base class';
is @attrs[0].name, '$!c', 'get correct attribute with introspection';

#?rakudo skip ':tree not implemented for .^attributes'
{
    @attrs = C.^attributes(:tree);
    is +@attrs, 2,                  'attribute introspection with :tree gives right number of elements';
    is @attrs[0].name, '$!c',       'first element is attribute desriptor';
    ok @attrs[1] ~~ Array,          'second element is array';
    is @attrs[1][0].name, '$!b',    'can look into second element array to find next attribute';
    is @attrs[1][1][0].name, '$!a', 'can look deeper to find attribute beyond that';
}

{
    my $x = A.new(a => 'abc');
    my $attr = $x.^attributes(:local).[0];
    isa_ok $attr, Attribute;
    is $attr.get_value($x), 'abc', '.get_value works';
    lives_ok { $attr.set_value($x, 'new') }, 'can set_value';
    is $x.a, 'new', 'set_value worked';

}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/can.t�������������������������������������������������������0000664�0001750�0001750�00000006513�12224265625�020204� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Tests for can.

=end pod

plan 25;

# L<S12/"Introspection"/Unlike in Perl 5 where .can returns a single Code object>

lives_ok { Str.can("split") },   "method can on built-in Str works";
ok "foo".can("split"),           "methd can on built-in Str gives correct result if method found";
#?niecza todo '.can returns something Positional'
ok "foo".can("split") ~~ Positional, '.can returns  something Positional';
ok !"foo".can("hazcheezburger"), "methd can on built-in Str gives correct result if method not found";
ok "bar".^can("split"),          "calling ^can also works";
ok "x".HOW.can("x", "split"),    "and also through the HOW";
ok Str.can("split"),             "can call on the proto-object too";
ok !Str.can("hazcheezburger"),   "can call on the proto-object too";

class Dog {
    method bark {
        "bow";
    }
}

my $dog = Dog.new;
lives_ok { $dog.can("bark") }, "method can on custom class works";
ok $dog.can("bark"),           "method can on custom class gives correct result if method found (on instance)";
ok !$dog.can("w00f"),          "method can on custom class gives correct result if method not found (on instance)";
ok Dog.can("bark"),            "method can on custom class gives correct result if method found (on proto)";
ok !Dog.can("w00f"),           "method can on custom class gives correct result if method not found (on proto)";

my $meth = $dog.can("bark");
#?niecza skip 'No match'
is $meth[0]($dog), "bow", "the result for can contains an invokable, giving us the sub (on instance)";
$meth = Dog.can("bark");
#?niecza skip 'No match'
is $meth[0](Dog), "bow",  "the result for can contains an invokable, giving us the sub (on proto)";

#?niecza skip 'No match'
{
    my $iters = 0;
    my $found = "";
    for $dog.can("bark") -> $meth {
        $found ~= $meth($dog);
        $iters++;
    }
    is $iters, 1,     "had right number of methods found (on instance)";
    is $found, "bow", "got right method called (on instance)";
}

#?niecza skip 'No match'
{
    my $iters = 0;
    my $found = "";
    for Dog.can("bark") -> $meth {
        $found ~= $meth($dog);
        $iters++;
    }
    is $iters, 1,     "had right number of methods found (on proto)";
    is $found, "bow", "got right method called (on proto)";
}

class Puppy is Dog {
    method bark {
        "yap";
    }
}
my $pup = Puppy.new();

#?niecza skip 'No match'
{
    my $iters = 0;
    my $found = "";
    for $pup.can("bark") -> $meth {
        $found ~= $meth($pup);
        $iters++;
    }
    is $iters, 2,        "subclass had right number of methods found (on instance)";
    is $found, "yapbow", "subclass got right methods called (on instance)";
}

#?niecza skip 'No match'
{
    my $iters = 0;
    my $found = "";
    for Puppy.can("bark") -> $meth {
        $found ~= $meth($pup);
        $iters++;
    }
    is $iters, 2,        "subclass had right number of methods found (on proto)";
    is $found, "yapbow", "subclass got right methods called (on proto)";
}

# RT #76584
#?niecza todo
ok Str.can('split') ~~ /split/, 'return value of .can stringifies sensibly';

#?niecza skip "No match"
{
    # RT #76882
    my class A {
        method b() { 'butterfly' }
    }
    sub callit($invocant, $method) { $method($invocant) };
    is callit(A.new, A.^can('b')[0]), 'butterfly',
        'can call method reference outside the class';
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/definite.t��������������������������������������������������0000664�0001750�0001750�00000001203�12224265625�021221� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 6;

=begin pod

Tests for .DEFINITE from L<S12/Introspection>.

=end pod

# L<S12/Introspection/"The DEFINITE macro">

is Int.DEFINITE, False, ".DEFINITE on type object";
is 42.DEFINITE, True,   ".DEFINITE on literal value";

my $x;
is $x.DEFINITE, False,  ".DEFINITE on undeclared variable";
$x = 'OMG THAT KANGAROO IS ON FIRE!!!11!';
is $x.DEFINITE, True,   ".DEFINITE on variable with value";

class C {
    method DEFINITE() { True }
}
is C.DEFINITE,     False, "Class declaring DEFINITE method doesn't influence .DEFINITE macro";
is C."DEFINITE"(), True,  "Quoting lets us call the method, however";  #OK Useless
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/meta-class.t������������������������������������������������0000664�0001750�0001750�00000002474�12224265625�021476� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 13;

=begin pod

Very basic meta-class tests from L<S12/Introspection>

=end pod

class Foo:ver<0.0.1> {
    method bar ($param) returns Str {
        return "baz" ~ $param
    }
};

# L<S12/Introspection/should be called through the meta object>

#?pugs emit skip_rest('meta class NYI');
#?pugs emit exit;

ok(Foo.HOW.can(Foo, 'bar'), '... Foo can bar');
#?rakudo skip 'precedence of HOW'
ok(HOW(Foo).can(Foo, 'bar'), '... Foo can bar (anthoer way)');
#?rakudo skip 'precedence of prefix:<^>'
ok(^Foo.can(Foo, 'bar'), '... Foo can bar (another way)');
ok(Foo.^can('bar'), '... Foo can bar (as class method)');
ok(Foo.HOW.isa(Foo, Foo), '... Foo is-a Foo (of course)');
ok(Foo.^isa(Foo), '... Foo is-a Foo (of course) (as class method)');

lives_ok { 4.HOW.HOW }, 'Can access meta class of meta class';

# L<S12/Introspection/Class traits may include:>

is Foo.^name(), 'Foo', '... the name() property is Foo';
#?rakudo skip '.version, version number parsing'
is Foo.^version(), v0.0.1, '... the version() property is 0.0.1';
#?rakudo skip '.layout'
is Foo.^layout, P6opaque, '^.layout';

# RT #115208
eval_lives_ok "True.HOW.say", "can output the .gist of a .HOW";

# RT #114130
{
    use lib "t/spec/packages";
    use Test::Util;
    throws_like 'Any.HOW(Foo)', X::Syntax::Argument::MOPMacro;
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/methods.t���������������������������������������������������0000664�0001750�0001750�00000014042�12224265625�021102� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 57;

=begin pod

Tests for .^methods from L<S12/Introspection>.

=end pod

# L<S12/Introspection/"get the method list of MyClass">

class A {
    method foo($param --> Any) { }   #OK not used
    multi method bar($thingy) { }   #OK not used
    multi method bar($thingy, $other_thingy) { }   #OK not used
}

class B is A {
    method foo($param) of Num { }   #OK not used
}
class C is A {
}
class D is B is C {
    multi method bar($a, $b, $c) { }   #OK not used
    method foo($param) returns Int { }   #OK not used
}

my (@methods, $meth1, $meth2);

@methods = C.^methods(:local);
is +@methods, 0, 'class C has no local methods (proto)';

@methods = C.new().^methods(:local);
is +@methods, 0, 'class C has no local methods (instance)';

@methods = B.^methods(:local);
is +@methods, 1, 'class B has one local methods (proto)';
is @methods[0].name(), 'foo', 'method name can be found';
ok @methods[0].signature.perl ~~ /'$param'/, 'method signature contains $param';
is @methods[0].returns.gist, Num.gist, 'method returns a Num (from .returns)';
is @methods[0].of.gist, Num.gist, 'method returns a Num (from .of)';
ok !@methods[0].is_dispatcher, 'method is not a dispatcher';

@methods = B.new().^methods(:local);
is +@methods, 1, 'class B has one local methods (instance)';
is @methods[0].name(), 'foo', 'method name can be found';
ok @methods[0].signature.perl ~~ /'$param'/, 'method signature contains $param';
is @methods[0].returns.gist, Num.gist, 'method returns a Num (from .returns)';
is @methods[0].of.gist, Num.gist, 'method returns a Num (from .of)';
ok !@methods[0].is_dispatcher, 'method is not a dispatcher';

@methods = A.^methods(:local);
is +@methods, 2, 'class A has two local methods (one only + one multi with two variants)';
my ($num_dispatchers, $num_onlys);
for @methods -> $meth {
    if $meth.name eq 'foo' {
        $num_onlys++;
        ok !$meth.is_dispatcher, 'method foo is not a dispatcher';
    } elsif $meth.name eq 'bar' {
        $num_dispatchers++;
        ok $meth.is_dispatcher, 'method bar is a dispatcher';
    }
}
is $num_onlys, 1, 'class A has one only method';
is $num_dispatchers, 1, 'class A has one dispatcher method';

@methods = D.^methods();
ok +@methods == 5, 'got all methods in hierarchy but NOT those from Any/Mu';
ok @methods[0].name eq 'foo' && @methods[1].name eq 'bar' ||
   @methods[0].name eq 'bar' && @methods[1].name eq 'foo',
   'first two methods from class D itself';
is @methods[2].name, 'foo', 'method from B has correct name';
is @methods[2].of.gist, Num.gist, 'method from B has correct return type';
ok @methods[3].name eq 'foo' && @methods[4].name eq 'bar' ||
   @methods[3].name eq 'bar' && @methods[4].name eq 'foo',
   'two methods from class A itself';

#?rakudo skip 'nom regression'
{
    @methods = D.^methods(:tree);
    is +@methods, 4, ':tree gives us right number of elements';
    ok @methods[0].name eq 'foo' && @methods[1].name eq 'bar' ||
       @methods[0].name eq 'bar' && @methods[1].name eq 'foo',
       'first two methods from class D itself';
    is @methods[2].WHAT.gist, Array.gist, 'third item is an array';
    is +@methods[2], 2, 'nested array for B had right number of elements';
    is @methods[3].WHAT.gist, Array.gist, 'forth item is an array';
    is +@methods[3], 1, 'nested array for C had right number of elements';
    is @methods[2], B.^methods(:tree), 'nested tree for B is correct';
    is @methods[3], C.^methods(:tree), 'nested tree for C is correct';
}

@methods = List.^methods();
ok +@methods > 0, 'can get methods for List (proto)';
@methods = (1, 2, 3).^methods();
ok +@methods > 0, 'can get methods for List (instance)';

@methods = Str.^methods();
ok +@methods > 0, 'can get methods for Str (proto)';
@methods = "i can haz test pass?".^methods();
ok +@methods > 0, 'can get methods for Str (instance)';

ok +List.^methods(:all) > +Any.^methods(:all), 'List has more methods than Any';
ok +Any.^methods(:all) > +Mu.^methods(), 'Any has more methods than Mu';

ok +(D.^methods>>.name) > 0, 'can get names of methods in and out of our own classes';
ok D.^methods.perl, 'can get .perl of output of .^methods';

class PT1 {
    method !pm1() { }
    method foo() { }
}
class PT2 is PT1 {
    method !pm2() { }
    method bar() { }
}

@methods = PT2.^methods(:all); # (all since we want at least one more)
is @methods[0].name, 'bar',    'methods call found public method in subclass';
is @methods[1].name, 'foo',    'methods call found public method in superclass (so no privates)';
ok @methods[2].name ne '!pm1', 'methods call did not find private method in superclass';

#?rakudo skip 'nom regression'
@methods = PT2.^methods(:private);
#?rakudo todo 'nom regression'
ok @methods[0].name eq '!pm2' || @methods[1].name eq '!pm2', 
                            'methods call with :private found private method in subclass';
#?rakudo todo 'nom regression'
ok @methods[2].name eq '!pm1' || @methods[3].name eq '!pm1', 
                            'methods call with :private found private method in superclass';

@methods = PT2.^methods(:local);
is +@methods, 1,            'methods call without :private omits private methods (with :local)';
is @methods[0].name, 'bar', 'methods call found public method in subclass (with :local)';

#?rakudo skip 'nom regression'
{
    @methods = PT2.^methods(:local, :private);
    is +@methods, 2,            'methods call with :private includes private methods (with :local)';
    ok @methods[0].name eq '!pm2' || @methods[1].name eq '!pm2', 
                                'methods call with :private found private method in subclass (with :local)';
}

{
    lives_ok { Sub.^methods.gist }, 'Can .gist methods of a subroutine';
    lives_ok { Sub.^methods.perl }, 'Can .perl methods of a subroutine';
    lives_ok { Method.^methods.gist }, 'Can .gist methods of a method';
    lives_ok { Method.^methods.perl }, 'Can .perl methods of a method';
    lives_ok { { $^a }.^methods.gist }, 'Can .gist methods of a block';
    lives_ok { { $^a }.^methods.perl }, 'Can .perl methods of a block';
    # RT #108968
    lives_ok { :(Int).^methods>>.gist }, 'Can >>.gist methods of a Signature';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/parents.t���������������������������������������������������0000664�0001750�0001750�00000011633�12224265625�021116� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 59;

=begin pod

Tests for the parents meta-method for introspecting class parents.

=end pod

# L<S12/Introspection/"The .^parents method">
class A { }
class B is A { }
class C is A { }
class D is B is C { }
my @parents;

@parents = A.^parents(:all);
is +@parents, 2, 'right number of parents in list of all, from type-object, with :all';
ok @parents[0].WHAT =:= Any, 'first parent is Any';
ok @parents[1].WHAT =:= Mu, 'second parent is Mu';

@parents = A.new.^parents(:all);
is +@parents, 2, 'right number of parents in list of all, from instance, with :all';
ok @parents[0].WHAT =:= Any, 'first parent is Any';
ok @parents[1].WHAT =:= Mu, 'second parent is Mu';

@parents = A.^parents();
is +@parents, 0, 'right number of parents in default list, from type-object';
@parents = A.^parents(:excl);
is +@parents, 0, 'right number of parents in default list, from type-object, explicit :excl';
@parents = A.new.^parents();
is +@parents, 0, 'right number of parents in default list, from instance';
@parents = A.new.^parents(:excl);
is +@parents, 0, 'right number of parents in default list, from instance, explicit :excl';

@parents = D.^parents(:all);
is +@parents, 5, 'right number of parents in list of all, from type-object, multiple inheritance';
ok @parents[0].WHAT =:= B, 'first parent is B';
ok @parents[1].WHAT =:= C, 'second parent is C';
ok @parents[2].WHAT =:= A, 'third parent is A';
ok @parents[3].WHAT =:= Any, 'forth parent is Any';
ok @parents[4].WHAT =:= Mu, 'fifth parent is Mu';

@parents = D.^parents();
is +@parents, 3, 'right number of parents in default list, from type-object, multiple inheritance';
ok @parents[0].WHAT =:= B, 'first parent is B';
ok @parents[1].WHAT =:= C, 'second parent is C';
ok @parents[2].WHAT =:= A, 'third parent is A';

@parents = D.new.^parents(:all);
is +@parents, 5, 'right number of parents in list of all, from instance, multiple inheritance';
ok @parents[0].WHAT =:= B, 'first parent is B';
ok @parents[1].WHAT =:= C, 'second parent is C';
ok @parents[2].WHAT =:= A, 'third parent is A';
ok @parents[3].WHAT =:= Any, 'forth parent is Any';
ok @parents[4].WHAT =:= Mu, 'fifth parent is Mu';

@parents = D.new.^parents(:excl);
is +@parents, 3, 'right number of parents in list with explicit :excl, from instance, multiple inheritance';
ok @parents[0].WHAT =:= B, 'first parent is B';
ok @parents[1].WHAT =:= C, 'second parent is C';
ok @parents[2].WHAT =:= A, 'third parent is A';

@parents = B.^parents(:local);
is +@parents, 1, 'right number of parents in list, from type-object, :local';
ok @parents[0].WHAT =:= A, 'parent is A'; 

@parents = B.new.^parents(:local);
is +@parents, 1, 'right number of parents in list, from instance, :local';
ok @parents[0].WHAT =:= A, 'parent is A'; 

@parents = D.^parents(:local);
is +@parents, 2, 'right number of parents in list, from type-object, :local, multiple inheritance';
ok @parents[0].WHAT =:= B, 'first parent is B';
ok @parents[1].WHAT =:= C, 'second parent is C';

@parents = D.new.^parents(:local);
is +@parents, 2, 'right number of parents in list, from instance, :local, multiple inheritance';
ok @parents[0].WHAT =:= B, 'first parent is B';
ok @parents[1].WHAT =:= C, 'second parent is C';

@parents = D.^parents(:tree);
is +@parents, 2,         'with :tree, D has two immediate parents (on proto)';
ok @parents[0] ~~ Array, ':tree gives back nested arrays for each parent (on proto)';
ok @parents[1] ~~ Array, ':tree gives back nested arrays for each parent (on proto)';
sub walk(Mu $a) {
    $a ~~ Positional
        ?? '(' ~ $a.map(&walk).join(', ') ~ ')'
        !! $a.gist;
}
is walk(@parents), walk( [[B, [A, [Any, [Mu]]]], [C, [A, [Any, [Mu]]]]]),
            ':tree gives back the expected data structure (on proto)';

@parents = D.new.^parents(:tree);
is +@parents, 2,         'with :tree, D has two immediate parents (on instance)';
ok @parents[0] ~~ Array, ':tree gives back nested arrays for each parent (on instance)';
ok @parents[1] ~~ Array, ':tree gives back nested arrays for each parent (on instance)';
is walk(@parents),  walk([[B, [A, [Any, [Mu]]]], [C, [A, [Any, [Mu]]]]]),
                         ':tree gives back the expected data structure (on instance)';


@parents = Str.^parents(:all);
is +@parents, 3, 'right number of parents for Str built-in, from type-object';
ok @parents[0].WHAT =:= Cool, 'first parent is Cool';
ok @parents[1].WHAT =:= Any, 'second parent is Any';
ok @parents[2].WHAT =:= Mu, 'third parent is Mu';

@parents = "omg introspection!".^parents(:all);
is +@parents, 3, 'right number of parents for Str built-in, from instance';
ok @parents[0].WHAT =:= Cool, 'first parent is Cool';
ok @parents[1].WHAT =:= Any, 'second parent is Any';
ok @parents[2].WHAT =:= Mu, 'third parent is Mu';

@parents = Mu.^parents();
is +@parents, 0, 'Mu has no parents (no params)';
@parents = Mu.^parents(:local);
is +@parents, 0, 'Mu has no parents (:local)';
@parents = Mu.^parents(:tree);
is +@parents, 0, 'Mu has no parents (:tree)';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/roles.t�����������������������������������������������������0000664�0001750�0001750�00000002626�12224265625�020570� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 12;

=begin pod

Tests for .^roles from L<S12/Introspection>.

=end pod

# L<S12/Introspection/"list of roles">

role R1 { }
role R2 { }
role R3 { }
class C1 does R1 does R2 { }
class C2 is C1 does R3 { }

my @roles = C2.^roles(:local);
is +@roles,   1,  ':local returned list with correct number of roles';
is @roles[0], R3, 'role in list was correct';

@roles = C1.^roles(:local);
is +@roles,   2,  ':local returned list with correct number of roles';
ok (@roles[0] ~~ R1 && @roles[1] ~~ R2 || @roles[0] ~~ R2 && @roles[1] ~~ R1),
                  'roles in list were correct';

ok C2.^roles ~~ Positional, '.^roles returns something Positional';
@roles = C2.^roles();
is +@roles,   3,  'with no args returned list with correct number of roles';
is @roles[0], R3, 'first role in list was correct';
ok (@roles[1] ~~ R1 && @roles[2] ~~ R2 || @roles[1] ~~ R2 && @roles[2] ~~ R1),
                  'second and third roles in list were correct';
#?rakudo skip '.^roles(:tree)'
{
@roles = C2.^roles(:tree);
is +@roles,   2,       ':tree returned list with correct number of elements';
is @roles[0], R3,      'first element in the list is the role done in base class';
ok @roles[1] ~~ Array, 'second element in list is an array';
ok @roles[1][0] ~~ R1 && @roles[1][1] ~~ R2 || @roles[1][0] ~~ R2 && @roles[1][1] ~~ R1,
                       'nested array contains roles of parent class';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/walk.t������������������������������������������������������0000664�0001750�0001750�00000004137�12224265625�020401� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 11;

=begin pod

Tests for WALK, defined in L<S12/Calling sets of methods>

=end pod

#L<S12/Calling sets of methods>

class A {
    method m { 'A' }
}
class B {
    method m { 'B' }
}
class C is A is B {
    method m { 'C' }
    method n { 'OH NOES' }
}
class D is A {
    method m { 'D' }
}
class E is C is D {
    method m { 'E' }
}

sub cand_order(@cands, $instance) {
    my $result = '';
    for @cands -> $cand {
        $result ~= $cand($instance);
    }
    $result
}

# :canonical
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :canonical);
    is cand_order(@cands, $x), 'ECDAB', ':canonical (explicit) works';
    @cands = $x.WALK(:name<m>);
    is cand_order(@cands, $x), 'ECDAB', ':canonical (as default) works';
}

# :super
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :super);
    is cand_order(@cands, $x), 'CD', ':super works';
}

# :breadth
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :breadth);
    is cand_order(@cands, $x), 'ECDAB', ':breadth works';
}

# :descendant
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :descendant);
    is cand_order(@cands, $x), 'ABCDE', ':descendant works';
}

# :ascendant
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :ascendant);
    is cand_order(@cands, $x), 'ECABD', ':ascendant works';
}

# :preorder
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :preorder);
    is cand_order(@cands, $x), 'ECABD', ':preorder works';
}

# :omit
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :omit({ .^can('n') }));
    is cand_order(@cands, $x), 'DAB', ':omit works';
}

# :include
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :include({ $^c.gist ~~ regex { <[CDE]> } }));
    is cand_order(@cands, $x), 'ECD', ':include works';
}

# :include and :omit
{
    my $x = E.new;
    my @cands = $x.WALK(:name<m>, :include({ $^c.gist ~~ regex { <[CDE]> } }), :omit({ .^can('n') }));
    is cand_order(@cands, $x), 'D', ':include and :omit together work';
}

# Grammar.WALK had issues once
{
    my ($meth) = Grammar.WALK(:name<parse>);
    is $meth.name, 'parse', 'Grammar.WALK works';
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-introspection/WHAT.t������������������������������������������������������0000664�0001750�0001750�00000007604�12224265625�020210� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 37;

# =head1 Introspection
#     WHAT        the type object of the type

my class A is Array {};
my class H is Hash  {};

{
    my $a;
    ok $a.WHAT    === Any,   '$a default is Any';
    my @a;
    ok @a.WHAT    === Array, '@a default is Array';
    ok @a[0].WHAT === Any,   '@a[0] default is Any';
    my %a;
    ok %a.WHAT    === Hash,  '%a default is Hash';
    ok %a<a>.WHAT === Any,   '%a<a> default is Any';
} #5

{
    my $a = Array.new;
    ok $a.WHAT    === Array, 'Array.new default is Array';
    ok $a[0].WHAT === Any,   'Array.new[0] default is Any';
    my $h = Hash.new;
    ok $h.WHAT    === Hash,  'Hash.new default is Hash';
    ok $h<a>.WHAT === Any,   'Hash.new<a> default is Any';
} #4

{
    my $a = A.new;
    ok $a.WHAT    === A,   'A.new default is A';
    ok $a[0].WHAT === Any, 'A.new[0] default is Any';
    my $h = H.new;
    #?niecza todo
    ok $h.WHAT    === H,   'H.new default is Hash';
    ok $h<a>.WHAT === Any, 'H.new<a> default is Any';
} #4

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
{
    my Int $a;
    ok $a.WHAT    === Int,        'Int $a default is Int';
    my Int @a;
    ok @a.WHAT    === Array[Int], 'Int @a default is Array[Int]';
    ok @a[0].WHAT === Int,        'Int @a[0] default is Int';
    my Int %a;
    ok %a.WHAT    === Hash[Int],  'Int %a default is Hash[Int]';
    ok %a<a>.WHAT === Int,        'Int %a<a> default is Int';
} #5

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
{
    my $a of Int;
    #?rakudo todo "of Type on scalars fails"
    ok $a.WHAT    === Int,        '$a of Int default is Int';
    my @a of Int;
    #?rakudo todo "looks like a type object, but is not"
    ok @a.WHAT    === Array[Int], '@a of Int default is Array[Int]';
    #?rakudo todo "of Type on scalars fails"
    ok @a[0].WHAT === Int,        '@a[0] of Int default is Int';
    my %a of Int;
    #?rakudo todo "looks like a type object, but is not"
    ok %a.WHAT    === Hash[Int],  '%a of Int default is Hash[Int]';
    #?rakudo todo "of Type on scalars fails"
    ok %a<a>.WHAT === Int,        '%a<a> of Int default is Int';
} #5

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
{
    my Int %a{Str};
    ok %a.WHAT    === Hash[Int,Str], 'Int %a{Str} default is Hash[Int,Str]';
    ok %a<a>.WHAT === Int,           'Int %a{Str}<a> default is Int';
} #2

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
#?rakudo todo '%h{Str} of Int fails'
{
    my %a{Str} of Int;
    ok %a.WHAT    === Hash[Int,Str], '%a{Str} of Int default is Hash[Int,Str]';
    ok %a<a>.WHAT === Int,           '%a{Str}<a> of Int default is Int';
} #2

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
{
    my $a = Array[Int].new;
    ok $a.WHAT    === Array[Int], 'Array[Int].new default is Array';
    #?rakudo todo "Foo[Int].new on scalars fails"
    ok $a[0].WHAT === Int,        'Array[Int].new[0] default is Int';
    my $h = Hash[Int].new;
    ok $h.WHAT    === Hash[Int],  'Hash[Int].new default is Hash[Int]';
    #?rakudo todo "Foo[Int].new on scalars fails"
    ok $h<a>.WHAT === Int,        'Hash[Int].new<a> default is Int';
} #4

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
{
    my $a = A[Int].new;
    ok $a.WHAT    === A[Int], 'A[Int].new default is A[Int]';
    #?rakudo todo "Foo[Int].new on scalars fails"
    ok $a[0].WHAT === Int,    'A[Int].new[0] default is Int';
    my $h = H[Int].new;
    ok $h.WHAT    === H[Int], 'H[Int].new default is H[Int]';
    #?rakudo todo "Foo[Int].new on scalars fails"
    ok $h<a>.WHAT === Int,    'H[Int].new<a> default is Int';
} #4

#?pugs   skip "no typed support"
#?niecza skip "no typed support"
{
    my $h = H[Int,Str].new;
    ok $h.WHAT    === H[Int,Str], 'H[Int,Str].new default is H[Int,Str]';
    #?rakudo todo "Foo[Int,Str].new on scalars fails"
    ok $h<a>.WHAT === Int,        'H[Int,Str].new<a> default is Int';
} #2

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/accessors.t�������������������������������������������������������0000664�0001750�0001750�00000002672�12224265625�020175� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 8;

class A {
    has @.a;
    has $.b;
    method test-list-a {
        my $x = 0;
        $x++ for @.a;
        $x;
    }
    method test-scalar-a {
        my $x = 0;
        $x++ for $.a;
        $x;
    }
    method test-list-b {
        my $x = 0;
        $x++ for @.b;
        $x;
    }
    method test-scalar-b {
        my $x = 0;
        $x++ for $.b;
        $x;
    }
    method test-hash-a {
        my $x = 0;
        $x++ for %.a;
        $x;
    }

}

my $a = A.new(a => (1, 2, 3, 4), b => [3, 4, 5, 6]);
is $a.test-list-a,   4, '@.a contextualizes as (flat) list (1)';
#?pugs todo
is $a.test-scalar-a, 1, '$.a contextualizes as item (1)';
is $a.test-list-b,   4, '@.a contextualizes as (flat) list (2)';
is $a.test-scalar-b, 1, '$.a contextualizes as item (2)';
#?pugs skip 'Cannot cast into Hash'
is $a.test-hash-a,   2, '%.a contextualizes as hash';

# RT #78678
{
    class Parent {
        has $.x is rw;
        method parent-x() { $!x };
    }
    class Child is Parent {
        has $.x is rw;
        method child-x() { $!x };
    }
    my $o = Child.new(x => 42);
    $o.Parent::x = 5;
    is $o.parent-x, 5, 'parent attribute is separate from child attribute of the same name (parent)';
    #?pugs todo
    #?niecza todo
    is $o.child-x, 42, 'parent attribute is separate from child attribute of the same name (child)';
    #?pugs todo
    #?niecza todo
    is $o.x, 42, '.accessor returns that of the child';

}
����������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/attribute-params.t������������������������������������������������0000664�0001750�0001750�00000002310�12224265625�021461� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 13;

class Ap {
    has $.s;
    has @.a;
    has %.h;

    method ss($!s) { 3 }
    method sa(@!a) { 4 }
    method sh(%!h) { 5 }
    method ssa(*@!a) { 14 }
    method ssh(*%!h) { 15 }
}

my $x = Ap.new();

nok $x.s.defined, 'attribute starts undefined';
is  $x.ss('foo'), 3, 'attributive paramed method returns the right thing';
is  $x.s,         'foo', '... and it set the attribute';

nok $x.a,             'array attribute starts empty';
is  $x.sa([1, 2]), 4, 'array attributive paramed method returns the right thing';
is  $x.a.join('|'), '1|2', 'array param set correctly';

nok $x.h,             'hash attribute starts empty';
is  $x.sh({ a=> 1, b => 2}), 5, 'hash attributive paramed method returns the right thing';
#?pugs skip 'Cannot cast into Hash'
is  $x.h<b a>.join('|'), '2|1', 'hash param set correctly';

is  $x.ssa(1, 2), 14, 'slurpy array attributive paramed method returns the right thing';
is  $x.a.join('|'), '1|2', 'slurpy array param set correctly';

is  $x.ssh(a=> 1, b => 2), 15, 'slurpy hash attributive paramed method returns the right thing';
#?pugs skip 'Cannot cast into Hash'
is  $x.h<b a>.join('|'), '2|1', 'slurpy hash param set correctly';

done;

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/calling_sets.t����������������������������������������������������0000664�0001750�0001750�00000010054�12224265625�020650� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 32;

# L<S12/"Calling sets of methods">

# Some basic tests with only single-dispatch in operation.
class A {
    has $.cnt is rw;
    method foo { $.cnt += 4 }
}
class B is A {
    method foo { $.cnt += 2 }
}
class C is B {
    method foo { $.cnt += 1 }
}

{
    my $c = C.new();

    $c.cnt = 0;
    $c.?foo();
    is $c.cnt, 1, '.? calls first matching method';

    $c.cnt = 0;
    $c.*foo();
    is $c.cnt, 7, '.* calls up inheritance hierarchy';

    $c.cnt = 0;
    $c.+foo();
    is $c.cnt, 7, '.+ calls up inheritance hierarchy';

    is $c.?bar(), Nil,  '.? on undefined method gives Nil';

    my $lived = 0;
    try { $c.+bar(); $lived = 1; }
    is $lived, 0, '.+ on undefined method is an error';

    is $c.*bar(), Nil, '.* on undefined method gives Nil';

    my $foo = "foo";

    $c.cnt = 0;
    $c.?"$foo"();
    is $c.cnt, 1, '.? with dynamic method name';

    $c.cnt = 0;
    $c.*"$foo"();
    is $c.cnt, 7, '.* with dynamic method name';

    $c.cnt = 0;
    $c.+"$foo"();
    is $c.cnt, 7, '.+ with dynamic method name';

    dies_ok { $c."?foo"() }, '? at start of dynamic name does not imply .?';

    dies_ok { $c."+foo"() }, '+ at start of dynamic name does not imply .+';

    dies_ok { $c."*foo"() }, '* at start of dynamic name does not imply .*';
}


# Some tests involiving .?, .+ and .* with multi-methods.
class D {
    has $.cnt is rw;
    multi method foo() { $.cnt++ }
    multi method foo(Int $x) { $.cnt++ }   #OK not used
    multi method foo($x) { $.cnt++ }   #OK not used
}
class E is D {
    multi method foo() { $.cnt++ }
    multi method foo($x) { $.cnt++ }   #OK not used
}

#?rakudo skip 'ambiguous dispatch'
{
    my $e = E.new();

    $e.cnt = 0;
    $e.foo();
    is $e.cnt, 1, 'dispatch to one sanity test';

    $e.cnt = 0;
    $e.?foo();
    is $e.cnt, 1, '.? calls first matching multi method';

    $e.cnt = 0;
    $e.*foo();
    is $e.cnt, 2, '.* calls up inheritance hierarchy and all possible multis';

    $e.cnt = 0;
    $e.*foo(2.5);
    is $e.cnt, 2, '.* calls up inheritance hierarchy and all possible multis';

    $e.cnt = 0;
    $e.*foo(2);
    is $e.cnt, 3, '.* calls up inheritance hierarchy and all possible multis';

    $e.cnt = 0;
    $e.+foo();
    is $e.cnt, 2, '.+ calls up inheritance hierarchy and all possible multis';

    $e.cnt = 0;
    $e.+foo(2.5);
    is $e.cnt, 2, '.+ calls up inheritance hierarchy and all possible multis';

    $e.cnt = 0;
    $e.+foo(2);
    is $e.cnt, 3, '.+ calls up inheritance hierarchy and all possible multis';

    is $e.?foo("lol", "no", "match"), Nil, '.? when no possible multis gives Nil';

    my $lived = 0;
    try { $e.+foo("lol", "no", "match"); $lived = 1; }
    is $lived, 0, '.+ with no matching multis is an error';

    is ($e.*foo("lol", "no", "match")).elems, 0, '.* when no possible multis gives empty list';
}

# Some tests to make sure we walk methods from roles too.
role R1 {
    multi method mm { $.cnt += 1 }
    multi method sm { $.cnt += 2 }
}
role R2 {
    multi method mm { $.cnt += 3 }
}
class F does R1 {
    has $.cnt is rw;
}
class G is F does R2 {
}

{
    my $g = G.new();

    $g.cnt = 0;
    $g.?sm();
    is $g.cnt, 2, 'single dispatch method from role found with .?';

    $g.cnt = 0;
    $g.+sm();
    is $g.cnt, 2, 'single dispatch method from role found with .+';

    $g.cnt = 0;
    $g.*sm();
    is $g.cnt, 2, 'single dispatch method from role found with .*';

    $g.cnt = 0;
    $g.?mm();
    is $g.cnt, 3, 'multi dispatch method from role found with .?';

    $g.cnt = 0;
    $g.+mm();
    is $g.cnt, 4, 'multi dispatch method from role found with .+';

    $g.cnt = 0;
    $g.*mm();
    is $g.cnt, 4, 'multi dispatch method from role found with .*';
}

class MMT1 {
    multi method foo($x) { 42 }   #OK not used
}
class MMT2 is MMT1 {
    multi method foo(Int $x) { "oh noes" }   #OK not used
}
is MMT2.new.?foo("lol"), 42, '.? when initial multi does not match will find next one up';

{
    my @list =  MMT1.new.?nonexistent();
    is +@list, 0, '.?nonexisent() returns Nil';
}

eval_dies_ok '1.*WHAT', '.WHAT is a macro and cannoted be .*ed';

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/calling_syntax.t��������������������������������������������������0000664�0001750�0001750�00000002215�12224265625�021220� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 11;

=begin description

Test for 

=end description

# L<S02/Bare identifiers/"$x.foo;">

class Foo {
    method foo {
        42
    }
    method bar() {
        101
    }
    method identity($x) {
        $x
    }
}

my $x = Foo.new();
is($x.foo, 42, 'called a method without parens');
is($x.foo(), 42, 'called a method without parens');
is($x.bar, 101, 'called a method with parens');
is($x.bar(), 101, 'called a method with parens');
is($x.identity("w00t"), "w00t", 'called a method with a parameter');

# L<S12/Methods/"You can replace the identifier with a quoted string">
eval_dies_ok(q{$x.'foo'}, 'indirect method call using quotes, no parens');
is($x.'bar'(), 101, 'indirect method call using quotes, with parens');   #OK use of quotes
is($x.'identity'('qwerty'), 'qwerty', 'indirect method call using quotes, with parameter');   #OK use of quotes
{
    my $name = 'foo';
    eval_dies_ok(q{$x."$name"}, 'indirect method call, no parens');
    is($x."$name"(), 42, 'indirect method call, with parens');
}
{
    my $name = 'identity';
    is($x."$name"('asdf'), 'asdf', 'indirect method call, with parameter');
}

# vim: syn=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/chaining.t��������������������������������������������������������0000664�0001750�0001750�00000003707�12224265625�017770� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 17;

# L<S03/"Changes to Perl 5 operators"/"-> becomes .">

class Foo {
    has $.num;
    
    method bar ($self: $num) returns Foo {
        $!num = $num; 
        return $self;
    }
    
    method baz ($self: $num) returns Foo {
        $!num += $num;
        return $self;
    }
}

my $foo = Foo.new(:num<10>);
isa_ok($foo, Foo);

# do some sanity checking to make sure it does 
# all that we expect it too first.

is($foo.num(), 10, '... got the right num value');

my $_foo1 = $foo.bar(20);
isa_ok($_foo1, Foo);
ok($_foo1 === $foo, '... $_foo1 and $foo are the same instances');

is($foo.num(), 20, '... got the right num value');

my $_foo2 = $foo.baz(20);
isa_ok($_foo2, Foo);
ok( ([===]($foo, $_foo2, $_foo1)), '... $_foo1, $_foo2 and $foo are the same instances');

is($foo.num(), 40, '... got the right num value');

# now lets try it with chained methods ...

my $_foo3;
lives_ok {
    $_foo3 = $foo.bar(10).baz(5);
}, '... method chaining works';

isa_ok($_foo3, Foo);
ok( ([===]($_foo3, $_foo2, $_foo1, $foo)),
    '... $_foo3, $_foo1, $_foo2 and $foo are the same instances');

is($foo.num(), 15, '... got the right num value');

# test attribute accessors, too
is($foo.baz(7).baz(6).num, 28, 'chained an auto-generated accessor');

eval_dies_ok('Foo->new',  'Perl 5 -> is dead (class constructor)');
eval_dies_ok('$foo->num', 'Perl 5 -> is dead (method call)');

# L<S03/"Changes to Perl 5 operators"/"-> becomes .">
# L<S12/"Open vs Closed Classes"/"though you have to be explicit">
#?pugs skip 'Mu'
{
    # (A => (B => Mu)) => (C => Mu))
    # ((A B) C)
    
    my $cons = [=>] ( [=>] <A B>, Mu ), <C>, Mu;
    
    ## Hmm.  Works with the latest release of Pugs (6.2.12 (r13256))
    ## Leaving this in as something that once didn't work (6.2.12 CPAN)
    
    my $p = $cons.key;
    ok( $cons.key.key =:= $p.key, 'chaining through temp variable' );
    ok( $cons.key.key =:= $cons.key.key, 'chaining through Any return');
}

# vim: ft=perl6
���������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/class-and-instance.t����������������������������������������������0000664�0001750�0001750�00000001766�12224265625�021662� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 8;

class Foo {
    method bar (Foo $class: $arg) { return 100 + $arg }   #OK not used
}

{
    my $val;
    lives_ok {
        $val = Foo.bar(42);
    }, '... class|instance methods work for class';
    is($val, 142, '... basic class method access worked');
}

{
    my $foo = Foo.new();
    my $val;
    lives_ok {
        $val = $foo.bar(42);
    }, '... class|instance methods work for instance';
    is($val, 142, '... basic instance method access worked');
}

class Act {
    my method rules() { 'the world' }
    our method rocks() { 'the house' }
    
    is(rules(Act), 'the world', 'my method is lexically installed');
}
#?niecza todo "https://github.com/sorear/niecza/issues/185"
dies_ok({ Act.rules }, 'my method not installed in methods table');
is(Act::rocks(Act), 'the house', 'our method is installed in package');
#?pugs todo
#?niecza todo "https://github.com/sorear/niecza/issues/185"
dies_ok({ Act.rocks }, 'our method not installed in methods table');

# vim: ft=perl6
����������rakudo-2013.12/t/spec/S12-methods/default-trait.t���������������������������������������������������0000664�0001750�0001750�00000001763�12224265625�020755� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

# L<S12/Candidate Tiebreaking/"only candidates marked with the default
# trait">

class Something {
    multi method doit(Int $x)            { 2 * $x };
    multi method doit(Int $x) is default { 3 * $x };
}

my $obj = Something.new();
lives_ok { $obj.doit(3) }, "'is default' trait makes otherwise ambiguous method dispatch live";
is $obj.doit(3), 9, "'is default' trait tie-breaks on method dispatch";

multi sub doit_sub(Int $x)            { 2 * $x };
multi sub doit_sub(Int $x) is default { 3 * $x };

lives_ok { doit_sub(3) }, "'is default' trait makes otherwise ambiguous method dispatch live";
#?pugs todo
is doit_sub(3), 9, "'is default' trait on subs";

multi sub slurpy() is default { return 'a' };
multi sub slurpy(*@args)      { return 'b' };   #OK not used

is slurpy(2), 'b', 'basic sanity with arity based dispatch and slurpies';
#?pugs skip 'make todo? passes. untodo? fails.'
is slurpy(),  'a', '"is default" trait wins against empty slurpy param';

# vim: ft=perl6
�������������rakudo-2013.12/t/spec/S12-methods/defer-call.t������������������������������������������������������0000664�0001750�0001750�00000005161�12224265625�020202� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 14;

# L<S12/"Calling sets of methods"/"Any method can defer to the next candidate method in the list">

# Simple test, making sure callwith passes on parameters properly.
class A {
    method a(*@A) {
        (self.perl, @A)
    }
}
class B is A {
    method a() {
        callwith("FIRST ARG", "SECOND ARG")
    }
}
{
    my $instance = B.new;
    my @result = $instance.a();
    is @result.elems, 3, 'nextwith passed on right number of parameters';
    is @result[0], $instance.perl, 'invocant passed on correctly';
    is @result[1], "FIRST ARG", 'first argument correct';
    is @result[2], "SECOND ARG", 'second argument correct';
}

class Foo {
    # $.tracker is used to determine the order of calls.
    has $.tracker is rw;
    multi method doit()  {$.tracker ~= 'foo,'}
    multi method doit(Int $num) {$.tracker ~= 'fooint,'}   #OK not used
    method show  {$.tracker}
    method clear {$.tracker = ''}
}

class BarCallSame is Foo {
    multi method doit() {$.tracker ~= 'bar,'; callsame; $.tracker ~= 'ret1,'}
    multi method doit(Int $num) {$.tracker ~= 'barint,'; callsame; $.tracker ~= 'ret2,'}   #OK not used
}

{
    my $o = BarCallSame.new;
    $o.clear;
    $o.doit;
    is($o.show, 'bar,foo,ret1,', 'callsame inheritance test');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'barint,fooint,ret2,', 'callsame multimethod/inheritance test');
}


class BarCallWithEmpty is Foo {
    multi method doit() {$.tracker ~= 'bar,'; callwith(); $.tracker ~= 'ret1,'}
    multi method doit(Int $num) {$.tracker ~= 'barint,'; callwith($num); $.tracker ~= 'ret2,'}   #OK not used
}
{
    my $o = BarCallWithEmpty.new;
    $o.clear;
    $o.doit;
    is($o.show, 'bar,foo,ret1,', 'callwith() inheritance test');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    {
        $o.doit(5);
        is($o.show, 'barint,fooint,ret2,', 'callwith() multimethod/inheritance test');
    }
}

class BarCallWithInt is Foo {
    multi method doit() {$.tracker ~= 'bar,'; callwith(); $.tracker ~= 'ret1,'}
    multi method doit(Int $num) {$.tracker ~= 'barint,'; callwith(42); $.tracker ~= 'ret2,'}   #OK not used
}
{
    my $o = BarCallWithInt.new;
    $o.clear;
    $o.doit;
    is($o.show, 'bar,foo,ret1,', 'callwith(42) inheritance test');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'barint,fooint,ret2,', 'callwith(42) multimethod/inheritance test');
}

# RT #69756
{
    multi sub f(0) { };
    multi sub f($n) {
        callwith($n - 1);
    }
    lives_ok { f(3) }, 'can recurse several levels with callwith()';
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/defer-next.t������������������������������������������������������0000664�0001750�0001750�00000007460�12224265625�020251� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 21;

# L<S12/"Calling sets of methods"/"Any method can defer to the next candidate method in the list">

# Simple test, making sure nextwith passes on parameters properly.
class A {
    method a(*@A) {
        (self.perl, @A)
    }
}
class B is A {
    method a() {
        nextwith("FIRST ARG", "SECOND ARG")
    }
}
{
    my $instance = B.new;
    my @result = $instance.a();
    is @result.elems, 3, 'nextwith passed on right number of parameters';
    is @result[0], $instance.perl, 'invocant passed on correctly';
    is @result[1], "FIRST ARG", 'first argument correct';
    is @result[2], "SECOND ARG", 'second argument correct';
}

class Foo {
    # $.tracker is used to determine the order of calls.
    has $.tracker is rw;
    multi method doit()  {$.tracker ~= 'foo,'}
    multi method doit(Int $num) {$.tracker ~= 'fooint,'}   #OK not used
    method show  {$.tracker}
    method clear {$.tracker = ''}
}

class BarNextSame is Foo {
    multi method doit() {$.tracker ~= 'bar,'; nextsame; $.tracker ~= 'ret1,'}
    multi method doit(Int $num) {$.tracker ~= 'barint,'; nextsame; $.tracker ~= 'ret2,'}   #OK not used
}

{
    my $o = BarNextSame.new;
    $o.clear;
    $o.doit;
    is($o.show, 'bar,foo,', 'nextsame inheritance test');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'barint,fooint,', 'nextsame multimethod/inheritance test');
}

class BarNextWithEmpty is Foo {
    multi method doit() {$.tracker ~= 'bar,'; nextwith(); $.tracker ~= 'ret1,'}
    multi method doit(Int $num) {$.tracker ~= 'barint,'; nextwith($num); $.tracker ~= 'ret2,'}   #OK not used
}
{
    my $o = BarNextWithEmpty.new;
    $o.clear;
    $o.doit;
    is($o.show, 'bar,foo,', 'nextwith() inheritance test');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'barint,fooint,', 'nextwith() multimethod/inheritance test');
}

class BarNextWithInt is Foo {
    multi method doit() {$.tracker ~= 'bar,'; nextwith(); $.tracker ~= 'ret1,'}
    multi method doit(Int $num) {$.tracker ~= 'barint,'; nextwith(42); $.tracker ~= 'ret2,'}   #OK not used
}
{
    my $o = BarNextWithInt.new;
    $o.clear;
    $o.doit;
    is($o.show, 'bar,foo,', 'nextwith(42) inheritance test');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'barint,fooint,', 'nextwith(42) multimethod/inheritance test');
}

{
    my $called = 0;
    class DeferWithoutCandidate {
        multi method a($x) {   #OK not used
            $called = 1;
            nextwith();
        }
    }
    #?rakudo todo 'variant of RT 69608'
    dies_ok { DeferWithoutCandidate.new.a(1) },
        'Dies when nextwith() does not find a candidate to dispatch to';
    is $called, 1, 'but was in the correct method before death';
}

{
    my $r;
    class AA {
        proto method l (|) { * }
        multi method l ( &t, *@list ) {
            $r ~= '&';
            $r ~= @list.join;
            $r;
        }
        multi method l ( %t, *@list ) {
            $r ~= '%';
            $r ~= @list.join;
            samewith( { %t{$^a} }, @list );
#            &?ROUTINE.dispatcher()( self, { %t{$^a} }, @list );
        }
        multi method l ( @t, *@list ) {
            $r ~= '@';
            $r ~= @list.join;
            samewith( { @t[$^a] }, @list );
#            &?ROUTINE.dispatcher()( self, { @t[$^a] }, @list );
        }
    }

    my $a = AA.new;
    is $a.l( {$_}, 1,2,3 ), '&123', 'return direct call to code ref candidate';
    is $r, '&123', "direct call to code ref candidate";

    $r='';
    is $a.l( my %a, 4,5,6 ), '%456&456', 'return from hash candidate';
    is $r, '%456&456', "call to hash candidate";

    $r='';
    is $a.l( my @a, 7,8,9 ), '@789&789', 'return from array candidate';
    is $r, '@789&789', "call to array candidate";
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/delegation.t������������������������������������������������������0000664�0001750�0001750�00000001050�12224265625�020310� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 5;

class A {
    method Str() handles 'uc' {
        'test';
    }
    method Num() handles <sqrt floor> {
        4e0;
    }

    method Int() handles 'base' {
        255
    }
}

my $a = A.new;
is        $a.uc,     'TEST',     'simple method delegation';
is_approx $a.sqrt,   2,          'delegation to multiple names (1)';
is        $a.floor,  4,          'delegation to multiple names (2)';
is        $a.base(16), 'FF',     'delegation and arguments';
is        A.base(16),  'FF',     '... same with type object invocant';
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/how.t�������������������������������������������������������������0000664�0001750�0001750�00000000316�12224265625�016776� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 2;

lives_ok { 4.HOW.HOW }, 'Can access meta class of meta class';

#?pugs todo
eval_dies_ok 'my $x; ($x = "hi").HOW = Block;',
            'Cannot assign to .HOW';

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/indirect_notation.t�����������������������������������������������0000664�0001750�0001750�00000010714�12224265625�021720� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S12/Method calls/"Indirect object notation now requires a colon after the invocant, even if there are no arguments">

plan 33;


##### Without arguments
class T1
{
    method a
    {
        'test';
    }
}

{
    my T1 $o .= new;
    ok( "Still alive after new" );

    is( $o.a(), 'test', "The indirect object notation call without argument 1" );
    #?rakudo skip 'TTIAR near $o:'
    #?niecza skip 'Invocant handling is NYI'
    is( (a $o:), 'test', "The indirect object notation call without arguments 2" );
}

##### With arguments
class T2
{
    method a( $x )
    {
        $x;
    }
}

{
    my T2 $o .= new;
    ok( "Still alive after new" );
    my $seed = 1000.rand;
    is( $o.a( $seed ), $seed, "The indirect object notation call with argument 1" );
    #?rakudo skip 'TTIAR near $o:'
    #?niecza skip 'Invocant handling is NYI'
    is( (a $o: $seed), $seed, "The indirect object notation call with arguments 2" );
    my $name = 'a';
    eval_dies_ok('$name $o: $seed', 'Indirect object notation and indirect method calls cannot be combined');
}


# L<S12/Fancy method calls/"There are several forms of indirection for the method name">

{
    class A {
        method abc { 'abc' };
        method bcd { 'bcd' };
    }
    my $o = A.new();

    is $o."abc"(),    'abc',   'calling method with $object."methodname"';   #OK use of quotes
    my $bc = 'bc';
    is $o."a$bc"(),   'abc',  'calling method with $object."method$name"';
    is $o."{$bc}d"(), 'bcd',  'calling method with $object."method$name"';


    my $meth = method { self.abc ~ self.bcd };
    is $o.$meth, 'abcbcd',   'calling method with $object.$methodref';
}

# L<S12/Fancy method calls/"$obj.@candidates(1,2,3)">
#?rakudo skip '.@foo not yet working'
#?niecza skip 'Unable to resolve method postcircumfix:<( )> in class Array'
{
    class T3 {
        has $.x;
        has $.y;
        has $.called is rw = 0;

        our method m1 ()   { $!called++; "$.x|$.y" };
        our method m2 ()   { $!called++; "$.x,$.y"; nextsame() };
        our method m3 ()   { $!called++; "$.x~$.y" };
        our method m4 ()   { $!called++; callsame(); };
    }
    my @c = (&T3::m1, &T3::m2, &T3::m3);
    my $o = T3.new(:x<p>, :y<q>);

    is $o.@c(),         'p|q', 'called the first candidate in the list, which did not defer';
    is $o.called,       1,     'called only one method dispatch';
    
    @c.shift();
    $o.called = 0;
    is $o.@c,           'p~q', 'got result from method we deferred to';
    is $o.called,       2,     'called total two methods during dispatch';

    @c.unshift(&T3::m4);
    $o.called = 0;
    is $o.@c,           'p~q', 'got result from method we deferred to, via call';
    is $o.called,       3,     'called total three methods during dispatch';
}

dies_ok { 23."nonexistingmethod"() }, "Can't call nonexisting method";   #OK use of quotes

#?rakudo skip '.*, .+ and .? with @foo'
#?niecza skip 'Two definitions found for symbol ::GLOBAL::T4::&m, etc'
{
    class T4 {
        has $.called = 0;
        our multi method m(Int $x) { $!called++; 'm-Int' }   #OK not used
        our multi method m(Num $x) { $!called++; 'm-Num' }   #OK not used

        our multi method n(Int $x) { $!called++; 'n-Int' }   #OK not used
        our multi method n(Num $x) { $!called++; 'n-Num' }   #OK not used
    }

    my $o = T4.new();
    my @cand-num = &T4::m, &T4::n;
    is ~$o.*@cand-num(3.4).sort, 'm-Num n-Num', '$o.*@cand(arg) (1)';
    is ~$o.*@cand-num(3).sort, 'm-Int m-Num n-Int n-Num', '$o.*@cand(arg) (2)';
    is $o.called, 6, 'right number of method calls';
    lives_ok { $o.*@cand-num() }, "it's ok with .* if no candidate matched (arity)";
    lives_ok { $o.*@cand-num([]) }, "it's ok with .* if no candidate matched (type)";

    $o = T4.new();
    is ~$o.+@cand-num(3.4).sort, 'm-Num n-Num', '$o.+@cand(arg) (1)';
    is ~$o.+@cand-num(3).sort, 'm-Int m-Num n-Int n-Num', '$o.+@cand(arg) (2)';
    is $o.called, 6, 'right number of method calls';
    dies_ok { $o.+@cand-num() }, "it's not ok with .+ if no candidate matched (arity)";
    dies_ok { $o.+@cand-num([]) }, "it's not ok with .+ if no candidate matched (type)";

    $o = T4.new();
    is ~$o.?@cand-num(3.4).sort, 'm-Num', '$o.?@cand(arg) (1)';
    is ~$o.?@cand-num(3).sort, 'm-Int', '$o.?@cand(arg) (2)';
    is $o.called, 2, 'right number of method calls';
    lives_ok { $o.?@cand-num() }, "it's ok with .? if no candidate matched (arity)";
    lives_ok { $o.?@cand-num([]) }, "it's ok with .? if no candidate matched (type)";
}

# vim: ft=perl6
����������������������������������������������������rakudo-2013.12/t/spec/S12-methods/instance.t��������������������������������������������������������0000664�0001750�0001750�00000012644�12224265625�020014� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 38;

=begin pod

Very basic instance method tests from L<S12/"Methods">

=end pod

# L<S12/"Method calls" /"either the dot notation or indirect object notation:">
class Foo {
  method doit ($a, $b, $c) { $a + $b + $c }
  method noargs () { 42 }
  method nobrackets { 'mice' }
  method callsmethod1() { self.noargs(); }
  method callsmethod2 { self.noargs(); }
}

my $foo = Foo.new();
is($foo.doit(1,2,3), 6, "dot method invocation");

my $val;
#?rakudo 2 skip 'indirect object notation'
lives_ok { $val = doit $foo: 1,2,3; }, '... indirect method invocation works';
is($val, 6, '... got the right value for indirect method invocation');

is($foo.noargs, 42, "... no parentheses after method");
is($foo.noargs(), 42, "... parentheses after method");

{
    my $val;
    lives_ok { $val = $foo.noargs\ (); }, "... <unspace> + parentheses after method";
    is($val, 42, '... we got the value correctly');
}

{
    my $val;
    lives_ok { $val = $foo.nobrackets() }, 'method declared with no brackets';
    is($val, 'mice', '... we got the value correctly');
}

{
    my $val;
    lives_ok { $val = $foo.callsmethod1() }, 'method calling method';
    is($val, 42, '... we got the value correctly');
};

{
    my $val;
    lives_ok { $val = $foo.callsmethod2() }, 'method calling method with no brackets';
    is($val, 42, '... we got the value correctly');
};

{
    # This test could use peer review to make sure it complies with the spec.
    class Zoo {
        method a () { my %s; %s.b }
    }
    dies_ok( { Zoo.new.a }, "can't call current object methods on lexical data structures");
}
# doesn't match, but defines "b"
sub b() { die "oops" }

# this used to be a Rakudo bug, RT #62046
{
    class TestList {
        method list {
            'method list';
        }
    }
    is TestList.new.list, 'method list', 'can call a method "list"';
}

# Test that methods allow additional named arguments
# http://irclog.perlgeek.de/perl6/2009-01-28#i_870566

{
    class MethodTester {
        method m ($x, :$y = '')  {
            "$x|$y";
        }
    }

    my $obj = MethodTester.new;

    is $obj.m('a'),        'a|',   'basic sanity 1';
    is $obj.m('a', :y<b>), 'a|b',  'basic sanity 2';
    lives_ok { $obj.m('a', :y<b>, :z<b>) }, 'additional named args are ignored';
    is $obj.m('a', :y<b>, :z<b>), 'a|b', '... same, but test value';

    # and the same with class methods

    is MethodTester.m('a'),        'a|',   'basic sanity 1 (class method)';
    is MethodTester.m('a', :y<b>), 'a|b',  'basic sanity 2 (class method)';
    lives_ok { MethodTester.m('a', :y<b>, :z<b>) }, 
             'additional named args are ignored (class method)';
    is MethodTester.m('a', :y<b>, :z<b>), 'a|b', 
       '... same, but test value (class method)';
}

# test that public attributes don't interfere with private methods of the same
# name (RT #61774)

{
    class PrivVsAttr {
        has @something is rw;
        method doit {
            @something = <1 2 3>;
            self!something;
        }
        method !something {
            'private method'
        }
    }

    my PrivVsAttr $a .= new;
    is $a.doit, 'private method',
       'call to private method in presence of attribute';
}

# used to be RT #69206

class AnonInvocant {
    method me(::T $:) {
        T;
    }
}

is AnonInvocant.new().me, AnonInvocant, 'a typed $: as invocant is OK';

# check that sub foo() is available from withing method foo();
# RT #74014

{
    my $tracker = '';
    sub foo($x) {
        $tracker = $x;
    }
    class MSClash {
        method foo($x) {
            foo($x);
        }
    }
    MSClash.new.foo('bla');
    is $tracker, 'bla', 'can call a sub of the same name as the current method';
}

# usage of *%_ in in methods, RT #73892
{
    my $tracker = '';
    sub track(:$x) {
        $tracker = $x;
    }
    class PercentUnderscore {
        method t(*%_) {
            track(|%_);
        }
        method implicit {
            track(|%_);
        }
    }
    lives_ok { PercentUnderscore.new.t(:x(5)) }, 'can use %_ in a method';
    is $tracker, 5, ' ... and got right result';
    lives_ok { PercentUnderscore.new.implicit(:x(42)) },
                    'can use implicit %_ in a method';
    is $tracker, 42, '... and got he right result';
}

{
    my $tracker = '';
    sub track(:$x) {
        $tracker = $x;
    }

    class ImplicitPercentUnderscore {
        method t {
            track(|%_);
        }
    }
    lives_ok { ImplicitPercentUnderscore.new.t(:x(5)) }, 'can use %_ in a method (implicit)';
    is $tracker, 5, ' ... and got right result (implicit)';
}

# RT #72940
{
    class X {
        method x(*@_) { @_[0] };
    }
    is X.new.x('5'), '5', 'can use explicit @_ in method signature';

}

{
    class Y {
        method y(Whatever) { 1; };
    }
    is Y.new.y(*), 1, 'Can dispatch y(*)';
}

{
    class InvocantTypeCheck {
        method x(Int $a:) {   #OK not used
            42;
        }
    }
    dies_ok { InvocantTypeCheck.new.x() }, 'Invocant type is checked';
}

# RT #83902
{
    my $tracker;
    class A {
        method foo { my $a = 42;
            method bar { $tracker = $a }
        }
    };
    given A.new { .foo; .bar }
    is $tracker, 42, 'nested methods work';
}

# RT #74490
{
    my $tracker;
    class HasMethod {
        $tracker = method foo() { };
    }
    isa_ok $tracker, Method,
        'a named method definition inside a class returns a Method';
    is $tracker.name, 'foo', '... and that method knows its name';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/lastcall.t��������������������������������������������������������0000664�0001750�0001750�00000003075�12224265625�020005� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 6;

# L<S12/"Calling sets of methods"/"It is also possible to trim the candidate list so that the current call is considered the final candidate.">

class Foo {
    # $.tracker is used to determine the order of calls.
    has $.tracker is rw;
    multi method doit($foo) { $.tracker ~= 'foo,' }   #OK not used
    method show  {$.tracker}
    method clear {$.tracker = ''}
}

class BazLastCallNext is Foo {
    multi method doit($foo) { $.tracker ~= 'baz,'; nextsame; }   #OK not used
    multi method doit(Int $foo) {   #OK not used
        $.tracker ~= 'bazint,';
        if 1 { lastcall }
        nextsame;
        $.tracker ~= 'ret3,';
    }
}

{
    my $o = BazLastCallNext.new;
    $o.clear;
    $o.doit("");
    is($o.show, 'baz,foo,', 'no lastcall, so we defer up the inheritance tree');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'bazint,ret3,', 'lastcall meant nextsame failed, no deferal happened');
}

class BarLastCallSame is Foo {
    multi method doit($foo) {$.tracker ~= 'bar,'; lastcall; callsame; $.tracker ~= 'ret1,'}   #OK not used
    multi method doit(Int $num) {$.tracker ~= 'barint,'; callsame; $.tracker ~= 'ret2,'}   #OK not used
}

{
    my $o = BarLastCallSame.new;
    $o.clear;
    $o.doit("");
    is($o.show, 'bar,ret1,', 'lastcall trims candidate list, so no call up inheritance tree');
    $o.clear;
    is($o.show, '', 'sanity test for clearing');
    $o.doit(5);
    is($o.show, 'barint,bar,ret1,ret2,', 'lastcall trimming does not affect stuff earlier in chain');
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/lvalue.t����������������������������������������������������������0000664�0001750�0001750�00000002533�12224265625�017474� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 16;

# L<S12/Lvalue methods/may be declared as lvalues with is rw.>

class T {
    has $.a;
    has $.b;
    method l1 is rw { 
        return-rw $!a;
    }

    method l2 is rw { 
        $!b;
    }
}

my $o = T.new(:a<x>, :b<y>);

is $o.l1,       'x',    'lvalue method as rvalue with explicit return';
is $o.l2,       'y',    'lvalue method as rvalue with implicit return';

lives_ok { $o.l1 = 3 }, 'can assign to the lvalue method (explicit return)';
is $o.l1,       3,      '... and the assignment worked';
is $o.a,        3,      '...also to the attribute';

lives_ok { $o.l2 = 4 }, 'can assign to the lvalue method (implicit return)';
is $o.l2,       4,      '... and the assignment worked';
is $o.b,        4,      '...also to the attribute';

my ($a, $b);
lives_ok { temp $o.l1 = 8; $a = $o.a },
         'can use lvalue method in temp() statement (explicit return)';
is $o.l1,       3,      '... and the value was reset';
is $o.a,        3,      '... also on the attribute';
is $a,          8,      'but the temp assignment had worked';

lives_ok { temp $o.l2 = 9; $b = $o.b },
         'can use lvalue method in temp() statement (implicit return)';
is $o.l2,       4,      '... and the value was reset';
is $o.b,        4,      '... also on the attribute';
is $b,          9,      'but the temp assignment had worked';

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/method-vs-sub.t���������������������������������������������������0000664�0001750�0001750�00000001577�12224265625�020710� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 5;

#L<S12/Method call vs. Subroutine call>

class test {
    method foo($a:) { 'method' }   #OK not used
};
sub foo($a) { 'sub' };   #OK not used
my $obj = test.new;

#?rakudo skip 'confused near "($obj:),  "'
#?niecza skip 'Invocant handling is NYI'
is foo($obj:),  'method', 'method with colon notation';
is $obj.foo,    'method', 'method with dot notation';
is foo($obj),   'sub', 'adding trailing comma should call the "sub"';

# RT #69610
{
    class RT69610 {
        our method rt69610() {
            return self;
        }
    }

    ok( { "foo" => &RT69610::rt69610 }.<foo>( RT69610.new ) ~~ RT69610,
        "Can return from method called from a hash lookup (RT 69610)" );
}

# RT #92192
#?pugs skip 'anon'
{
    my @a;
    my $n;
    for 1..5 -> $i { @a.push(anon method foo { $n++ }) };
    .($_) for @a;
    is $n, 5, 'RT #92192';
}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/multi.t�����������������������������������������������������������0000664�0001750�0001750�00000013167�12224265625�017343� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 32;

# L<S12/"Multisubs and Multimethods">
# L<S12/"Trusts">

class Foo {
    multi method bar() {
        return "Foo.bar() called with no args";
    }

    multi method bar(Str $str) {
        return "Foo.bar() called with Str : $str";
    }

    multi method bar(Int $int) {
        return "Foo.bar() called with Int : $int";
    }
    
    multi method bar(Numeric $num) {
        return "Foo.bar() called with Numeric : $num";
    }
    
    multi method baz($f) {
        return "Foo.baz() called with parm : $f";
    }
}


my $foo = Foo.new();
is($foo.bar(), 'Foo.bar() called with no args', '... multi-method dispatched on no args');

is($foo.bar("Hello"), 'Foo.bar() called with Str : Hello', '... multi-method dispatched on Str');

is($foo.bar(5), 'Foo.bar() called with Int : 5', '... multi-method dispatched on Int');
is($foo.bar(4.2), 'Foo.bar() called with Numeric : 4.2', '... multi-method dispatched on Numeric');

#?rakudo todo 'RT 66006'
try { eval '$foo.baz()' };
#?niecza todo 'This test is pretty dubious IMO'
ok ~$! ~~ /:i argument[s?]/, 'Call with wrong number of args should complain about args';

role R1 {
    method foo($x) { 1 }   #OK not used
}
role R2 {
    method foo($x, $y) { 2 }   #OK not used
}
eval_dies_ok 'class X does R1 does R2 { }', 'sanity: get composition conflict error';
class C does R1 does R2 {
    proto method foo(|) { * }
}
my $obj = C.new;
#?rakudo 2 skip 'proto does not promote to multi'
#?niecza skip 'No candidates for dispatch to C.foo'
is($obj.foo('a'),     1, 'method composed into multi from role called');
#?niecza skip 'No candidates for dispatch to C.foo'
is($obj.foo('a','b'), 2, 'method composed into multi from role called');


class Foo2 {
    multi method a($d) {   #OK not used
        "Any-method in Foo";
    }
}
class Bar is Foo2 {
    multi method a(Int $d) {   #OK not used
        "Int-method in Bar";
    }
}

is Bar.new.a("not an Int"), 'Any-method in Foo';

# RT #67024
{
    try { eval 'class RT67024 { method a(){0}; method a($x){1} }' };
    #?niecza skip 'Exception NYI'
    ok  $!  ~~ Exception, 'redefinition of non-multi method (RT 67024)';
    #?niecza todo 'depends on previous test'
    ok "$!" ~~ /multi/, 'error message mentions multi-ness';
}

# RT 69192
#?rakudo skip 'unknown bug'
#?niecza skip 'NYI dottyop form .*'
{
    role R5 {
        multi method rt69192()       { push @.order, 'empty' }
        multi method rt69192(Str $a) { push @.order, 'Str'   }   #OK not used
    }
    role R6 {
        multi method rt69192(Numeric $a) { push @.order, 'Numeric'   }   #OK not used
    }
    class RT69192 { has @.order }

    {
        my RT69192 $bot .= new();
        ($bot does R5) does R6;
        $bot.*rt69192;
        is $bot.order, <empty>, 'multi method called once on empty signature';
    }

    {
        my RT69192 $bot .= new();
        ($bot does R5) does R6;
        $bot.*rt69192('RT #69192');
        is $bot.order, <Str>, 'multi method called once on Str signature';
    }

    {
        my RT69192 $bot .= new();
        ($bot does R5) does R6;
        $bot.*rt69192( 69192 );
        is $bot.order, <Numeric>, 'multi method called once on Numeric signature';
    }
}

#?niecza skip 'ambiguous'
{
    role RoleS {
        multi method d( Str $x ) { 'string' }   #OK not used
    }
    role RoleI {
        multi method d( Int $x ) { 'integer' }   #OK not used
    }
    class M does RoleS does RoleI {
        multi method d( Any $x ) { 'any' }   #OK not used
    }

    my M $m .= new;

    is $m.d( 876 ), 'integer', 'dispatch to one role';
    is $m.d( '7' ), 'string',  'dispatch to other role';
    is $m.d( 1.2 ), 'any',     'dispatch to the class with the roles';

    my @multi_method = $m.^methods.grep({ ~$_ eq 'd' });
    is @multi_method.elems, 1, '.^methods returns one element for a multi';

    my $routine = @multi_method[0];
    ok $routine ~~ Routine, 'multi method from ^methods is a Routine';
    my @candies = $routine.candidates;
    is @candies.elems, 3, 'got three candidates for multi method';

    ok @candies[0] ~~ Method, 'candidate 0 is a method';
    ok @candies[1] ~~ Method, 'candidate 1 is a method';
    ok @candies[2] ~~ Method, 'candidate 2 is a method';
}

{
    class BrokenTie {
        multi method has_tie(Int $x) { 'tie1' };   #OK not used
        multi method has_tie(Int $y) { 'tie2' };   #OK not used
    }

    dies_ok { BrokenTie.has_tie( 42 ) }, 'call to tied method dies';

    class WorkingTie is BrokenTie {
        multi method has_tie(Int $z) { 'tie3' };   #OK not used
        multi method has_tie(Str $s) { 'tie4' };   #OK not used
    }

    is WorkingTie.has_tie( 42 ), 'tie3', 'broken class fixed by subclass (1)';
    is WorkingTie.has_tie( 'x' ), 'tie4', 'broken class fixed by subclass (2)';

    my $error;
    try {
        WorkingTie.new.has_tie([]);
    }
    $error = "$!";
    ok $error ~~ /<< 'has_tie' >>/,
        'error message for failed dispatch contains method name';
    ok $error ~~ /<< 'WorkingTie' >>/,
        'error message for failed dispatch contains invocant type';
}

# RT #68996
{
    class A {
        has $.foo = "bar";
        multi method foo(Str $test) {
            return $test;
        }
    };

    my $a = A.new;
    
    is $a.foo("oh hai"), "oh hai",
        'foo() method works when $.foo attribute is present';

    dies_ok { $a.foo }, 
        '$.foo attribute has no accessor when foo() method is present';
}

# RT #57788
{
    eval_dies_ok 'class RT57788 { method m() { }; method m() { } }';
}

{
    class B {
        multi method foo() { }
        multi method bar() { }
    }

    lives_ok { B.new.foo() },
        'multis with different names but same signatures are not ambiguous';
}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/parallel-dispatch.t�����������������������������������������������0000664�0001750�0001750�00000011100�12237474612�021565� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 37;

# L<S12/"Parallel dispatch"/"Any of the method call forms may be turned into a hyperoperator">
# syn r14547

class Foo {
    trusts GLOBAL;
    has $.count is rw;
    method doit {$.count++}
    method !priv {$.count++}
}

class Bar is Foo {
    method doit {$.count++;}
}

{
    my @o = (5..10).map({Foo.new(count => $_)});
    is(@o.map({.count}), (5..10), 'object sanity test');
    @o».doit;
    is(@o.map({.count}), (6..11), 'parallel dispatch using » works');
    @o>>.doit;
    is(@o.map({.count}), (7..12), 'parallel dispatch using >> works');
    @o»!Foo::priv;
    is(@o.map({.count}), (8..13), 'parallel dispatch to a private using »! works');
    @o>>!Foo::priv;
    is(@o.map({.count}), (9..14), 'parallel dispatch to a private using >>! works');
}

{
    my @o = (5..10).map({Foo.new(count => $_)});
    is(@o.map({.count}), (5..10), 'object sanity test');
    lives_ok({@o».?not_here},  'parallel dispatch using @o».?not_here lives');
    lives_ok({@o>>.?not_here}, 'parallel dispatch using @o>>.?not_here lives');
    dies_ok({@o».not_here},    'parallel dispatch using @o».not_here dies');
    dies_ok({@o>>.not_here},   'parallel dispatch using @o>>.not_here dies');

    @o».?doit;
    is(@o.map({.count}), (6..11), 'parallel dispatch using @o».?doit works');
    @o>>.?doit;
    is(@o.map({.count}), (7..12), 'parallel dispatch using @o>>.?doit works');
    #?rakudo todo 'is_deeply does not think map results are the same as list on LHS'
    #?niecza skip "=== Nil NYI"
    is (@o».?not_here).map({ $_ === Nil }).join(", "), @o.map({ True }).join(", "),
       '$obj».?nonexistingmethod returns a list of Nil';
    is (@o».?count).join(", "), @o.map({.count}).join(", "),
       '$obj».?existingmethod returns a list of the return values';
}

#?niecza skip 'NYI dottyop form'
{
    my @o = (5..10).map({Bar.new(count => $_)});
    is(@o.map({.count}), (5..10), 'object sanity test');
    lives_ok({@o».*not_here},  'parallel dispatch using @o».*not_here lives');
    lives_ok({@o>>.*not_here}, 'parallel dispatch using @o>>.*not_here lives');
    dies_ok({@o».+not_here},   'parallel dispatch using @o».+not_here dies');
    dies_ok({@o>>.+not_here},  'parallel dispatch using @o>>.+not_here dies');

    @o».*doit;
    is(@o.map({.count}), (7..12), 'parallel dispatch using @o».*doit works');
    @o».+doit;
    is(@o.map({.count}), (9..14), 'parallel dispatch using @o».*doit works');
}

{
    is(<a bc def ghij klmno>».chars,  (1, 2, 3, 4, 5), '<list>».method works');
    is(<a bc def ghij klmno>>>.chars, (1, 2, 3, 4, 5), '<list>>>.method works');
}

{
    my @a = -1, 2, -3;
    my @b = -1, 2, -3;
    @a».=abs;
    is(@a, [1,2,3], '@list».=method works');
    @b>>.=abs;
    is(@b, [1,2,3], '@list>>.=method works');
}

# more return value checking
{
    class PDTest {
        has $.data;
        multi method mul(Int $a) {
            $.data * $a;
        }
        multi method mul(Num $a) {
            $.data * $a.Int  * 2
        }
    }

    my @a = (1..3).map: { PDTest.new(data => $_ ) };
    my $method = 'mul';

    is (@a».mul(3)).join(", "), (3, 6, 9).join(", "),  'return value of @a».method(@args)';
    is (@a»."$method"(3)).join(", "), (3, 6, 9).join(", "),  '... indirect';
      
    is (@a».?mul(3)).join(", "), (3, 6, 9).join(", "), 'return value of @a».?method(@args)';
    is (@a».?"$method"(3)).join(", "), (3, 6, 9).join(", "), '... indirect';

    #?rakudo 4 todo 'is_deeply does not think map results are the same as list on LHS'
    #?niecza 4 skip 'NYI dottyop form'
    is_deeply @a».+mul(2), ([2, 4], [4, 8], [6, 12]),
              'return value of @a».+method is a list of lists';
    is_deeply @a».+"$method"(2), ([2, 4], [4, 8], [6, 12]),
              '... indirect';

    is_deeply @a».*mul(2), ([2, 4], [4, 8], [6, 12]),
              'return value of @a».*method is a list of lists';
    is_deeply @a».*"$method"(2), ([2, 4], [4, 8], [6, 12]),
              '... indirect';
}

# test postcircumfix parallel dispatch
#?niecza skip 'Cannot use hash access on an object of type Pair'
#?rakudo skip 'No such method postcircumfix:<( )> for invocant of type Pair'
{
    is (a => 1, a => 2)>>.<a>, '1 2',   # METHOD TO SUB CASUALTY
        '>>.<a>';
}

{
    BEGIN { @*INC.push: 't/spec/packages' };
    use ContainsUnicode;
    is uc-and-join('foo', 'bar'), 'FOO, BAR',
        'parallel dispatch with » works in modules too';

}

# RT #77436
#?pugs 2 skip
{
    is (1,2,3)».$( * + 42 ), [43, 44, 45], '$( ) after dotty parallel dispatch';
    is (1,2,3)».&( * + 42 ), [43, 44, 45], '&( ) after dotty parallel dispatch';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/private.t���������������������������������������������������������0000664�0001750�0001750�00000004573�12224265625�017664� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;

plan 13;

# L<S12/Private methods/"Private methods are declared using">

class A {
    method !private {
        12;
    }
    method public {
        self!private
    }
}

is A.new().public, 12, 'Can call private method from within the class';
dies_ok {eval('A.new!private')}, 'Can not call private method from outside';

# indirect call syntax for public and private methods

class Indir {
    method a {
        'aa';
    }
    method !b {
        'bb';
    }
    method b_acc1 {
        self!"b"();   #OK use of quotes
    }
    method b_acc2 {
        self!'b'();   #OK use of quotes
    }
}

my $o = Indir.new();

is $o."a"(),    "aa", 'indirect call to public method (double quotes)';   #OK use of quotes
is $o.'a'(),    "aa", 'indirect call to public method (single quotes)';   #OK use of quotes
is $o.b_acc1, 'bb', 'indirect call to private method (double quotes)';
is $o.b_acc2, 'bb', 'indirect call to private method (single quotes)';
dies_ok {$o."b"() },  'can not call private method via quotes from outside';   #OK use of quotes

# L<S14/Roles/"same, but &foo is aliased to &!foo">

# method !foo in a role gets composed in as a private method and is callable
# as one. XXX Role Private Methods? my method !foo() { ... } different?

{
    role C {
        method !role_shared {
            18;
        }
        my method !role_private {
            36;
        }
    }

    class B does C {
        method !private {
            24;
        }
        method public1 {
            self!private();
        }
        method public2 {
            self!role_shared();
        }
        method public3 {
            self!role_private();
        }
    }

    my $b = B.new();

    is $b.public1, 24, '"my method private" can be called as self!private';
    is $b.public2, 18, 'can call role shared private methods';
    #?niecza todo 'role private methods - spec?'
    dies_ok { $b.public3() }, 'can not call role private methods scoped with my';
}

# RT #101964
{
    class RT101964 {
        has @!c;
        method foo { self!bar(@!c) }
        method !bar(@r) {  #OK not used
            'OH HAI';
        }
    }
    is RT101964.new.foo, 'OH HAI', 'can pass private array attribute to private method param';
}

#RT #115308
#?niecza skip "throws_like NYI"
#?DOES 2
throws_like '$_!X::a', X::Method::Private::Permission;

# vim: syn=perl6
�������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/qualified.t�������������������������������������������������������0000664�0001750�0001750�00000001022�12224265625�020137� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 2;

class Parent {
    method me {
        self;
    }
}

class Child is Parent {
    method myself {
        self.Parent::me();
    }
}

role R {
    method me {
        self;
    }
}

class Consumer does R {
    method myself {
        self.R::me();
    }
}

my $child = Child.new;
is( $child.myself, $child, 'Qualified method calls should use the original self' );

my $consumer = Consumer.new;
is( $consumer.myself, $consumer, 'Qualified method calls should use the original self' );

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/submethods.t������������������������������������������������������0000664�0001750�0001750�00000007461�12224265625�020366� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 27;

=begin pod

Basic submethod tests. See L<S12/"Submethods">

=end pod
# L<S12/Submethods>
{

  class Foo        { has $.foo_build; submethod BUILD() { $!foo_build++ } }
  class Bar is Foo { has $.bar_build; submethod BUILD() { $!bar_build++ } }

  my $a;
  lives_ok {$a = Foo.new()},    "Foo.new() worked (1)";
  is $a.foo_build, 1,           "Foo's BUILD was called";
  # is instead of todo_is to avoid unexpected succeedings
  dies_ok { $a.bar_build },     "Bar's BUILD counter not available";

  my $b;
  lives_ok {$b = Bar.new()},    "Bar.new() worked";
  is $b.foo_build, 1,           "Foo's BUILD was called again";
  is $b.bar_build, 1,           "Bar's BUILD was called, too";

  # The next three tests are basically exactly the same as the first three tests
  # (not counting the initial class definition). This is to verify our call to
  # Bar.new didn't removed/changed some internal structures which'd prevent
  # Foo.BUILD of getting called.
  my $c;
  lives_ok {$c = Foo.new()}, "Foo.new() worked (2)";
  is $c.foo_build, 1,      "Foo's BUILD was called again";
}

# See thread "BUILD and other submethods" on p6l
# L<"http://groups-beta.google.com/group/perl.perl6.language/msg/e9174e5538ded4a3">
{
  class Baz         {
      has $.baz_blarb = 0;
      submethod blarb() { $!baz_blarb++ } 
  }
  class Grtz is Baz {
      has $.grtz_blarb = 0;
      submethod blarb() { $!grtz_blarb++ } 
  }

  my ($baz, $grtz);
  lives_ok {$baz  = Baz.new},  "Baz.new() worked";
  lives_ok {$grtz = Grtz.new}, "Grtz.new() worked";

  lives_ok { $baz.blarb },      'can call submethod on parent class';
  is $baz.baz_blarb,         1, "Baz's submethod blarb was called";
  is $grtz.grtz_blarb,       0, "Grtz's submethod blarb was not called";

  lives_ok { $grtz.blarb },     'can call submethod on child class';
  is $grtz.baz_blarb,        0, "Baz's submethod blarb was not called";
  is $grtz.grtz_blarb,       1, "Grtz's submethod blarb was called now";

  lives_ok { $grtz.Baz::blarb }, '$obj.Class::submthod';
  is $grtz.baz_blarb,        1, "Baz's submethod blarb was called now";
  is $grtz.grtz_blarb,       1, "Grtz's submethod blarb was not called again";
}

# Roles with BUILD
# See thread "Roles and BUILD" on p6l
# L<"http://www.nntp.perl.org/group/perl.perl6.language/21277">
#?rakudo skip 'outer lexicals in roles'
#?niecza todo
{
  my $was_in_a1_build = 0;
  my $was_in_a2_build = 0;
  role RoleA1  { multi submethod BUILD() { $was_in_a1_build++ } }
  role RoleA2  { multi submethod BUILD() { $was_in_a2_build++ } }
  class ClassA does RoleA1 does RoleA2 {}

  ClassA.new;

  is $was_in_a1_build, 1, "roles' BUILD submethods were called when mixed in a class (1)";
  is $was_in_a2_build, 1, "roles' BUILD submethods were called when mixed in a class (2)";
}

#?rakudo skip 'roles and submethods'
#?pugs skip 'does'
#?DOES 4
{
  my $was_in_b1_build = 0;
  my $was_in_b2_build = 0;
  role RoleB1  { multi submethod BUILD() { $was_in_b1_build++ } }
  role RoleB2  { multi submethod BUILD() { $was_in_b2_build++ } }
  class ClassB {}

  my $B = ClassB.new;
  is $was_in_b1_build, 0, "roles' BUILD submethods were not yet called (1)";
  is $was_in_b2_build, 0, "roles' BUILD submethods were not yet called (2)";

  $B does (RoleB1, RoleB2);
  #?niecza 2 todo
  is $was_in_b1_build, 1, "roles' BUILD submethods were called now (1)";
  is $was_in_b2_build, 1, "roles' BUILD submethods were called now (2)";
};

# BUILD with signatures that don't map directly to attributes
{
  class ClassC
  {
    has $.double_value;

    submethod BUILD ( :$value = 1 )
    {
      $!double_value = $value * 2;
    }
  }

  my $C = ClassC.new();
  is( $C.double_value, 2,
    'BUILD() should allow default values of optional params in signature' );

  my $C2 = ClassC.new( :value(100) );
  is( $C2.double_value, 200, '... or value passed in' );
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/syntax.t����������������������������������������������������������0000664�0001750�0001750�00000003302�12224265625�017525� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

# L<S12/Fancy method calls/"no space between the method name and the left parenthesis">

class A {
    multi method doit () { 'empty' };
    multi method doit ($a, $b, *@rest) {
        "a:$a|b:{$b}!" ~ @rest.join('!');
    }
}

$_ = A.new();

is .doit,       'empty',        'plain call with no args';
is .doit(),     'empty',        'method call with parens and no args';
eval_dies_ok '.doit ()',        '.doit () illegal';
is .doit\ (),   'empty',        'method call with unspace';

is (.doit: 1, 2, 3),    'a:1|b:2!3',    'list op with colon';
is (.doit: 1, 2, 3, 4), 'a:1|b:2!3!4',  'list op with colon, slurpy';
#?rakudo 3 skip 'switch-from-paren-to-listop form'
#?niecza 3 skip 'Interaction between semiargs and args is not understood'
is (.doit(1): 2, 3),    'a:1|b:2!3',    'list op with colon';
is (.doit(1, 2): 3),    'a:1|b:2!3',    'list op with colon';
is (.doit\  (1, 2): 3), 'a:1|b:2!3',    'list op with colon, unspace';

# L<S12/Fancy method calls/"if any term in a list is a bare closure">
#?rakudo skip 'adverbial closures'
#?niecza skip 'Excess arguments to Any.map, used 2 of 4 positionals'
is (1..8).grep: { $_ % 2 }.map: { $_ - 1}.join('|'), '0|2|4|6', 
   'adverbial closure has right precedence and associativity';

# Used to be Rakudo RT #61988, $.foo form didn't accept arguments

{
    class B {
        method a ($a, $b) { $a + $b }
        method b { $.a(2, 3) }
    }

    is B.new.b, 5, '$.a can accept arguments';
}

# RT #69350
# test that you can't manipulate methods by writinig to the symbol table
{
    class Manip { method a { 1} };
    &Manip::a = sub ($:) { 2 };
    is Manip.new.a, 1, 'Writing to a symbol table does not alter methods';
}


# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/topic.t�����������������������������������������������������������0000664�0001750�0001750�00000001074�12224265625�017321� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# old: L<A12/"Declaration of Methods" /methods do not set the topic now/>
# (This is an an "update" section.)
# not mentioned explicitly in S12, but still true.

plan 2;

class Foo {
    method no_topic     { .echo }
    method topic ($_: ) { .echo }
    method echo         { "echo"  }
}

{
    my Foo $foo .= new;
    #?pugs todo 'outdated semantics'
    dies_ok { $foo.no_topic() }, '$_ is not set in methods...';
}

{
    my Foo $foo .= new;
    is $foo.topic(), "echo", '...unless $_ the invocant name is specified to be "$_"';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/trusts.t����������������������������������������������������������0000664�0001750�0001750�00000001313�12224265625�017543� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 4;

class Trustee { ... }
class Truster {
    trusts Trustee;
    has $.x;
    method !get-x-priv {
        $!x;
    }
}

class ChildTruster is Truster { };

class Trustee {
    method x($truster) {
        $truster!Truster::get-x-priv();
    }
}

eval_dies_ok 'Truster.new()!Truster::get-x-priv',
    'can not access private method without a trust';
is Trustee.x(Truster.new(x => 5)), 5, 'can access private method with trust';
is Trustee.x(ChildTruster.new(x => 5)), 5, 'can access private method with trust + subclass';
eval_dies_ok q[class ChildTrustee { method x($t) { $t!Truster>>get-x-priv()} }],
    'trust relation does not extend to child classes of the trustee'


# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/typed-attributes.t������������������������������������������������0000664�0001750�0001750�00000001277�12224265625�021521� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 7;

class Bar {
    method baz returns Str { 'Baz' }
}

class Foo {
    has Bar $.bar;
    
    method call_bar {
        return $.bar.baz();
    }

    method call_bar_indirectly {
        my $bar = $.bar;
        return $bar.baz();
    }
}

my $bar = Bar.new();
isa_ok($bar, Bar);

my $foo = Foo.new(:bar($bar));
isa_ok($foo, Foo);

# sanity test
is($bar.baz(), 'Baz', '... sanity test, this works as we expect');

my $val;
lives_ok { $val = $foo.call_bar() }, '... this should work';
is $val, 'Baz', '... this should be "Baz"';

my $val2;
lives_ok { $val2 = $foo.call_bar_indirectly() }, '... this should work';
is($val2, 'Baz', '... this should be "Baz"');

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-methods/what.t������������������������������������������������������������0000664�0001750�0001750�00000006341�12224265625�017150� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 33;

=begin pod

=head1 DESCRIPTION

This test tests the C<WHAT> builtin.

=end pod

# L<S12/Introspection/"WHAT">

# Basic subroutine/method form tests for C<WHAT>.
{
  my $a = 3;
  ok((WHAT $a) === Int, "subroutine form of WHAT");
  ok(($a.WHAT) === Int, "method form of WHAT");
}

# Now testing basic correct inheritance.
{
  my $a = 3;
  ok($a.WHAT ~~ Numeric, "an Int isa Numeric");
  ok($a.WHAT ~~ Mu,  "an Int isa Mu");
}

# And a quick test for Code:
{
  my $a = sub ($x) { 100 + $x };
  ok($a.WHAT === Sub,    "a sub's type is Sub");
  ok($a.WHAT ~~ Routine, "a sub isa Routine");
  ok($a.WHAT ~~ Code,    "a sub isa Code");
}

# L<S12/Introspection/"which also bypasses the macros.">

# RT #60992
{
    class Foo {
        method WHAT {'Bar'}
    }
    my $o = Foo.new;
    is($o."WHAT"(), 'Bar', '."WHAT" calls the method instead of the macro');
    is($o.WHAT.gist,   '(Foo)', '.WHAT still works as intended');
    my $meth = method () { 'Bar' };
    is($o.$meth,  'Bar', '.$meth calls the method instead of the macro');
}

# these used to be Rakudo regressions, RT #62006
{
    # proto as a term
    lives_ok {  Match }, 'type object as a term lives';
    lives_ok { +Match }, 'numification of type object lives';
    isa_ok ("bac" ~~ /a/).WHAT, Match, '.WHAT on a Match works';
    is +("bac" ~~ /a/).WHAT, 0, 'numification of .WHAT of a Match works';
}

ok &infix:<+>.WHAT ~~ Sub, '.WHAT of built-in infix op is Multi (RT 66928)';

# RT #69915
{
    sub rt69915f($b, :$a! ) { return WHAT($a).gist ~ '~' ~ WHAT($b).gist }
    sub rt69915m( $b, :$a! ) { return $a.WHAT.gist  ~ '~' ~ $b.WHAT.gist }

    is rt69915m( a => 42, 23 ), '(Int)~(Int)', 'WHAT method on ints';

    is rt69915f( a => 42, 23 ), '(Int)~(Int)', 'WHAT function on ints (1)';
    is rt69915f( 23, a => 42 ), '(Int)~(Int)', 'WHAT function on ints (2)';

    is rt69915f( :a, 23 ), '(Bool)~(Int)', 'WHAT function on bool and int';
    is rt69915m( :a, 23 ), '(Bool)~(Int)', 'WHAT method on bool and int';

    sub wm($x) { return $x.WHAT.gist }
    sub rt69915wm( $b, :$a ) { return wm($a) ~ '~' ~ wm($b) }
    is rt69915wm( a => 42, 23 ), '(Int)~(Int)', 'WHAT method on ints via func';
    
    sub wf($x) { return WHAT($x).gist }
    sub rt69915wf( $b, :$a ) { return wf($a) ~ '~' ~ wf($b) }
    is rt69915wf( a => 42, 23 ), '(Int)~(Int)', 'WHAT func on ints via func';
}

is 6.02e23.WHAT.gist, Num.gist, 'decimal using "e" is a Num';
is 1.23456.WHAT.gist, Rat.gist, 'decimal without "e" is Rat';
ok 1.1 == 11/10, 'decimal == the equivalent rational';

# RT #70237
{
    is 1.WHAT.gist, '(Int)', '1.WHAT sanity';
    dies_ok { Int.WHAT = Str }, '.WHAT is readonly';
    is 2.WHAT.gist, '(Int)', 'assignment to Int.WHAT does nothing';
}

{
    class AccessMethods {
        our method a { };
        method b { };
    }

    ok &AccessMethods::a.defined, 'Can access "our" method with &class::method';
    ok &AccessMethods::a ~~ Method, '... and got a Method back';
    nok &AccessMethods::b.defined, '"has" methods are hidden';
    lives_ok {&AccessMethods::c.defined and die "foo"}, 'non-existent method access lives (and returns undef)';

}

# RT 112364
{
    class RT112364 {
        our sub xyz() { 'xyz' }
    };
    ok RT112364::.WHAT ~~ Stash, 'RT 112364';
}

done;

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-subset/multi-dispatch.t���������������������������������������������������0000664�0001750�0001750�00000001624�12224265625�020775� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S12/Types and Subtypes/>

plan 6;

subset Even of Int where { $_ % 2 == 0 };
subset Odd  of Int where { $_ % 2 == 1 };

multi sub test_subtypes(Even $y){ 'Even' }   #OK not used
multi sub test_subtypes(Odd  $y){ 'Odd'  }   #OK not used

is test_subtypes(3), 'Odd',  'mutli dispatch with type mutual exclusive type constaints 1';
is test_subtypes(4), 'Even', 'mutli dispatch with type mutual exclusive type constaints 1';


multi sub mmd(Even $x) { 'Even' }   #OK not used
multi sub mmd(Int  $x) { 'Odd'  }   #OK not used

is mmd(3), 'Odd' , 'MMD with subset type multi works';
is mmd(4), 'Even', 'subset multi is narrower than the general type';

multi foo ($foo where { $_ eq "foo"}) { $foo }
is foo("foo"), "foo", "when we have a single candidate with a constraint, it's enforced";
dies_ok { foo("bar") }, "value that doesn't meet single constraint causes failed dispatch";

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-subset/subtypes.t���������������������������������������������������������0000664�0001750�0001750�00000021742�12224265625�017727� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;


=begin description

Tests subtypes, specifically in the context of multimethod dispatch.

=end description

# L<S12/"Types and Subtypes">

#?niecza skip '$n has already been used as a non-placeholder in the surrounding block'
{
    my $abs = '
    multi sub my_abs (Int $n where { $^n >= 0 }){ $n }
    multi sub my_abs (Int $n where { $^n <  0 }){ -$n }
    ';

    ok(eval("$abs; 1"), "we can compile subtype declarations");

    is(eval("$abs; my_abs(3)"), 3, "and we can use them, too");
    is(eval("$abs; my_abs(-5)"), 5, "and they actually work");
}

{
    my $abs = '
    multi sub another_abs (Int $n where { $_ >= 0 }){ $n }
    multi sub another_abs (Int $n where { $_ <  0 }){ -$n }
    ';

    ok(eval("$abs; 1"), "we can compile subtype declarations");

    is(eval("$abs; another_abs(3)"), 3, "and we can use them, too");
    is(eval("$abs; another_abs(-5)"), 5, "and they actually work");
}

# another nice example
{
    multi factorial (Int $x)          { $x * factorial($x-1) };
    multi factorial (Int $x where 0 ) { 1 };   #OK not used
    is factorial(3), 6, 'subset types refine candidate matches';
}

# Basic subtype creation

{
    subset Int::Odd of Int where { $^num % 2 == 1 };
    is eval('my Int::Odd $a = 3'), 3, "3 is an odd num";
    # The eval inside the eval is/will be necessary to hider our smarty
    # compiler's compile-time from bailing.
    # (Actually, if the compiler is *really* smarty, it will notice our eval trick,
    # too :))
    is eval('my Int::Odd $b = 3; try { $b = eval "4" }; $b'), 3,
      "objects of Int::Odd don't get even";

    # Subtypes should be undefined.
    nok Int::Odd.defined, 'subtypes are undefined';

    # Subs with arguments of a subtype
    sub only_accepts_odds(Int::Odd $odd) { $odd + 1 }
    is only_accepts_odds(3), 4, "calling sub worked";
    dies_ok { only_accepts_odds(4) },  "calling sub did not work";

    # Can smartmatch too
    sub is_num_odd(Int::Odd $odd) { $odd ~~ Int::Odd },
    ok is_num_odd(3), "Int accepted by Int::Odd";
}

# The same, but lexically
#?niecza skip 'Pathed definitions require our scope'
{
    my subset Int::Even of Int where { $^num % 2 == 0 }
    ok my Int::Even $c = 6;
    ok $c ~~ Int::Even, "our var is a Int::Even";
    try { $c = 7 }
    is $c, 6, "setting a Int::Even to an odd value dies";
    ok eval('!try { my Int::Even $d }'),
        "lexically declared subtype went out of scope";
}

# Following code is evil, but should work:
{
  my Int $multiple_of;
  subset Num::Multiple of Int where { $^num % $multiple_of == 0 }

  $multiple_of = 5;
  ok $multiple_of ~~ Int, "basic sanity (1)";
  is $multiple_of,     5, "basic sanity (2)";

  ok (my Num::Multiple $d = 10), "creating a new Num::Multiple";
  is $d,                   10,   "creating a new Num::Multiple actually worked";
  dies_ok { $d = 7 },            'negative test also works';
  is $d,                   10,   'variable kept previous value';

  
  $multiple_of = 6;
  dies_ok { my Num::Multiple $e = 10 }, "changed subtype definition worked";
}

# Rakudo had a bug where 'where /regex/' failed
# http://rt.perl.org/rt3/Ticket/Display.html?id=60976
#?DOES 2
{
    subset HasA of Str where /a/;
    lives_ok { my HasA $x = 'bla' },   'where /regex/ works (positive)';
    eval_dies_ok 'my HasA $x = "foo"', 'where /regex/ works (negative)';
}

# You can write just an expression rather than a block after where in a sub
# and it will smart-match it.
{
    sub anon_where_1($x where "x") { 1 }   #OK not used
    sub anon_where_2($x where /x/) { 1 }   #OK not used
    is(anon_where_1('x'), 1,       'where works with smart-matching on string');
    dies_ok({ anon_where_1('y') }, 'where works with smart-matching on string');
    is(anon_where_2('x'), 1,       'where works with smart-matching on regex');
    is(anon_where_2('xyz'), 1,     'where works with smart-matching on regex');
    dies_ok({ anon_where_2('y') }, 'where works with smart-matching on regex');
}

# Block parameter to smart-match is readonly.
{
    subset SoWrong of Str where { $^epic = "fail" }
    sub so_wrong_too($x where { $^epic = "fail" }) { }   #OK not used
    my SoWrong $x;
    dies_ok({ $x = 42 },          'parameter in subtype is read-only...');
    dies_ok({ so_wrong_too(42) }, '...even in anonymous ones.');
}

# ensure that various operations do type cheks

{
    subset AnotherEven of Int where { $_ % 2 == 0 };
    my AnotherEven $x = 2;
    dies_ok { $x++ }, 'Even $x can not be ++ed';
    is $x, 2,         '..and the value was preserved';
    dies_ok { $x-- }, 'Even $x can not be --ed';
    is $x, 2,         'and the value was preserved';
}

{
    # chained subset types
    subset Positive of Int where { $_ > 0 };
    subset NotTooLarge of Positive where { $_ < 10 };

    my NotTooLarge $x;

    lives_ok { $x = 5 }, 'can satisfy both conditions on chained subset types';
    dies_ok { $x = -2 }, 'violating first condition barfs';
    dies_ok { $x = 22 }, 'violating second condition barfs';
}


# subtypes based on user defined classes and roles
{
    class C1 { has $.a }
    subset SC1 of C1 where { .a == 42 }
    ok !(C1.new(a => 1) ~~ SC1), 'subtypes based on classes work';
    ok C1.new(a => 42) ~~ SC1,   'subtypes based on classes work';
}

#?niecza skip 'Object reference not set to an instance of an object'
{
    role R1 { }; 
    subset SR1 of R1 where 1;
    ok !(1 ~~ SR1), 'subtypes based on roles work';
    my $x = 1 but R1;
    ok $x ~~ SR1,   'subtypes based on roles work';
}

subset NW1 of Int;
ok NW1 ~~ Int,  'subset declaration without where clause does type it refines';
ok 0 ~~ NW1,    'subset declaration without where clause accepts right value';
ok 42 ~~ NW1,   'subset declaration without where clause accepts right value';
ok 4.2 !~~ NW1, 'subset declaration without where clause rejects wrong value';
ok "x" !~~ NW1, 'subset declaration without where clause rejects wrong value';

# RT #65700
{
    subset Small of Int where { $^n < 10 }
    class RT65700 {
        has Small $.small;
    }
    #?niecza todo
    dies_ok { RT65700.new( small => 20 ) }, 'subset type is enforced as attribute in new() (1)';
    lives_ok { RT65700.new( small => 2 ) }, 'subset type enforced as attribute in new() (2)';

    my subset Teeny of Int where { $^n < 10 }
    class T { has Teeny $.teeny }
    #?niecza todo
    dies_ok { T.new( teeny => 20 ) }, 'my subset type is enforced as attribute in new() (1)';
    lives_ok { T.new( teeny => 2 ) }, 'my subset type enforced as attribute in new() (2)';
}

# RT #78318
{
    my @*rt78318;
    subset Bug  of Int where { @*rt78318.push( 'bug' ) };
    subset Hunt of Bug where { @*rt78318.push( 'hunt' ) };
    78318 ~~ Hunt;
    is @*rt78318, <bug hunt>, 'code called when subtype built on subtype';
}

# RT #78322
{
    my $*call1;
    my $*call2;

    $*call1 = 0;$*call2 = 0;

    subset RT78322 of Int     where { $*call1++; $^a == 78322 };
    subset Bughunt of RT78322 where { $*call2++; ?1 };

    $*call1 = 0;$*call2 = 0;
    nok 22 ~~ RT78322, 'level one subset check is false';
    is $*call1, 1, 'level one subset checked (should fail)';
    is $*call2, 0, 'level two subset not checked';

    $*call1 = 0;$*call2 = 0;
    nok 22 ~~ Bughunt, 'overall subset check is false';
    is $*call1, 1, 'level one subset checked (should fail)';
    is $*call2, 0, 'level two subset not checked';

    $*call1 = 0;$*call2 = 0;
    ok 78322 ~~ RT78322, 'level one subset check is true';
    is $*call1, 1, 'level one subset checked (should succeed)';
    is $*call2, 0, 'level two subset not checked';

    $*call1 = 0;$*call2 = 0;
    ok 78322 ~~ Bughunt, 'overall subset check is true';
    is $*call1, 1, 'level one subset checked (should succeed)';
    is $*call2, 1, 'level two subset checked (should succeed)';
}

#?niecza skip 'Object reference not set to an instance of an object'
{
    role R { };
    subset S of R;
    # RT #75718
    nok 1 ~~ S, 'subsets of roles (1)';
     ok R ~~ S, 'subsets of roles (2)';

    ok (R ~~ S) ~~ Bool, 'smart-matching a subset returns a Bool (1)';
    ok (S ~~ R) ~~ Bool, 'smart-matching a subset returns a Bool (2)';
}


# RT #89708
{
    subset Many::Parts of Str;
    ok 'a' ~~ Many::Parts, 'subset names with many parts work';
}

{
    subset Int::Positive of Int where { $_ > 0 };
    sub f(Int::Positive $a) { $a * $a };
    dies_ok { eval('f(-2)') }, 'Cannot violate Int::Positive constraint';
}

# RT #71820
#?niecza todo
{
    subset Interesting of Int where * > 10;
    class AI { has Interesting $.x };
    try { eval 'AI.new(x => 2)' };
    ok $!.Str ~~ /Interesting/, 'error message mentions subset name';

}

# RT #79160
{
    my Str subset MyStr;
    #?rakudo todo 'RT 79160'
    ok MyStr ~~ Str, 'my str subset MyStr creates basically a type alias (1)';
    ok 'foo' ~~ MyStr, 'my str subset MyStr creates basically a type alias (2)';
    #?rakudo todo 'RT 79160'
    ok 2    !~~ MyStr, 'Ints are not in there';
}

# RT 72948
#?niecza skip "Exceptions not supported"
{
    try { eval 'sub foo($x where { $x == $y }, $y) { }' };
    isa_ok $!, X::Undeclared, 'subset in signature cannot use non-predeclared variable';
}

done;

# vim: ft=perl6
������������������������������rakudo-2013.12/t/spec/S12-traits/basic.t������������������������������������������������������������0000664�0001750�0001750�00000002243�12224265625�017126� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 9;

=begin pod

Basic traits tests, see L<S14/Traits>.

=end pod

# L<S14/Traits>
# Basic definition
my $was_in_any_sub   = 0;
my $was_in_class_sub = 0;
role cool {
  has $.is_cool = 42;

  multi sub trait_auxiliary:<is>(cool $trait, Any $container:) {   #OK not used
    $was_in_any_sub++;
    $container does cool;
  }

  multi sub trait_auxiliary:<is>(cool $trait, Class $container:) {   #OK not used
    $was_in_class_sub++;
    $container does cool;
  }
}
ok(::cool.HOW, "role definition worked");

eval_lives_ok 'my $a is cool; 1', 'mixing in our role into a scalar via "is" worked';
#?pugs 2 todo 'traits'
is $was_in_any_sub, 1, 'trait_auxiliary:is was called on container';
is eval('my $a is cool; $a.is_cool'), 42,  'our var "inherited" an attribute';

my $b;
class B is cool {}
ok(::B.HOW, 'mixing in our role into a class via "is" worked');
#?pugs todo
is $was_in_class_sub, 1, 'trait_auxiliary:is was called on class';
$b = B.new;
ok($b, 'creating an instance worked');
is($b.is_cool,    42,  'our class "inherited" an attribute');

eval_dies_ok(' %!P = 1; 1',
        'calling a trait outside of a class should be a syntax error');

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S12-traits/parameterized.t����������������������������������������������������0000664�0001750�0001750�00000001240�12224265625�020675� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 8;

=begin pod

Parameterized traits tests, see L<S14/Traits>.

=end pod

# L<S14/Traits>
# Basic definition
role cool {
    has $.cool;

    multi sub trait_auxiliary:<is>(cool $trait, Any $container; $val) {   #OK not used
        $.cool = $val;
        $container does cool($val);
    }
}

my $a = 42;
is           $a, 42, "basic sanity (1)";
lives_ok {$a does cool(23)},   "imperative does worked (1)";
is $a.cool,      23,   "attribute was set correctly (1)";

my $b = 23;
is           $b, 23, "basic sanity (2)";
ok $b does cool("hi"), "imperative does worked (2)";
is $b.cool,      "hi", "attribute was set correctly (2)";

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-overloading/fallbacks-deep.t����������������������������������������������0000664�0001750�0001750�00000000743�12224265625�021711� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 2;

# L<S13/"Fallbacks"/"is also generated for you (unless you define it yourself).">

class Base {has $.value is rw;}
class Exponent {has $.value is rw;}

multi sub infix:<+> (Base $b, Exponent $e) is deep {$b.value ** $e.value}

my $base = Base.new();
my $exp  = Exponent.new();
$base.value = 2;
$exp.value  = 5;

is($base + $exp, 32, 'defining infix:<+> works');

$base += $exp;
is($base, 32, 'is deep generates infix:<+=> on infix:<+>');

# vim: ft=perl6
�����������������������������rakudo-2013.12/t/spec/S13-overloading/metaoperators.t�����������������������������������������������0000664�0001750�0001750�00000002050�12224265625�021732� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 9;

#L<S06/Operator overloading>

# Define operator, check it works.
sub infix:<wtf>($a, $b) { $a ~ "WTF" ~ $b };
is 'OMG' wtf 'BBQ', 'OMGWTFBBQ', 'basic sanity';

# Assignment meta-op.
my $a = 'OMG';
$a wtf= 'BBQ';
is $a, 'OMGWTFBBQ', 'assignment meta-op';

# Reduce meta-op.
is ([wtf] <OMG BBQ PONIES>), 'OMGWTFBBQWTFPONIES', 'reduce meta-op generated';

# Reverse meta-op.
is 'BBQ' Rwtf 'OMG', 'OMGWTFBBQ', 'reverse meta-op generated';

# Cross meta-op.
is ~('OMG','BBQ' Xwtf 'OMG','BBQ'), 'OMGWTFOMG OMGWTFBBQ BBQWTFOMG BBQWTFBBQ',
    'cross meta-op generated';

# Hyper meta-op (todo: unicode variants, check variants apply correct constraints)
is ~(('OMG','BBQ') >>wtf<< ('BBQ','OMG')), 'OMGWTFBBQ BBQWTFOMG', '>>...<< hyper generated';
is ~(('OMG','BBQ') <<wtf<< ('BBQ','OMG')), 'OMGWTFBBQ BBQWTFOMG', '<<...<< hyper generated';
is ~(('OMG','BBQ') >>wtf>> ('BBQ','OMG')), 'OMGWTFBBQ BBQWTFOMG', '>>...>> hyper generated';
is ~(('OMG','BBQ') <<wtf>> ('BBQ','OMG')), 'OMGWTFBBQ BBQWTFOMG', '<<...>> hyper generated';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-overloading/multiple-signatures.t�����������������������������������������0000664�0001750�0001750�00000001667�12224265625�023077� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 5;

# L<S13/"Syntax"/"If you declared a state variable within the body, for instance, there would only be one of them.">

# test the general multiple signatures functionality
class Base {has $.value is rw;}
class Exponent   {has $.value is rw;}

multi sub infix:<+> (Base $b, Exponent $e) |
                    (Exponent $e, Base $b) {$b.value ** $e.value}

my $base = Base.new();
my $exp  = Exponent.new();
$base.value = 2;
$exp.value  = 5;

is($base + $exp, 32, 'First order works');
is($exp + $base, 32, 'Second order works');

# specifically make sure that there is only one state variable
# this tells us that there is only one multi sub body
multi sub postfix:<!> (Base $x) |   #OK not used
                      (Exponent $x) {state $counter = 0; return ++$counter;}   #OK not used

is($base!, 1, 'shared routine test 1');
is($exp!,  2, 'shared routine test 2');
is($base!, 3, 'shared routine test 3');

# vim: ft=perl6
�������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-overloading/operators.t���������������������������������������������������0000664�0001750�0001750�00000001735�12224265625�021074� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 4;

#L<S06/Operator overloading>

{
    sub postfix:<§> ($x) {
        $x * 2;
    };
    is 3§, 6, 'Can define postfix operator';
}

{
    sub postfix:<!>($arg) {
        if ($arg == 0) { 1;}
        else { ($arg-1)! * $arg;}
    };
    is 5!, 120, 'Can define recursive postfix operator';
}

#?pugs todo
{
    class A does Associative {
        method postcircumfix:<{ }>(*@ix) {   # METHOD TO SUB CASUALTY
            return @ix
        }
    };

    #?rakudo skip 'cannot easily override {} at the moment'
    is A.new<foo bar>, <foo bar>, 'defining postcircumfix:<{ }> works';
}

# overloaded invoke
# RT #76330
# (even though the ticket title claims it, the actual problem was not related
# to monkey typing/augmenting at all)

#?pugs skip 'Cannot cast from VObject'
{
    class B {
        has $.x;
        method postcircumfix:<( )>($y) {
            $.x ~ $y;
        }
    }
    is B.new(x => 'a').('b'), 'ab', 'can overload invoke';
}

# vim: ft=perl6
�����������������������������������rakudo-2013.12/t/spec/S13-overloading/typecasting-long.t��������������������������������������������0000664�0001750�0001750�00000004617�12224265625�022347� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 16;

# L<S13/"Type Casting"/"method postcircumfix:<{ }> (**@slice) {...}">
# basic tests to see if the methods overload correctly.

#?niecza skip 'No value for parameter $capture in TypeCastSub.postcircumfix:<( )>'
{
    my multi testsub ($a,$b) {   #OK not used
        return 1;
    }
    my multi testsub ($a) {   #OK not used
        return 2;
    }
    my multi testsub () {
        return 3;
    }
    class TypeCastSub {
        method postcircumfix:<( )> ($capture) {return 'pretending to be a sub ' ~ testsub(|$capture) }
    }

    my $thing = TypeCastSub.new;
    is($thing(), 'pretending to be a sub 3', 'overloaded () call works');
    is($thing.(), 'pretending to be a sub 3', 'overloaded .() call works');
    is($thing.(1), 'pretending to be a sub 2', 'overloaded .() call works');
    is($thing.(1,2), 'pretending to be a sub 1', 'overloaded .() call works');
}

#?rakudo skip 'cannot easily override [] at the moment'
{
    class TypeCastArray {
        method postcircumfix:<[ ]> (*@slice) {  # METHOD TO SUB CASUALTY
            return 'pretending to be an array';
        }   #OK not used
    }

    my $thing = TypeCastArray.new;
    is($thing[1], 'pretending to be an array', 'overloaded [] call works');
    is($thing[2,3], 'pretending to be an array', 'overloaded [] call works (slice)');
    is($thing.[4], 'pretending to be an array', 'overloaded .[] call works');
    is($thing.[5,6], 'pretending to be an array', 'overloaded .[] call works (slice)');
}

#?rakudo skip 'cannot easily override {} at the moment'
{
    class TypeCastHash {
        method postcircumfix:<{ }> (*@slice) {   # METHOD TO SUB CASUALTY
            return 'pretending to be a hash';
        }   #OK not used
    }

    my $thing = TypeCastHash.new;
    is($thing{'a'}, 'pretending to be a hash', 'overloaded {} call works');
    is($thing{'b','c'}, 'pretending to be a hash', 'overloaded {} call works (slice)');
    is($thing.{'d'}, 'pretending to be a hash', 'overloaded .{} call works');
    is($thing.{'e','f'}, 'pretending to be a hash', 'overloaded .{} call works (slice)');
    is($thing<a>, 'pretending to be a hash', 'overloaded <> call works');
    is($thing<b c>, 'pretending to be a hash', 'overloaded <> call works (slice)');
    is($thing.<d>, 'pretending to be a hash', 'overloaded .<> call works');
    is($thing.<e f>, 'pretending to be a hash', 'overloaded .<> call works (slice)');
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-overloading/typecasting-mixed.t�������������������������������������������0000664�0001750�0001750�00000004554�12224265625�022516� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 14;

# L<S13/"Type Casting"/"method %.{ **@slice } {...}">
# basic tests to see if the methods overload correctly.
{
    class TypeCastMixed {
        method &.( |capture ) {
            return 'pretending to be a sub';
        }   #OK not used
        method postcircumfix:<[ ]> (**@slice) {   # METHOD TO SUB CASUALTY
            return 'pretending to be an array';
        }   #OK not used
        method %.{ **@slice } {                   # METHOD TO SUB CASUALTY
            return 'pretending to be a hash';
        }   #OK not used
    }

    my $thing = TypeCastMixed.new;
    is($thing(), 'pretending to be a sub', 'overloaded () call works');
    is($thing.(), 'pretending to be a sub', 'overloaded .() call works');
    #?rakudo 2 skip 'cannot easily override [] at the moment'
    is($thing[1], 'pretending to be an array', 'overloaded [] call works');
    is($thing[2,3], 'pretending to be an array', 'overloaded [] call works (slice)');
    #?rakudo todo 'cannot easily override [] at the moment'
    is($thing.[4], 'pretending to be an array', 'overloaded .[] call works');
    #?rakudo skip 'cannot easily override [] at the moment'
    is($thing.[5,6], 'pretending to be an array', 'overloaded .[] call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing{'a'}, 'pretending to be a hash', 'overloaded {} call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing{'b','c'}, 'pretending to be a hash', 'overloaded {} call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing.{'d'}, 'pretending to be a hash', 'overloaded .{} call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing.{'e','f'}, 'pretending to be a hash', 'overloaded .{} call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing<a>, 'pretending to be a hash', 'overloaded <> call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing<b c>, 'pretending to be a hash', 'overloaded <> call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing.<d>, 'pretending to be a hash', 'overloaded .<> call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing.<e f>, 'pretending to be a hash', 'overloaded .<> call works (slice)');
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-overloading/typecasting-short.t�������������������������������������������0000664�0001750�0001750�00000004644�12224265625�022547� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 14;

# L<S13/"Type Casting"/"method %.{ **@slice } {...}">
# basic tests to see if the methods overload correctly.

{
    class TypeCastSub {
        method &.( |capture ) {return 'pretending to be a sub'}   #OK not used
    }

    my $thing = TypeCastSub.new;
    is($thing(), 'pretending to be a sub', 'overloaded () call works');
    is($thing.(), 'pretending to be a sub', 'overloaded .() call works');
}

{
    class TypeCastArray {
        method @.[ **@slice ] {                  # METHOD TO SUB CASUALTY
            return 'pretending to be an array';
        }   #OK not used
    }

    my $thing = TypeCastArray.new;
    #?rakudo todo 'cannot easily override [] at the moment'
    is($thing[1], 'pretending to be an array', 'overloaded [] call works');
    #?rakudo 3 skip 'cannot easily override [] at the moment'
    is($thing[2,3], 'pretending to be an array', 'overloaded [] call works (slice)');
    is($thing.[4], 'pretending to be an array', 'overloaded .[] call works');
    is($thing.[5,6], 'pretending to be an array', 'overloaded .[] call works (slice)');
}

{
    class TypeCastHash {
        method %.{ **@slice } {                  # METHOD TO SUB CASUALTY
            return 'pretending to be a hash';
        }   #OK not used
    }

    my $thing = TypeCastHash.new;
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing{'a'}, 'pretending to be a hash', 'overloaded {} call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing{'b','c'}, 'pretending to be a hash', 'overloaded {} call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing.{'d'}, 'pretending to be a hash', 'overloaded .{} call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing.{'e','f'}, 'pretending to be a hash', 'overloaded .{} call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing<a>, 'pretending to be a hash', 'overloaded <> call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing<b c>, 'pretending to be a hash', 'overloaded <> call works (slice)');
    #?rakudo todo 'cannot easily override {} at the moment'
    is($thing.<d>, 'pretending to be a hash', 'overloaded .<> call works');
    #?rakudo skip 'cannot easily override {} at the moment'
    is($thing.<e f>, 'pretending to be a hash', 'overloaded .<> call works (slice)');
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-syntax/aliasing.t���������������������������������������������������������0000664�0001750�0001750�00000001006�12224265625�017651� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 3;

# L<S13/Syntax/This can easily be handled with Perl 6's aliasing>

class Foo {
  method bar()     { 42 }
  method bar_ref() { &bar }
}

{
  my $foo = Foo.new;
  lives_ok { $foo.bar_ref }, "returning a method reference works";
}

class Baz {
    method bar() { 42 }
    our &baz ::= &bar;
}

{
  my $ret;
  lives_ok {
    my $baz = Baz.new;
    $ret    = $baz.baz();
  }, "calling an aliased method worked";
  is $ret, 42, "the aliased method returned the right thing";
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S13-type-casting/methods.t����������������������������������������������������0000664�0001750�0001750�00000003230�12224265625�020607� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 13;

# L<S13/Type Casting/"whose name is a declared type, it is taken as a coercion
# to that type">

class CoercionTest {
    method Stringy  { "foo" };
    method Numeric  { 1.2   };
}

my $o = CoercionTest.new();

#?niecza todo 'Stringy'
is ~$o, 'foo', 'method Stringy takes care of correct stringification';
ok +$o == 1.2, 'method Numeric takes care of correct numification';

# RT #69378
{
    class RT69378 {
        has $.x = 'working';
        method Str() { $.x }
    }
    is RT69378.new.Str, 'working', 'call to .Str works';

    class RT69378str is Cool {
        has $.a = 'RT #69378';
        method Str() { $.a }
    }
    is RT69378str.new.a, 'RT #69378', 'call to RT69378str.new properly initializes $.a';
    is RT69378str.new.Str, 'RT #69378', 'call to .Str works on "class is Str"';
    #?niecza 2 skip 'coercion syntax'
    is Str(RT69378str.new), 'RT #69378', 'Str(...) coercion syntax calls our .Str too';
    # RT #72834
    ok Int() == 0, 'Int()';
}

is 1.Str.Str, "1", ".Str can be called on Str";
is "hello".Str, "hello", ".Str can be called on Str";

#?niecza skip "this test makes not much sense: noauto"
{
    # Not sure how to set the derived Str portion to a value, but that would be an
    # additional useful test here.
    class DerivedFromStr is Str {
        has $.a;
    }
    isa_ok DerivedFromStr.new, DerivedFromStr, 'DerivedFromStr.new isa DerivedFromStr';
    isa_ok DerivedFromStr.new, Str, 'DerivedFromStr.new isa DerivedFromStr';
    isa_ok DerivedFromStr.new.Str, DerivedFromStr, 'DerivedFromStr.new.Str isa DerivedFromStr';
    isa_ok DerivedFromStr.new.Str, Str, 'DerivedFromStr.new.Str isa Str';
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/anonymous.t���������������������������������������������������������0000664�0001750�0001750�00000002446�12224265625�017722� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 13;

#?pugs 99 todo 'anonymous roles'

# L<S14/Roles>
{
  my $a = {:x};
  is $a, {:x}, "basic sanity";
  lives_ok { $a does role { has $.cool = "yeah" }}, "anonymous role mixin";
  is $a, {:x}, "still basic sanity";
  is $a.cool, "yeah", "anonymous role gave us an attribute";
}

# The same, but we story the anonymous role in a variable
{
  my $a = {:x};
  is $a, {:x}, "basic sanity";
  my $role;
  lives_ok { $role = role { has $.cool = "yeah" } }, "anonymous role definition";
  #?rakudo.jvm todo "nigh"
  lives_ok { $a does $role }, "anonymous role variable mixin";
  is $a, {:x}, "still basic sanity";
  #?rakudo.jvm todo "nigh"
  is $a.cool, "yeah", "anonymous role variable gave us an attribute";
}

# Guarantee roles are really first-class-entities:
{
    sub role_generator(Str $val) {
      return role {
        has $.cool = $val;
      }
    }

  my $a = {:x};
  is $a, {:x}, "basic sanity";
  #?niecza todo 'This is being misinterpreted as an initial value'
  lives_ok {$a does role_generator("hi")}, "role generating function mixin";
  is $a, {:x}, "still basic sanity";
  #?niecza skip 'roles are run once and only capture the protopad'
  #?rakudo skip 'anonymous roles only created once'
  is $a.cool, "hi", "role generating function gave us an attribute";
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/attributes.t��������������������������������������������������������0000664�0001750�0001750�00000002614�12224265625�020055� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 7;

# L<S14/Roles/"Roles may have attributes">

#?rakudo skip 'review test and rakudo'
{
    role R1 {
        has $!a1;
        has $.a2 is rw;
    };

    class C1 does R1 {
        method set_a1($val) {
            $!a1 = $val;
        }
        method get_a1 {
            $!a1
        }
    };

    my $x = C1.new();

    $x.set_a1('abc');
    is $x.get_a1,   'abc',      'Can set and get class-private attr from role';

    $x.a2 = 'xyz';
    is $x.a2,       'xyz',      'Public attribute gets accessor/mutator composed';
}


role R2 {
    has Int $!a;
}

#?pugs 2 todo
eval_dies_ok 'class C3 does R2 { has $!a }',      'Roles with conflicing attributes';
eval_dies_ok 'class C2 does R2 { has Int $!a }',  'Same name, same type will also conflicts';

role R3 {
    has $.x = 42;
}
class C4 does R3 { }
is C4.new.x, 42, 'initializing attributes in a role works';

role R4 { has @!foo; method bar() { @!foo } }
class C5 does R4 {
    has $.baz;
}
is C5.new().bar(), [], 'Composing an attribute into a class that already has one works';

#?pugs skip 'Cannot cast into Hash'
#?niecza skip 'Unhandled exception: Attribute %!e in C6 is defined in C6 but not R6'
{
    role R6 {
        has %!e;
        method el() { %!e<a> };
        submethod BUILD(:%!e) { };
    }
    class C6 does R6 { };
    is C6.new(e => { a => 42 }).el, 42, 'can use :%!role_attr in BUILD signature';
}

# vim: syn=perl6
��������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/basic.t�������������������������������������������������������������0000664�0001750�0001750�00000012172�12224265625�016750� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 43;

=begin description

Basic role tests from L<S14/Roles>

=end description

# L<S14/Roles>
# Basic definition
role Foo {}
class Bar does Foo {};

# Smartmatch and .HOW.does and .^does
my $bar = Bar.new();
ok ($bar ~~ Bar),               '... smartmatch our $bar to the Bar class';
ok ($bar.HOW.does($bar, Foo)),  '.HOW.does said our $bar does Foo';
ok ($bar.^does(Foo)),           '.^does said our $bar does Foo';
ok ($bar ~~ Foo),               'smartmatch said our $bar does Foo';
nok Foo.defined,                'role type objects are undefined';

# Can also write does inside the class.
{
    role Foo2 { method x { 42 } }
    class Bar2 { also does Foo2; }
    my $bar2 = Bar2.new();
    ok ($bar2 ~~ Foo2),          'smartmatch works when role is done inside class';
    is $bar2.x, 42,              'method composed when role is done inside class';
}

# Mixing a Role into a Mu using imperative C<does>
my $baz = { };
ok defined($baz does Foo),      'mixing in our Foo role into $baz worked';
#?pugs skip 3 'feature'
ok $baz.HOW.does($baz, Foo),    '.HOW.does said our $baz now does Foo';
ok $baz.^does(Foo),             '.^does said our $baz now does Foo';
eval_dies_ok q{ $baz ~~ Baz },        'smartmatch against non-existent type dies';

# L<S14/Roles/but with a role keyword:>
# Roles may have methods
#?pugs skip "todo"
{
    role A { method say_hello(Str $to) { "Hello, $to" } }
    my Bar $a .= new();
    ok(defined($a does A), 'mixing A into $a worked');
    is $a.say_hello("Ingo"), "Hello, Ingo", 
        '$a "inherited" the .say_hello method of A';
}

# L<S14/Roles/Roles may have attributes:>
{
    role B { has $.attr is rw = 42 }
    my Bar $b .= new();
    $b does B;
    ok defined($b),        'mixing B into $b worked';
    is $b.attr, 42,        '$b "inherited" the $.attr attribute of B (1)';
    is ($b.attr = 23), 23, '$b "inherited" the $.attr attribute of B (2)';

    # L<S14/Run-time Mixins/"but creates a copy">
    # As usual, ok instead of todo_ok to avoid unexpected succeedings.
    my Bar $c .= new(),
    ok defined($c),             'creating a Foo worked';
    ok !($c ~~ B),              '$c does not B';
    ok (my $d = $c but B),      'mixing in a Role via but worked';
    ok !($c ~~ B),              '$c still does not B...';
    ok $d ~~ B,                 '...but $d does B';
}

# Using roles as type constraints.
role C { }
class DoesC does C { }
lives_ok { my C $x; },          'can use role as a type constraint on a variable';
dies_ok { my C $x = 42 },       'type-check enforced';
dies_ok { my C $x; $x = 42 },   'type-check enforced in future assignments too';
lives_ok {my C $x = DoesC.new },'type-check passes for class doing role';
lives_ok { my C $x = 42 but C },'type-check passes when role mixed in';

class HasC {
    has C $.x is rw;
}
lives_ok { HasC.new },          'attributes typed as roles initialized OK';
lives_ok { HasC.new.x = DoesC.new },
                                'typed attribute accepts things it should';
dies_ok { HasC.new.x = Mu },    'typed attribute rejects things it should';
dies_ok { HasC.new.x = 42 },    'typed attribute rejects things it should';

eval_dies_ok '0 but RT66178', '"but" with non-existent role dies';

{
    dies_ok { eval 'class Animal does NonExistentRole { }; 1' },
	    'a class dies when it does a non-existent role';

    try { eval 'class AnotherAnimal does NonExistentRole { }; 1' };
    my $err = "$!";
    #?rakudo todo 'nom regression'
    ok $err ~~ /NonExistentRole/,
       '... and the error message mentions the role';
}

# RT #67278
{
    class AClass { };
    dies_ok { eval 'class BClass does AClass { }; 1' },
	    'class SomeClass does AnotherClass  dies';
    my $x = try eval 'class CClass does AClass { }; 1';
    ok "$!" ~~ /AClass/, 'Error message mentions the offending non-role';
}

# RT #72840
{
    try eval 'class Boo does Boo { };';
    #?rakudo todo "can see it in the position, but even STD message doesn't include it"
    ok "$!" ~~ /Boo/, 'class does itself produces sensible error message';
}

# RT #69170
{
    role StrTest {
        method s { self.gist }
    };
    ok StrTest.s ~~ /StrTest/,
        'default role gistification contains role name';
}

# RT #72848
lives_ok {0 but True}, '0 but True has applicable candidate';

# RT #67768
#?rakudo skip 'RT 67768'
{
    eval_lives_ok 'role List { method foo { 67768 } }',
        'can declare a role with a name already assigned to a class';
    eval_lives_ok 'class C67768 does OUR::List { }',
        'can use a role with a name already assigned to a class';
    is ::OUR::C67768.new.foo, 67768,
        'can call method from a role with a name already assigned to a class';
}

# RT #114380
eval_lives_ok q[my role R { our $.r }; my class C does R {}],
    'Can have "our $.r" in a role (RT 114380)';

# RT #116226
#?niecza skip "Unable to resolve method x in type AccessesAttr"
{
    my role AccessesAttr {
        method meth() {
            self.x;
        }
    }
    my class WithAttr does AccessesAttr {
        has $.x = 42;
        method meth() {
            self.AccessesAttr::meth();
        }
    }
    is WithAttr.new.meth, 42, '$obj.Role::method() passes correct invocant';
}
done;

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/bool.t��������������������������������������������������������������0000664�0001750�0001750�00000000517�12224265625�016622� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 3;

# boolification of roles

sub b($x) { $x ?? 'aye' !! 'nay' }

my Stringy $s;
is b($s), 'nay', 'boolification of role type object';

my Stringy $t = '';
is b($t), 'nay', 'boolification of role-typed container (false)';

my Stringy $u = 'moin';
is b($u), 'aye', 'boolification of role-typed container (true)';
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/composition.t�������������������������������������������������������0000664�0001750�0001750�00000006277�12224265625�020243� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 26;

# L<S14/Roles/"Roles may be composed into a class at compile time">

role rA {
    method mA1 {
        'mA1';
    }
    method mA2 {
        'mA2';
    }
};

role rB {
    method mB1 {
        'mB1';
    }
    method mB2 {
        'mB2';
    }
};

class C1 does rA {
    method mC1 {
        'mC1';
    }
};

my $x = C1.new();

is $x.mC1,      'mC1',      'Can call method of class with mixed in role';
is $x.mA1,      'mA1',      'Call first method from role';
is $x.mA2,      'mA2',      'Call second method from role';

class C2 does rA does rB {
    method mC2 {
        'mC2';
    }
}

my $y = C2.new();

is $y.mC2,      'mC2',      'Can call method of class with two roles mixed in';
is $y.mA1,      'mA1',      'Can call mixed in method (two roles) 1';
is $y.mA2,      'mA2',      'Can call mixed in method (two roles) 2';
is $y.mB1,      'mB1',      'Can call mixed in method (two roles) 3';
is $y.mB2,      'mB2',      'Can call mixed in method (two roles) 4';

ok C2 ~~ rA, 'class matches first role';
ok C2 ~~ rB, 'class matches second role';
ok rA !~~ C2, 'first role does not match class';
ok rB !~~ C2, 'second role does not match class';

role RT64002 does rA does rB {}
ok RT64002 ~~ rA, 'role matches first role it does';
ok RT64002 ~~ rB, 'role matches second role it does';
ok rA !~~ RT64002, 'role not matched by first role it does';
ok rB !~~ RT64002, 'role not matched by second role it does';

{
    class D1 does rA {
        method mA1 {
            'D1.mA1';
        }
    }

    my $z = D1.new();

    is $z.mA1,      'D1.mA1',   'Can override method in a role with method in a class';
}

# diamond composition
#?rakudo skip 'diamond composition'
{
    role DA { 
        method foo { "OH HAI" };
    }
    role DB does DA { }
    role DC does DA { }
    class DD does DB does DC { };
    is DD.new.foo, 'OH HAI', 'diamond role composition';
    class DE is DB is DC { };
    is DE.new.foo, 'OH HAI', 'same with punning and inheritance';
}

# RT #69919
{
    role RT69919 {
        my $lex = 'Luthor';
        method rt69919 { return $lex }
    }
    class IL does RT69919 {}

    #?pugs todo
    is IL.new.rt69919, 'Luthor', 'access lexical declared in role from method called via class that does the role';
}


# inheritance through role composition - specced in A12
# RT 69254
{
    class irA {};
    role  irB is   irA {};
    class irC does irB {};
    ok irC ~~ irB, 'role composition worked';
    ok irC ~~ irA, 'role composition transported inheritance';

}

# RT #72856
{
    role RT72856A { method foo {} };
    role RT72856B { method foo {} };
    try { eval 'class RT72856C does RT72856A does RT72856B {}' };
    #?pugs todo
    ok $! ~~ /foo/,
        'method of the same name from two different roles collide in a class composition';
    #?pugs todo
    ok $! ~~ /RT72856A/, 'colliding role mentioned in error (1)';
    #?pugs todo
    ok $! ~~ /RT72856B/, 'colliding role mentioned in error (2)';
}

# RT #74078
{
    role UsesSettingSub {
        method doit() {
            uc 'a';
        }
    }
    class ClassUsesSettingSub does UsesSettingSub { };
    is ClassUsesSettingSub.new.doit, 'A',
        'can use a sub from the setting in a method composed from a role';
}

# vim: syn=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/conflicts.t���������������������������������������������������������0000664�0001750�0001750�00000002761�12224265625�017656� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 11;

=begin pod

Conflict resolution role tests, see L<S14/Roles>

=end pod

# L<S14/Roles>

my ($was_in_sentry_shake, $was_in_pet_shake, $was_in_general_shake) = 0, 0, 0;
role Sentry { method shake() { $was_in_sentry_shake++; "A" } }
role Pet    { method shake() { $was_in_pet_shake++;    "B" } }

class General does Sentry does Pet {

    method shake(Str $what) {
        $was_in_general_shake++;
        given $what {
            when "sentry" { return self.Sentry::shake() }
            when "pet"    { return self.Pet::shake()    }
        }
    }
}
lives_ok {Pet.new}, "role and class definition worked";

my $a;
ok(($a = General.new()),      "basic class instantiation works");
is $a.shake("sentry"), "A", "conflict resolution works (1-1)";
is      $was_in_general_shake,  1, "conflict resolution works (1-2)";
is      $was_in_sentry_shake,   1, "conflict resolution works (1-3)";
# As usual, is instead of todo_is to avoid unexpected suceedings.
is      $was_in_pet_shake,      0, "conflict resolution works (1-4)";
is $a.shake("pet"),    "B", "conflict resolution works (2-1)";
is      $was_in_general_shake,  2, "conflict resolution works (2-2)";
is      $was_in_sentry_shake,   1, "conflict resolution works (2-3)";
is      $was_in_pet_shake,      1, "conflict resolution works (2-4)";

# RT #111664
eval_dies_ok q[
    role R1 { method !foo() { 1 }}
    role R2 { method !foo() { 2 } }
    class A does R1 does R2 { }
    ], 'private roles can cause conflicts too';

# vim: ft=perl6
���������������rakudo-2013.12/t/spec/S14-roles/crony.t�������������������������������������������������������������0000664�0001750�0001750�00000001633�12224265625�017021� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 4;

# A role composed from another role.
# String and integer allocated to attributes in roles.
# Test two attributes in each role because roles with single attributes are special
# Author: Richard Hainsworth, Oct 2, 2006

# L<S14/Roles/but may be composed of other roles>

role InnerRole {
  has $.inner_role_var_1 is rw;
  has $.inner_role_var_2 is rw;
};

role OuterRole does InnerRole {
  has $.outer_role_var_1 is rw;
  has $.outer_role_var_2 is rw;
};

my $w = OuterRole.new;

$w.outer_role_var_1 = 2;
$w.outer_role_var_2 = 'red';
is $w.outer_role_var_1, 2 , "integer attribute is set in outer role" ;
is $w.outer_role_var_2, 'red', "string attribute is set in outer role" ;

$w.inner_role_var_1 = 3;
$w.inner_role_var_2 = 'dog';
is $w.inner_role_var_1, 3 , "integer attribute is set in inner role" ; 
is $w.inner_role_var_2,'dog' , "string attribute is set in inner role" ;

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/instantiation.t�����������������������������������������������������0000664�0001750�0001750�00000005156�12224265625�020557� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<"http://use.perl.org/~autrijus/journal/25351">
# Roles are also classes! They can be instantiated just fine if they are
# concrete enough. Basically they mean composable classes or mixin-able
# classes. Hence, RoleName.new() instantiates an object that will probably fail
# on all stubs.

plan 19;

role SampleRole {
  method sample_method () { 42 }
}

{
  my $obj = SampleRole.new;
  ok $obj.defined, "roles can be instantiated";

  ok $obj ~~ SampleRole, "our instantiated role object smartmatches against our role";

  is $obj.sample_method, 42, "calling a method on our instantiated role object worked";

  my $obj2 = SampleRole.new;
  ok $obj.WHAT === $obj2.WHAT, "Punned role classes have the same .WHAT";

  is $obj.WHAT.gist, '(SampleRole)', '.WHAT as a string gives the name of the role';
}

role WithAttr {
    has $.x;
    has $.y;
}
{
    my $obj = WithAttr.new(x => 'abc', y => 123);
    ok $obj ~~ WithAttr, "our instantiated role object smartmatches against our role";
    is $obj.x, 'abc', "role attributes initialized in constructor";
    is $obj.y, 123, "role attributes initialized in constructor";
}

{
    role ParaRole[$x] {
        method get_x { $x }
    }

    my $obj = ParaRole[42].new;
    my $obj2 = ParaRole[100].new;

    ok $obj ~~ ParaRole, "instantiated object smartmatches against parameterized role";
    ok $obj ~~ ParaRole[42], "instantiated object smartmatches against parameterized role (with param)";
    ok $obj2 ~~ ParaRole, "instantiated object smartmatches against parameterized role";
    ok $obj2 ~~ ParaRole[100], "instantiated object smartmatches against parameterized role (with param)";

    is $obj.get_x, 42, "instantiated object has method with correct associated role parameter";
    is $obj2.get_x, 100, "instantiated object has method with correct associated role parameter";
}

{
    role ParaRole2Args[$x, $y] {
        method x { $x + $y }
    }

    is ParaRole2Args[4, 5].new.x, 9, 'instantiating a parametric role with two arguments works';
}

# Can also pun a role and inherit from the punned class.
{
    class TestA is SampleRole { }
    is(TestA.new.sample_method, 42, "can call method from punned class of inherited role");
    
    class TestB is WithAttr { }
    my $obj = TestB.new(x => 1, y => 2);
    is($obj.x, 1, "can access attribute from punned class of inherited role");
    is($obj.y, 2, "can access attribute from punned class of inherited role");
}

# It isn't just .new that works - any method can be punned.
{
    role NotNewTest {
        method x { 69 }
    }
    is(NotNewTest.x, 69, "it's not just .new that causes a pun, but any method");
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/lexical.t�����������������������������������������������������������0000664�0001750�0001750�00000002476�12224265625�017316� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 9;

=begin pod

Tests for lexical roles delcared with 'my role'

=end pod

# L<S12/Classes>

# A few basic tests.
eval_lives_ok 'my role R1 {}', 'my role parses OK';
eval_lives_ok '{ my role R2 {} }; { my role R2 {} }',
              'declare roles with the same name in two scopes.';
#?pugs todo
eval_dies_ok  '{ my class R3 {}; R3; }; R3',
              'scope is correctly restricted';

{
    my role Model {
        method catwalk() { 'ooh pretty!' }
    }

    is Model.gist, '(Model)',            'lexical role type object stringifies OK';
    is Model.catwalk, 'ooh pretty!', 'can pun lexical role';

    my class SuperModel does Model {
    }
    ok SuperModel ~~ Model,        'lexical role can be composed and smart-matches';
    my $sm = SuperModel.new();
    ok $sm ~~ Model,               'instance smart-matches against lexical role too';
    is $sm.catwalk, 'ooh pretty!', 'can call composed method';
}

{
    # This one was a former Rakudo bug.
    my role Drinking { method go-to-bar() { "glug" } }
    my role Gymnastics { method go-to-bar() { "ouch" } }
    my class DrunkGymnast does Gymnastics does Drinking {
        method go-to-bar() { self.Gymnastics::go-to-bar() }
    }
    is DrunkGymnast.new.go-to-bar, "ouch", 'the $obj.RoleName::meth() syntax works on lexical roles';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/mixin.t�������������������������������������������������������������0000664�0001750�0001750�00000010267�12224265625�017016� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 32;

# L<S14/Run-time Mixins/>

role R1 { method test { 42 } }
class C1 { }

my $x = C1.new();
$x does R1;
is $x.test,     42,         'method from a role can be mixed in';
is $x.?test,    42,         '.? form of call works on a mixed-in role';
#?niecza skip 'NYI dottyop form .+'
is $x.+test,    42,         '.+ form of call works on a mixed-in role';
#?niecza skip 'NYI dottyop form .*'
is $x.*test,    42,         '.* form of call works on a mixed-in role';


role R2 { method test { 42 } }
class C2 { has $.x }
my $y = C2.new(x => 100);
is $y.x,        100,        'initialization sanity check';
$y does R2;
is $y.test,     42,         'method from role was mixed in';
is $y.x,        100,        'mixing in did not destroy old value';


role R3 { has $.answer is rw }
class C3 { has $.x }
$y = C3.new(x => 100);
$y does R3;
$y.answer = 42;
is $y.x,        100,        'mixing in with attributes did not destroy existing ones';
is $y.answer,   42,         'mixed in new attributes';


$y = C3.new(x => 100);
$y does (R2, R3);
$y.answer = 13;
is $y.x,        100,        'multi-role mixin preserved existing values';
is $y.answer,   13,         'attribute from multi-role mixing OK';
is $y.test,     42,         'method from other role was OK too';


{
    role Answer { has $.answer is rw }
    my $x = 0 but Answer(42);
    is $x.answer,   42,         'role mix-in with initialization value worked';
    is $x,          0,          'mixing into Int still makes it function as an Int';
}


{
    my $x = C1.new();
    role A { has $.a is rw }
    role B { has $.b is rw }
    $x does A(1);
    $x does B(2);
    is $x.a,        1,          'mixining in two roles one after the other';
    is $x.b,        2,          'mixining in two roles one after the other';
}


#?rakudo skip 'mixin at the point of declaration is compile time'
#?niecza skip 'Trait does not available on variables'
{
    my @array does R1;
    is @array.test, 42,         'mixing in a role at the point of declaration works';

    my $x;
    BEGIN { $x = @array.test }
    is $x, 42,              'mixing in at point of declaration at compile time';
}

# L<S14/Run-time Mixins/"but only if the role supplies exactly one attribute">

{
    role R4a {
        # no attribute here
    }
    role R4b {
        has $.x is rw;
    }
    role R4c {
        has $.x;
        has $.y;
    }

    dies_ok { my $x = {}; $x does R4a(3) },
            '"does role(param)" does not work without attribute';
    lives_ok { my $x = {}; $x does R4b(3) },
            '"does role(param)" does work with one attribute';
    dies_ok { my $x = {}; $x does R4c(3) },
            '"does role(param)" does not work with two attributes';
    is ([] does R4b("foo")).x, 'foo',
       'can mix R4b into an Array, and access the attribute';
}

# RT #69654
#?niecza skip 'Unable to resolve method methods in class ClassHOW'
{
    role ProvidesFoo { method foo { } }
    class NoFoo { };
    is (NoFoo.new does ProvidesFoo).^methods(:local)>>.name, 'foo',
        'mixin with "does" lists method during introspection';
}

# RT #99986
{
    lives_ok { 3/2 but role { } }, 'can mix into a Rat';
}

# RT #77184
#?niecza skip 'Twigil ! is only valid on attribute definitions'
#?rakudo skip 'Twigil ! is only valid on attribute definitions'
{
    lives_ok { role A { my $!foo; }; role B { my $!foo; }; class C does A does B {} }, 'RT #77184'
}

# RT #100782
{
    my $a = 0 but True;
    is +$a, 0, 'RT #100782 1/2';
    is ?$a, Bool::True, 'RT #100782 2/2';
}

# RT #79866
{
    my $x = 42 but role { method postcircumfix:<( )>($arg) { self * $arg[0] } };
    is $x(13), 546, 'can mix a &.() method into an Int';
}

# RT #79868
is (class { } but role { method answer() { 42 } }).answer, 42,
    'can mix a role into a type object';

# RT #101022
lives_ok {(True but role {}).gist}, 'can mix into True';

# RT #73990
#?niecza skip "Can only provide exactly one initial value to a mixin"
{
    my $tracker = '';
    for 1..3 {
        $tracker ~= 'before';
        1 but last;
        $tracker ~= 'after';
    }
    is $tracker, 'before', '"1 but last" does the same as "last"';

    sub f() { role { method answer { 42 } } };
    is (1 but f).answer, 42, '<literal> but <zero-arg call> works';

}

# vim: syn=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/namespaced.t��������������������������������������������������������0000664�0001750�0001750�00000000743�12224265625�017770� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 3;

=begin pod

Roles with names containing double colons and doing of them.

=end pod

role A::B {
    method foo { "Foo" }
};

#?rakudo todo 'nom regression'
#?pugs todo
is(A::B.WHAT.gist, '(B)', 'A::B.WHAT stringifies to short name B');

class X does A::B {
}
class X::Y does A::B {
}

is(X.new.foo,    'Foo', 'Composing namespaced role to non-namespaced class');
is(X::Y.new.foo, 'Foo', 'Composing namespaced role to namespaced class');

# vim: ft=perl6
�����������������������������rakudo-2013.12/t/spec/S14-roles/parameterized-basic.t�����������������������������������������������0000664�0001750�0001750�00000012130�12224265625�021574� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 32;

=begin pod

Basic parameterized role tests, see L<S14/Roles>

=end pod

#?pugs emit skip_rest('parameterized roles'); exit;
#?pugs emit =begin SKIP

# L<S14/Run-time Mixins/may be parameterized>

# Some basic arity-based selection tests.
role AritySelection {
    method x { 1 }
}
role AritySelection[$x] {
    method x { 2 }
}
role AritySelection[$x, $y] {
    method x { 3 }
}
class AS_1 does AritySelection { }
class AS_2 does AritySelection[1] { }
class AS_3 does AritySelection[1, 2] { }
is(AS_1.new.x, 1, 'arity-based selection of role with no parameters');
is(AS_2.new.x, 2, 'arity-based selection of role with 1 parameter');
is(AS_3.new.x, 3, 'arity-based selection of role with 2 parameters');

# Make sure Foo[] works as well as Foo.
role AritySelection2[] {
    method x { 1 }
}
role AritySelection2[$x] {
    method x { 2 }
}
class AS2_1 does AritySelection2 { }
class AS2_2 does AritySelection2[] { }
class AS2_3 does AritySelection2[1] { }
is(AS2_1.new.x, 1, 'Foo[] invoked as Foo');
is(AS2_2.new.x, 1, 'Foo[] invoked as Foo[]');
is(AS2_3.new.x, 2, 'Foo[1] (for sanity)');

# Some type based choices.
class NarrownessTestA { }
class NarrownessTestB is NarrownessTestA { }
role TypeSelection[Str $x] {
    method x { 1 }
}
role TypeSelection[NarrownessTestA $x] {
    method x { 2 }
}
role TypeSelection[NarrownessTestB $x] {
    method x { 3 }
}
role TypeSelection[::T] {
    method x { 4 }
}
class TS_1 does TypeSelection["OH HAI"] { }
class TS_2 does TypeSelection[NarrownessTestB] { }
class TS_3 does TypeSelection[NarrownessTestA] { }
class TS_4 does TypeSelection[Pair] { }
is(TS_1.new.x, 1, 'type-based selection of role');
is(TS_2.new.x, 3, 'type-based selection of role (narrowness test)');
is(TS_3.new.x, 2, 'type-based selection of role (narrowness test)');
is(TS_4.new.x, 4, 'type-based selection of role (type variable)');

# Use of parameters within methods.
role MethParams[$x] {
    method x { $x }
    method y { { "42" ~ $x } }
}
class MP_1 does MethParams[1] { }
class MP_2 does MethParams['BBQ'] { }
is(MP_2.new.x,   'BBQ',   'use of type params in methods works...');
is(MP_1.new.x,   1,       '...even over many invocations.');
is(MP_2.new.y,   '42BBQ', 'params in nested scopes in methods');
is(MP_1.new.y,   '421',   'params in nested scopes in methods');

# Use of parameters with attribute initialization.
role AttrParams[$a, $b] {
    has $.x = $a;
    has $.y = $b;
}
class AP_1 does AttrParams['a','b'] { }
class AP_2 does AttrParams[1,2] { }
is(AP_2.new.x,   1,    'use of type params in attr initialization works');
is(AP_2.new.y,   2,    'use of type params in attr initialization works');
is(AP_1.new.x,   'a',  'use of type params in attr initialization works after 2nd invocation');
is(AP_1.new.y,   'b',  'use of type params in attr initialization works after 2nd invocation');

# Use of parameters as type constraints.
{
    role TypeParams[::T] {
        method x(T $x) { return "got a " ~ T.gist() ~ " it was $x" }
    }
    class TTP_1 does TypeParams[Int] { }
    class TTP_2 does TypeParams[Str] { }
    is(TTP_1.new.x(42),       'got a (Int) it was 42',     'type variable in scope and accepts right value');
    is(TTP_2.new.x("OH HAI"), 'got a (Str) it was OH HAI', 'type variable in scope and accepts right value');
    dies_ok({ TTP_1.new.x("OH HAI") },                   'type constraint with parameterized type enforced');
    dies_ok({ TTP_2.new.x(42) },                         'type constraint with parameterized type enforced');
}

# test multi dispatch on parameterized roles
# not really basic anymore, but I don't know where else to put these tests
{
    role MD_block[Int $x where { $x % 2 == 0 }] {
        method what { 'even' };
    }
    role MD_block[Int $x where { $x % 2 == 1 }] {
        method what { 'odd' };
    }

    class CEven does MD_block[4] { };
    class COdd  does MD_block[3] { };

    is CEven.new.what, 'even',
       'multi dispatch on parameterized role works with where-blocks (1)';
    is COdd.new.what,  'odd',
       'multi dispatch on parameterized role works with where-blocks (2)';
    is CEven.what, 'even',
       'same with class methods (1)';
    is COdd.what,  'odd',
       'same with class methods (2)';
    eval_dies_ok 'class MD_not_Int does MD_block["foo"] { }',
                 "Can't compose without matching role multi";
}

{
    role MD_generics[::T $a, T $b] {
        method what { 'same type' }
    }
    role MD_generics[$a, $b] {
        method what { 'different type' }
    }
    class CSame does MD_generics[Array, Array] { }
    class CDiff does MD_generics[Int, Hash] { }

    is CSame.new.what, 'same type',
       'MD with generics at class composition time (1)';
    is CDiff.new.what, 'different type',
       'MD with generics at class composition time (2)';

    is CSame.what, 'same type',
       'MD with generics at class composition time (class method) (1)';
    is CDiff.what, 'different type',
       'MD with generics at class composition time (class method) (2)';
    eval_dies_ok 'class WrongFu does MD_generics[3] { }',
       'MD with generics at class composition times fails (wrong arity)';
}

#?pugs emit =end SKIP

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/parameterized-mixin.t�����������������������������������������������0000664�0001750�0001750�00000007763�12224265625�021657� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 28;

=begin pod

Parameterized role tests, see L<S14/Roles>

Might need some more review and love --moritz

=end pod

#?pugs emit skip_rest('parameterized roles'); exit;
#?pugs emit =begin SKIP

# L<S14/Run-time Mixins/may be parameterized>
role InitialAttribVal[$val] {
    has $.attr = $val;
}

my $a = 0;
lives_ok {$a does InitialAttribVal[42]},
  "imperative does to apply a parametrized role (1)";
is $a.attr, 42,
  "attribute was initialized correctly (1)";
ok $a.HOW.does($a, InitialAttribVal),
  ".HOW.does gives correct information (1-1)";
ok $a.^does(InitialAttribVal),
  ".^does gives correct information (1-1)";
ok $a.HOW.does($a, InitialAttribVal[42]),
  ".HOW.does gives correct information (1-2)";
ok $a.^does(InitialAttribVal[42]),
  ".^does gives correct information (1-2)";

my $b = 0;
lives_ok { $b does InitialAttribVal[23] },
  "imperative does to apply a parametrized role (2)";
is $b.attr, 23,
  "attribute was initialized correctly (2)";
ok $b.HOW.does($b, InitialAttribVal),
  ".HOW.does gives correct information (2-1)";
ok $b.^does(InitialAttribVal),
  ".^does gives correct information (2-1)";
ok $b.HOW.does($b, InitialAttribVal[23]),
  ".HOW.does gives correct information (2-2)";
ok $b.^does(InitialAttribVal[23]),
  ".^does gives correct information (2-2)";



# L<S14/Parametric Roles/main type is generic by default>
role InitialAttribType[::vartype] {
    method hi(vartype $foo) { 42 }   #OK not used
}
my $c = 0;
lives_ok { $c does InitialAttribType[Code] },
  "imperative does to apply a parametrized role (3)";
ok $c.HOW.does($c, InitialAttribType),
  ".HOW.does gives correct information (3-1)";
ok $c.^does(InitialAttribType),
  ".^does gives correct information (3-1)";
ok $c.HOW.does($c, InitialAttribType[Code]),
  ".HOW.does gives correct information (3-2)";
ok $c.^does(InitialAttribType[Code]),
  ".^does gives correct information (3-2)";
is $c.hi(sub {}), 42,
  "type information was processed correctly (1)";
dies_ok { $c.hi("not a code object") },
  "type information was processed correctly (2)";


# Parameterized role using both a parameter which will add to the "long name"
# of the role and one which doesn't.
# (Explanation: This one is easier. The two attributes $.type and $.name will
# be predefined (using the role parameterization). The $type adds to the long
# name of the role, $name does not. Such:
#   my $a does InitialAttribBoth["foo", "bar"];
#   my $b does InitialAttribBoth["foo", "grtz"];
#   $a ~~ InitialAttribBoth                ==> true
#   $b ~~ InitialAttribBoth                ==> true
#   $a ~~ InitialAttribBoth["foo"]         ==> true
#   $b ~~ InitialAttribBoth["foo"]         ==> true
#   $a ~~ InitialAttribBoth["foo", "bar"]  ==> false
#   $b ~~ InitialAttribBoth["foo", "grtz"] ==> false
# Heavy stuff, eh?)
  role InitialAttribBoth[Str $type;; Str $name] {
    has $.type = $type;
    has $.name = $name;
  }
my $d = 0;
lives_ok { $d does InitialAttribBoth["type1", "name1"] },
  "imperative does to apply a parametrized role (4)";
ok $d.HOW.does($d, InitialAttribBoth),
  ".HOW.does gives correct information (4-1)";
ok $d.^does(InitialAttribBoth),
  ".^does gives correct information (4-1)";
#?rakudo 4 todo '.does with parametric roles'
# Are these really right? Trying to supply one parameter to a role that
# needs two? Even if the second doesn't participate in the multi dispatch,
# it still exists as a role parameter that needs supplying. Maybe we do
# not create multiple role variants though...but these are almost certainly
# not correct. -- jnthn
ok $d.HOW.does($d, InitialAttribBoth["type1"]),
  ".HOW.does gives correct information (4-2)";
ok $d.^does(InitialAttribBoth["type1"]),
  ".^does gives correct information (4-2)";
ok !$d.HOW.does($d, InitialAttribBoth["type1", "name1"]),
  ".HOW.does gives correct information (4-3)";
ok !$d.^does(InitialAttribBoth["type1", "name1"]),
  ".^does gives correct information (4-3)";
is $d.type, "type1", ".type works correctly";
is $d.name, "name1", ".name works correctly";

#?pugs emit =end SKIP

# vim: ft=perl6
�������������rakudo-2013.12/t/spec/S14-roles/parameterized-type.t������������������������������������������������0000664�0001750�0001750�00000010710�12224265625�021476� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 29;

=begin pod

Tests for using parameterized roles as types, plus the of keyword.

=end pod

#?pugs emit skip_rest('parameterized roles'); exit;
#?pugs emit =begin SKIP

# L<S14/Parametric Roles>
# L<S14/Relationship Between of And Types>

role R1[::T] { method x { T } }
class C1 does R1[Int] { }
class C2 does R1[Str] { }
lives_ok { my R1 of Int $x = C1.new },      'using of as type constraint on variable works (class does role)';
dies_ok  { my R1 of Int $x = C2.new },      'using of as type constraint on variable works (class does role)';
lives_ok { my R1 of Int $x = R1[Int].new }, 'using of as type constraint on variable works (role instantiation)';
dies_ok  { my R1 of Int $x = R1[Str].new }, 'using of as type constraint on variable works (role instantiation)';

sub param_test(R1 of Int $x) { $x.x }
isa_ok param_test(C1.new),      Int,          'using of as type constraint on parameter works (class does role)';
dies_ok { param_test(C2.new) },             'using of as type constraint on parameter works (class does role)';
isa_ok param_test(R1[Int].new), Int,          'using of as type constraint on parameter works (role instantiation)';
dies_ok { param_test(R1[Str].new) },        'using of as type constraint on parameter works (role instantiation)';

role R2[::T] {
    method x { "ok" }
    method call_test { self.call_test_helper(T.new) }
    method call_test_helper(T $x) { "ok" }   #OK not used
    method call_fail { self.call_test_helper(4.5) }
}
class C3 does R2[R2[Int]] { }
class C4 does R2[R2[Str]] { }

lives_ok { my R2 of R2 of Int $x = C3.new },          'roles parameterized with themselves as type constraints';
dies_ok { my R2 of R2 of Int $x = C4.new },           'roles parameterized with themselves as type constraints';
lives_ok { my R2 of R2 of Int $x = R2[R2[Int]].new }, 'roles parameterized with themselves as type constraints';
dies_ok { my R2 of R2 of Int $x = R2[R2[Str]].new },  'roles parameterized with themselves as type constraints';

sub param_test_r(R2 of R2 of Int $x) { $x.x }
is param_test_r(C3.new),          'ok',    'roles parameterized with themselves as type constraints';
dies_ok { param_test_r(C4.new) },          'roles parameterized with themselves as type constraints';
is param_test_r(R2[R2[Int]].new), 'ok',    'roles parameterized with themselves as type constraints';
dies_ok { param_test_r(R2[R2[Str]].new) }, 'roles parameterized with themselves as type constraints';

is R2[Int].new.call_test,    'ok', 'types being used as type constraints inside roles work';
dies_ok { R2[Int].new.call_fail }, 'types being used as type constraints inside roles work';
is C3.new.call_test,         'ok', 'roles being used as type constraints inside roles work';
dies_ok { C3.new.call_fail },      'roles being used as type constraints inside roles work';
is C4.new.call_test,         'ok', 'roles being used as type constraints inside roles work';
dies_ok { C4.new.call_fail },      'roles being used as type constraints inside roles work';
is R2[C3].new.call_test,     'ok', 'classes being used as type constraints inside roles work';
dies_ok { R2[C3].new.call_fail },  'classes being used as type constraints inside roles work';

# RT #72694
eval_dies_ok 'role ABCD[EFGH] { }', 'role with undefined type as parameter dies';

# RT #68136
#?rakudo skip 'cannot easily override [] at the moment'
{
    role TreeNode[::T] does Positional {
        has TreeNode[T] @!children handles 'postcircumfix:<[ ]>'; # METHOD TO SUB CASUALTY
        has T $.data is rw;
    };
    my $tree = TreeNode[Int].new;
    $tree.data = 3;
    $tree[0] = TreeNode[Int].new;
    $tree[1] = TreeNode[Int].new;
    $tree[0].data = 1;
    $tree[1].data = 4;
    is ($tree.data, $tree[0,1]>>.data).join(','), '3,1,4',
        'parameterized role doing non-parameterized role';
}

# RT #68134
{
    role P[$x] { }
    # ::T only makes sense in a signature here, not in
    # an argument list.
    dies_ok { eval 'class MyClass does P[::T] { }' },
        'can not use ::T in role application';
}

# RT #101426
{
    my role R[::T = my role Q[::S = role { method baz { "OH HAI" } }] { method bar { S.baz } }] { method foo { T.bar } };
    is R.new.foo, 'OH HAI', 'can use a parameterized role as a default value of a parameterized role';

}

# RT #114954
{
    my module A {
        role B[$x] is export {
            method payload { $x }
        }
    }
    import A;
    is B['blubb'].payload, 'blubb', 'can export and import parameterized roles';
}

#?pugs emit =end SKIP

# vim: ft=perl6
��������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/parameter-subtyping.t�����������������������������������������������0000664�0001750�0001750�00000004002�12224265625�021662� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 22;

#?pugs emit skip_rest('parameterized roles'); exit;
#?pugs emit =begin SKIP

# L<S14/Parametric Subtyping>

role R1[::T] { }
role R1[::T1, ::T2] { }
class C1 { }
class C2 is C1 { }
class C3 { }

# Subtyping with a single role parameter which is a class type.
ok(R1[C1] ~~ R1,      'basic sanity');
ok(R1[C1] ~~ R1[C1],  'basic sanity');
ok(R1[C2] ~~ R1[C1],  'subtyping by role parameters (one param)');
ok(R1[C1] !~~ R1[C2], 'subtyping by role parameters (one param)');
ok(R1[C3] !~~ R1[C1], 'subtyping by role parameters (one param)');

# Subtyping with nested roles.
ok(R1[R1[C1]] ~~ R1,          'basic sanity');
ok(R1[R1[C1]] ~~ R1[R1[C1]],  'basic sanity');
ok(R1[R1[C2]] ~~ R1[R1[C1]],  'subtyping by role parameters (nested)');
ok(R1[R1[C1]] !~~ R1[R1[C2]], 'subtyping by role parameters (nested)');
ok(R1[R1[C3]] !~~ R1[R1[C1]], 'subtyping by role parameters (nested)');

# Subtyping with multiple role parameters.
ok(R1[C1,C3] ~~ R1,         'basic sanity');
ok(R1[C1,C3] ~~ R1[C1,C3],  'basic sanity');
ok(R1[C2,C3] ~~ R1[C1,C3],  'subtyping by role parameters (two params)');
ok(R1[C2,C2] ~~ R1[C1,C1],  'subtyping by role parameters (two params)');
ok(R1[C1,C1] !~~ R1[C2,C2], 'subtyping by role parameters (two params)');
ok(R1[C1,C2] !~~ R1[C2,C1], 'subtyping by role parameters (two params)');
ok(R1[C2,C1] !~~ R1[C1,C3], 'subtyping by role parameters (two params)');

# Use of parametric subtyping in dispatch.
sub s(C1 @arr) { 1 }   #OK not used
multi m(C1 @arr) { 2 }   #OK not used
multi m(@arr) { 3 }   #OK not used
my C2 @x;
is(s(@x), 1, 'single dispatch relying on parametric subtype');
is(m(@x), 2, 'multi dispatch relying on parametric subtype');

# Real types enforced.
sub modify(C1 @arr) {
    @arr[0] = C1.new;
}
dies_ok({ eval 'modify(@x)' }, 'type constraints enforced properly');

# Use of parametric subtyping for assignment.
my Numeric @a;
my Int @b = 1,2;
lives_ok({ @a = @b }, 'assignment worked as expected');
is(@a[0], 1,          'assignment worked as expected');

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/stubs.t�������������������������������������������������������������0000664�0001750�0001750�00000002513�12224265625�017025� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 9;

role WithStub { method a() { ... } };
role ProvidesStub1 { method a() { 1 } };
role ProvidesStub2 { method a() { 2 } };

#?pugs todo
dies_ok  { eval 'class A does WithStub { }' },
        'need to implement stubbed methods at role-into-class composition time';
lives_ok { eval 'role B does WithStub { }' },
        'but roles are fine';
lives_ok { eval 'class C does WithStub { method a() { 3 } }' },
        'directly implementing the stubbed method is fine';
lives_ok { eval 'class D does WithStub does ProvidesStub1 { }' },
        'composing the stubbed method is fine';
#?pugs todo
dies_ok  { eval 'class E does WithStub does ProvidesStub1 does ProvidesStub2 { }' },
        'composing stub and 2 implementations dies again';
lives_ok { eval 'class F does WithStub does ProvidesStub1 does ProvidesStub2 {
    method a() { 4 } }' },
        'composing stub and 2 implementations allows custom implementation';

class ProvidesA { method a() { 5 } };
lives_ok { eval 'class ChildA is ProvidesA does WithStub { }' },
        'stubbed method can come from parent class too';

lives_ok { eval 'class RT115212 does WithStub { has $.a }' }, 'stubbed method can come from accessor';

class HasA { has $.a }
lives_ok { eval 'class RT115212Child is HasA does WithStub { }' }, 'stubbed method can come from accessor in parent class';
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-roles/submethods.t��������������������������������������������������������0000664�0001750�0001750�00000001403�12224265625�020037� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 4;

=begin pod

Tests of roles with submethods

# L<S14/Roles>
# L<S12/Submethods>

=end pod


role AddBuild
{
    has $.did_build = 0;
    submethod BUILD ( $self: )   #OK not used
    {
        $!did_build = 1;
    }
}

class MyClass does AddBuild {}

my $class = MyClass.new();
ok( $class.did_build, 'Class that does role should do submethods of role' );


role WithSM {
    submethod ouch() { 'the pain' }
    submethod conf() { 'FAIL' }
}

class Parent does WithSM {
    submethod conf() { 'correct' }
}
class Child is Parent { }

is Parent.ouch(), 'the pain', 'submethod composes ok...';
is Parent.conf(), 'correct',  'submethod in class wins';
#?pugs todo
dies_ok { Child.ouch() },     'composed submethod acts like one';

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-traits/attributes.t�������������������������������������������������������0000664�0001750�0001750�00000002335�12224265625�020237� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 8;

# L<S14/Traits/>

my @attr_names;
multi trait_mod:<is>(Attribute $a, :$noted!) {
    push @attr_names, $a.name;
}

role doc { has $.doc is rw }
multi trait_mod:<is>(Attribute $a, doc, $arg) {
    $a.container.VAR does doc($arg);
}


class T1 {
    has $!a is noted;
}
class T2 is T1 {
    has %!b is noted;
    has @!c is noted;
}

# Force class to create itself and thus apply the traits, for implementations
# that do such things lazily.
ok T2.new ~~ T2, 'class with traits applied to attributes by name instantiated ok';
@attr_names .= sort;
is +@attr_names, 3, 'have correct number of attributes';
is @attr_names, ['$!a','%!b','@!c'], 'trait was applied to each attribute';
T2.new;
is +@attr_names, 3, 'second instantiation of the classes does not re-apply traits';


class T3 {
    has $.dog is doc('barks');
    has @.birds is doc('tweet');
    has %.cows is doc('moooo');
}

my $x = T3.new;
ok $x ~~ T3, 'class with traits applied to attributes by role instantiated ok';
is $x.dog.VAR.doc, 'barks', 'trait applied to scalar attribute correctly';
is $x.birds.doc,   'tweet', 'trait applied to array attribute correctly';
is $x.cows.doc,    'moooo', 'trait applied to hash attribute correctly';

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-traits/package.t����������������������������������������������������������0000664�0001750�0001750�00000003215�12224265625�017442� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 8;

# L<S14/Traits/>

role description {
    has $.description is rw;
}

multi trait_mod:<is>(Mu:U $c, description, $arg) {
    $c.HOW does description($arg);
}
multi trait_mod:<is>(Mu:U $c, description) {
    $c.HOW does description("missing description!");
}
multi trait_mod:<is>(Mu:U $c, :$described!) {
    $c.HOW does description($described ~~ Str ?? $described !! "missing description");
}

class Monkey is description('eats bananas, awesome') { }
class Walrus is description { }
is Monkey.HOW.description, 'eats bananas, awesome', 'description role applied to class and set with argument';
is Walrus.HOW.description, 'missing description!',  'description role applied to class without argument';

class Badger is described('mushroom mushroom') { }
class Snake is described { }
is Badger.HOW.description, 'mushroom mushroom',    'named trait handler applied other role to class set with argument';
is Snake.HOW.description,  'missing description!', 'named trait handler applied other role to class without argument';


role Nom is description('eats and eats') { }
role Loser is description { }
is Nom.HOW.description,   'eats and eats',        'description role applied to role and set with argument';
is Loser.HOW.description, 'missing description!', 'description role applied to role without argument';

role DamBuilding is described('dam good!') { }
role Slither is described { }
is DamBuilding.HOW.description, 'dam good!',            'named trait handler applied other role to role set with argument';
is Slither.HOW.description,     'missing description!', 'named trait handler applied other role to role without argument';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-traits/routines.t���������������������������������������������������������0000664�0001750�0001750�00000005213�12224265625�017717� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 13;

# L<S14/Traits/>
{
    role description {
        has $.description is rw;
    }

    multi trait_mod:<is>(Routine $code, description,  $arg) {
        $code does description($arg)
    }
    multi trait_mod:<is>(Routine $code, description) {
        $code does description('missing description!')
    }
    multi trait_mod:<is>(Routine $code, Str :$described!) {
        $code does description($described);
    }
    multi trait_mod:<is>(Routine $code, Bool :$described!) {
        $code does description("missing description!");
    }


    sub answer() is description('computes the answer') { 42 }
    sub faildoc() is description { "fail" }
    is answer(), 42, 'can call sub that has had a trait applied to it by role name with arg';
    is &answer.description, 'computes the answer',  'description role applied and set with argument';
    is faildoc(), "fail", 'can call sub that has had a trait applied to it by role name without arg';
    is &faildoc.description, 'missing description!', 'description role applied without argument';

    sub cheezburger is described("tasty") { "nom" }
    sub lolcat is described { "undescribable" }

    is cheezburger(), "nom", 'can call sub that has had a trait applied to it by named param with arg';
    is &cheezburger.description, 'tasty',  'named trait handler applied other role set with argument';
    is lolcat(), "undescribable", 'can call sub that has had a trait applied to it by named param without arg';
    is &lolcat.description, 'missing description!', 'named trait handler applied other role without argument';
}

{
    my $recorder = '';
    multi trait_mod:<is>(Routine $c, :$woowoo!) {
        $c.wrap: sub {
            $recorder ~= 'wrap';
        }
    }
    sub foo is woowoo { };
    lives_ok &foo, 'Can call subroutine that was wrapped by a trait';
    #?rakudo todo 'trait mod / .wrap interaction'
    is $recorder, 'wrap', 'and the wrapper has been called once';
}

# RT 112664
{
    multi trait_mod:<is>(Routine $m, :$a!) {
	multi y(|) { my $x = $m }   #OK not used
	$m.wrap(&y)
    }
    sub rt112664 is a {}

    lives_ok { rt112664 },
    '[BUG] multi without proto gets wrong lexical lookup chain (RT 112664)';
}

# RT 74092
{
    try { eval 'sub yulia is krassivaya { }' };
    diag $!
      if !ok "$!" ~~ /'unknown trait'/,
        'declaration of a sub with an unknown trait mentions trait_mod:<is> in dispatch error';
}

{
    multi trait_mod:<is>(Routine $r, :$trait_that_wraps!) {
        $r.wrap(-> |c { 2 * callsame; })
    }
    sub wrappee($a, $b) is trait_that_wraps { 42 };
    is wrappee(1, 2), 84, 'wrapping a routine at compile time makes it soft';
}

done();

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S14-traits/variables.t��������������������������������������������������������0000664�0001750�0001750�00000001430�12224265625�020014� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 5;

# L<S14/Traits/>

my @var_names;
multi trait_mod:<is>($a, :$noted!) {
    push @var_names, $a.VAR.name;
}

role doc { has $.doc is rw }
multi trait_mod:<is>($a, $arg, :$doc!) {
    $a.container.VAR does doc.new(doc => $arg);
}


my $a is noted;
my %b is noted;
my @c is noted;

@var_names .= sort;
is +@var_names, 3, 'have correct number of names noted from trait applied by name';
is @var_names, ['$a','%b','@c'], 'trait recorded correct information';


my $dog is doc('barks');
my @birds is doc('tweet');
my %cows is doc('moooo');

is $dog.VAR.doc, 'barks', 'trait applied to scalar variable correctly';
is @birds.doc,   'tweet', 'trait applied to array variable correctly';
is %cows.doc,    'moooo', 'trait applied to hash variable correctly';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S15-strings/NFK-types.t�������������������������������������������������������0000664�0001750�0001750�00000002150�12253134031�017774� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 10;

#### Tests both of the NFKC and NFKD types.

## NFKC

#?rakudo 1 skip 'NFKC type NYI'
#?niecza 1 skip 'NFKC type NYI'
{
    is q:nfkc"ẛ̣".WHAT, NFKC, ":nfkc adverb on quoteforms produces NFKC string type.";
    is "ẛ̣".NFKC.WHAT, NFKC, "Str literal can be converted to NFKC.";

    my $NFKC = q:nfkc'ẛ̣';

    is $NFKC.chars, 1, "NFKC.chars returns number of codepoints.";
    is $NFKC.codes, 1, "NFKC.codes returns number of codepoints.";

    is $NFKC.comb, 'ṩ', "NFKC correctly normalized ẛ̣";

    # note: more "correctly normalized" tests needed, esp. wrt correct order of
    # combining marks.
}

## NFKD

#?rakudo 1 skip 'NFKD type NYI'
#?niecza 1 skip 'NFKD type NYI'
{
    is q:nfkd"ẛ̣".WHAT, NFKD, ":nfkd adverb on quoteforms produces NFKD string type.";
    is "ẛ̣".NFKD.WHAT, NFKD, "Str literal can be converted to NFKD.";

    my $NFKD = q:nfkd'ẛ̣';

    is $NFKD.chars, 3, "NFKD.chars returns number of codepoints.";
    is $NFKD.codes, 3, "NFKD.codes returns number of codepoints.";

    is $NFKD.comb, <s ̣ ̇>, "NFKD correctly normalized ẛ̣";
}
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S15-strings/NF-types.t��������������������������������������������������������0000664�0001750�0001750�00000002105�12253134031�017661� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 10;

#### Tests both of the NFC and NFD types.

## NFC

#?rakudo 1 skip 'NFC type NYI'
#?niecza 1 skip 'NFC type NYI'
{
    is q:nfc"ẛ̣".WHAT, NFC, ":nfc adverb on quoteforms produces NFC string type.";
    is "ẛ̣".NFC.WHAT, NFC, "Str literal can be converted to NFC.";

    my $NFC = q:nfc'ẛ̣';

    is $NFC.chars, 2, "NFC.chars returns number of codepoints.";
    is $NFC.codes, 2, "NFC.codes returns number of codepoints.";

    is $NFC.comb, <ẛ ̣>, "NFC correctly normalized ẛ̣";

    # note: more "correctly normalized" tests needed, esp. wrt correct order of
    # combining marks.
}

## NFD

#?rakudo 1 skip 'NFD type NYI'
#?niecza 1 skip 'NFD type NYI'
{
    is q:nfd"ẛ̣".WHAT, NFD, ":nfd adverb on quoteforms produces NFD string type.";
    is "ẛ̣".NFD.WHAT, NFD, "Str literal can be converted to NFD.";

    my $NFD = q:nfd'ẛ̣';

    is $NFD.chars, 3, "NFD.chars returns number of codepoints.";
    is $NFD.codes, 3, "NFD.codes returns number of codepoints.";

    is $NFD.comb, <ſ ̣ ̇>, "NFD correctly normalized ẛ̣";
}�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S15-strings/Str.t�������������������������������������������������������������0000664�0001750�0001750�00000000730�12253134031�016766� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 5;

is "ẛ̣".WHAT, Str, "Strings are of type Str by default.";
#?rakudo 1 skip ':nfg adverb NYI'
#?niecza 1 skip ':nfg adverb NYI'
is qq:nfg/ẛ̣/.WHAT, Str, ":nfg adverb on quoteforms results in Str.";

is "ẛ̣".chars, 1,  "Str.chars returns number of graphemes.";
#?rakudo 1 skip 'Str.graphs NYI'
is "ẛ̣".graphs, 1, "Str.graphs returns number of graphemes.";
ok "ẛ̣".ord < 0, "Str.ord returns negative number for NFG grapheme.";
����������������������������������������rakudo-2013.12/t/spec/S16-filehandles/chmod.t�������������������������������������������������������0000664�0001750�0001750�00000005120�12241704255�020104� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::IO/IO::FSNode::Unix/chmod>
# old: L<S16/"Filehandles, files, and directories"/"chmod">

=begin pod

chmod - the unix chmod command, changing the rights on a file

Proposed behaviour
LIST = chmod MODE, LIST
Given a list of files and directories change the rights on them.
MODE should be an octet representing or a string like similar to what can be used in
     the same UNIX program:
     one or more of the letters ugoa, one of the symbols +-= and one or more of the letters rwxXstugo.
     
return list should be the list of files that were successfully changed
in scalar context it should be the number of files successfully changed

While some of the modes are UNIX specific, it would be nice to find similar
  modes in other operating system and do the right thing there too.


We really need the stat() function in order to test this.

=end pod

plan 19;

if $*OS eq any <MSWin32 mingw msys cygwin> {
    skip_rest "file tests not fully available on win32";
    exit;
};


{
    my $file = create_temporary_file;
    my @result = chmod 0o000, $file;
    is +@result, 1, "One file successfully changed";
    #?pugs todo ''
    is @result[0], $file, "name of the file returned";
    if ($*EUID) {
        ok $file.IO ~~ :!r, "not readable after 0";
        ok $file.IO ~~ :!w, "not writeable after 0";
        ok $file.IO ~~ :!x, "not executable after 0";
    }
    else {
        skip ":r :w :x can accidentally work with root permission", 3;
    }
    remove_file($file);
}


{
    my $file = create_temporary_file;
    my @result = chmod 0o700, $file;
    is +@result, 1, "One file successfully changed";
    #?pugs todo ''
    is @result[0], $file, "name of the file returned";

    ok $file.IO ~~ :r, "readable after 700";
    ok $file.IO ~~ :w, "writabel after 700";
    ok $file.IO ~~ :x, "executable after 700";
    remove_file($file);
}


{
    my $file = create_temporary_file;
    my @result = chmod 0o777, $file;
    is +@result, 1, "One file successfully changed";
    #?pugs todo ''
    is @result[0], $file, "name of the file returned";

    ok $file.IO ~~ :r, "readable after 777";
    ok $file.IO ~~ :w, "writable after 777";
    ok $file.IO ~~ :x, "executable after 777";
    remove_file($file);
}

sub create_temporary_file {
    my $time = time;
    my $file = "temp_$time";
    my $fh = open $file, :w orelse die "Could not create $file";   #OK not used
    diag "Using file $file";
    return $file;
}
sub remove_file ($file) {
    unlink $file;
    ok($file.IO ~~ :!e, "Test file was successfully removed");
}

ok(try { "nonesuch".IO ~~ :!e }, "~~:!e syntax works");


# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/connect.t�����������������������������������������������������0000664�0001750�0001750�00000001760�12241704255�020451� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::IO/IO::File/open>
# L<S32::IO/IO/uri>
# L<S29/IO/connect>
# old: L<S16/"Filehandles, files, and directories"/"connect">

=begin pod

Tests for IO connect() builtin

=end pod

plan 4;

my $skip_var = 'PERL_TESTS_ALLOW_NETWORK';
unless %*ENV{$skip_var} {
  skip_rest "Won't test &connect as environment variable \"$skip_var\" is not true.";
  exit;
}

{
  my $fh = connect "google.com", 80;

  my $nl = chr(13) ~ chr(10);
  $fh.print("GET / HTTP/1.0{$nl}Host: google.de{$nl}User-Agent: pugs/connect.t{$nl}Connection: close$nl$nl");
  $fh.flush();

  ok index($fh.readline, "HTTP/") > -1, "connect('google.de', 80) works";
}

{
  dies_ok { connect "localhost", 70000 }, "&connect fails when it can't connect";
}

skip_rest("waiting on 'use fatal'"); exit;

{
  # no fatal;
  lives_ok { connect "localhost", 70000 },
    "&connect does not die when it can't connect";

  ok !connect("localhost", 70000),
    "&connect returns a false value when it can't connect";
}

# vim: ft=perl6
����������������rakudo-2013.12/t/spec/S16-filehandles/dir.t���������������������������������������������������������0000664�0001750�0001750�00000011036�12241704255�017573� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
use FindBin;
plan 36;

# L<S32::IO/IO::DirectoryNode>
# old: L<S16/"Filehandles, files, and directories"/"IO::Dir::open">
# XXX closedir is not defined rigth now, should it be IO::Dir::close"?
# old: L<S16/"Filehandles, files, and directories"/"IO::Dir::open">
# XXX readdir is not defined rigth now, should be it IO::Dir::read"?
# old: L<S16/"Filehandles, files, and directories"/"IO::Dir::open">
# XXX rewinddir is not defined rigth now, should it be IO::Dir::rewind"?
# old: L<S16/"Filehandles, files, and directories"/"IO::Dir::open">

=begin pod

opendir/readdir support

=end pod

my $dir = opendir($FindBin::Bin);
isa_ok($dir, IO::Dir, "opendir worked on $FindBin::Bin");

my @files = readdir($dir);
ok(@files, "seems readdir worked too");

my @more_files = readdir($dir);
is(+@more_files, 0, "No more things to read");

my $row = readdir($dir);
ok(!defined($row), "in scalar context it returns undefined");

my $rew_1 = rewinddir($dir);
is($rew_1, 1, "success of rewinddir 1 returns 1");

my @files_again = readdir($dir);

is_deeply(\@files_again, @files, "same list of files retrieved after rewind");

my $rew_2 = rewinddir($dir);
is($rew_2, 1, "success of rewinddir 2 returns 1");

my @files_scalar;
loop {
    my $f = readdir($dir) orelse last;
    @files_scalar.push($f);
}
is_deeply(\@files_scalar, @files, "same list of files retrieved after rewind, using scalar context");

my $rew_3 = $dir.rewinddir;
is($rew_3, 1, 'success of rewinddir 3 using $dir.rewinddir returns 1');
my @files_dot = $dir.readdir;
is_deeply(\@files_dot, @files, 'same list of files retrieved using $dir.readdir');

my $rew_4 = $dir.rewinddir;
is($rew_4, 1, 'success of rewinddir 4 using $dir.rewinddir returns 1');

my @files_scalar_dot;
for $dir.readdir -> $f {
    @files_scalar_dot.push($f);
}
is_deeply(\@files_scalar_dot, @files, 'same list of files, using $dir.readdir in scalar context');

my @more_files_2 = $dir.readdir;
is(+@more_files_2, 0, "No more things to read");

my $row_2 = $dir.readdir;
ok(!defined($row_2), "in scalar context it returns undefined");


ok(closedir($dir), "as does closedir");

# on closed directory handler these calls should throw an exception
#my $undef = readdir($dir);
#my @empty = readdir($dir);
# rewinddir($dir);
# closedir


my $dh = opendir($FindBin::Bin);
isa_ok($dh, IO::Dir, "opendir worked");
my @files_once_more = $dh.readdir;
is_deeply(@files_once_more.sort, @files.sort, 'same list of files,after reopen');
ok($dir.closedir, 'closedir using $dir.closedir format');


# short version. read close etc...
# copied from above just shortent he methods. and append _s to every variable.
diag "Start testing for short version.";
my $dir_s = opendir($FindBin::Bin);
isa_ok($dir_s, IO::Dir, "opendir worked on $FindBin::Bin");

my @files_s = read($dir_s);
ok(@files_s, "seems read worked too");

my @more_files_s = read($dir);
is(+@more_files_s, 0, "No more things to read");

my $row_s = read($dir_s);
ok(!defined($row_s), "in scalar context it returns undefined");

my $rew_1_s = rewind($dir_s);
is($rew_1_s, 1, "success of rewind 1 returns 1");

my @files_again_s = read($dir_s);

is_deeply(\@files_again_s, @files_s, "same list of files retrieved after rewind");

my $rew_2_s = rewind($dir_s);
is($rew_2_s, 1, "success of rewind 2 returns 1");

my @files_scalar_s;
loop {
    my $f = read($dir_s) orelse last;
    @files_scalar_s.push($f);
}
is_deeply(\@files_scalar_s, @files_s, "same list of files retrieved after rewind, using scalar context");

my $rew_3_s = $dir_s.rewind;
is($rew_3_s, 1, 'success of rewind 3 using $dir.rewind returns 1');
my @files_dot_s = $dir_s.read;
is_deeply(\@files_dot_s, @files_s, 'same list of files retrieved using $dir.read');

my $rew_4_s = $dir_s.rewind;
is($rew_4_s, 1, 'success of rewind 4 using $dir.rewind returns 1');

my @files_scalar_dot_s;
for $dir_s.read -> $f {
    @files_scalar_dot_s.push($f);
}
is_deeply(\@files_scalar_dot_s, @files, 'same list of files, using $dir.read in scalar context');

my @more_files_2_s = $dir_s.read;
is(+@more_files_2_s, 0, "No more things to read");

my $row_2_s = $dir_s.read;
ok(!defined($row_2_s), "in scalar context it returns undefined");


ok(close($dir_s), "as does close");

# on closed directory handler these calls should throw an exception
#my $undef = readdir($dir);
#my @empty = readdir($dir);
# rewinddir($dir);
# closedir

my $dh_s = opendir($FindBin::Bin);
isa_ok($dh_s, IO::Dir, "opendir worked");
my @files_once_more_s = $dh_s.read;
is_deeply(@files_once_more_s.sort, @files_s.sort, 'same list of files,after reopen');
ok($dir_s.close, 'close using $dir.close format');



# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/filestat.t����������������������������������������������������0000664�0001750�0001750�00000005635�12241704255�020640� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

=head1 DESCRIPTION

This test tests various file stat methods.

=end pod

plan 13;

# time stat tests (modify/change/access)
{
    my $before_creation = time - 1;

    my $tmpfile1 = create_temporary_file(1);
    my $original1_modified = $tmpfile1.IO.modified;
    my $original1_changed = $tmpfile1.IO.changed;
    my $original1_accessed = $tmpfile1.IO.accessed;

    my $tmpfile2 = create_temporary_file(2);
    my $original2_modified = $tmpfile2.IO.modified;
    my $original2_changed = $tmpfile2.IO.changed;
    my $original2_accessed = $tmpfile2.IO.accessed;

    ok ($before_creation < $original1_modified), 'IO.modified should be greater than pre-creation timestamp';
    ok ($before_creation < $original1_changed),  'IO.changed should be greater than pre-creation timestamp';
    ok ($before_creation < $original1_accessed), 'IO.accessed should be greater than pre-creation timestamp';

    sleep 2; # tick for time comparisons


    # altering content
    my $fh1 = open $tmpfile1, :w orelse die "Could not open $tmpfile1 for writing";
    $fh1.print("example content");
    $fh1.close;

    ok ($original1_modified < $tmpfile1.IO.modified), 'IO.modified should be updated when file content changes';
    ok ($original1_changed  < $tmpfile1.IO.changed),  'IO.changed should be updated when file content changes';
    ok ($original1_accessed == $tmpfile1.IO.accessed), 'IO.accessed should NOT be updated when file is opened for writing';
   
    # opening for read
    $fh1 = open $tmpfile1, :r orelse die "Could not open $tmpfile1 for reading";
    $fh1.close;

    ok ($original1_accessed == $tmpfile1.IO.accessed), 'IO.accessed should NOT be updated when file is opened for reading';

    # reading contents of file 
    slurp $tmpfile1;
    ok ($original1_accessed < $tmpfile1.IO.accessed), 'IO.accessed should be updated when contents of file is read';


    # changing file permissions

    $tmpfile2.IO.chmod(0o000);
    my $post_chmod_modified = $tmpfile2.IO.modified;
    my $post_chmod_changed = $tmpfile2.IO.changed;

    ok ($original2_changed == $post_chmod_modified), 'IO.modified should NOT be updated when file mode is altered';
    ok ($original2_changed  < $post_chmod_changed),  'IO.changed should be updated when file mode is altered';
    ok ($post_chmod_modified != $post_chmod_changed),  'IO.changed and IO.modified should differ after file mode change';


    # accessing file

    remove_file $tmpfile1;
    remove_file $tmpfile2;
}


sub create_temporary_file($id) {
    my $time = time;
    my $file = "temp-16-filehandles-filestat-" ~ $*PID ~ "-" ~ $id ~ ".temp";
    my $fh = open $file, :w orelse die "Could not create $file";   #OK not used
    $fh.print($time);                            # store pre-creation timestamp
    diag "Using file $file";
    return $file;
}

sub remove_file ($file) {
    unlink $file;
    ok($file.IO ~~ :!e, "Test file $file was successfully removed");
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/filetest.t����������������������������������������������������0000664�0001750�0001750�00000010312�12241704255�020630� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

=head1 DESCRIPTION

This test tests the various filetest operators.

=end pod

plan 41;

# L<S32::IO/IO::FSNode/=item IO ~~ :X>
# L<S03/Changes to Perl 5 operators/The filetest operators are gone.>
# old: L<S16/Filehandles, files, and directories/A file test, where X is one of the letters listed below.>

#?niecza todo
dies_ok { 't' ~~ :d }, 'file test from before spec revision 27503 is error';

# Basic tests
ok 't'.IO ~~ :d,             "~~:d returns true on directories";
lives_ok { 'non_existing_dir'.IO ~~ :d },
         'can :d-test against non-existing dir and live';
ok !('non_existing_dir'.IO ~~ :d ),
         'can :d-test against non-existing dir and return false';
ok $*PROGRAM_NAME.IO ~~ :f,  "~~:f returns true on files";
ok $*PROGRAM_NAME.IO ~~ :e,  "~~:e returns true on files";
ok 't'.IO ~~ :e,             "~~:e returns true on directories";
ok $*PROGRAM_NAME.IO ~~ :r,  "~~:r returns true on readable files";
ok $*PROGRAM_NAME.IO ~~ :w,  "~~:w returns true on writable files";

if $*OS eq any <MSWin32 mingw msys cygwin> {
  skip "win32 doesn't have ~~:x", 2;
} else {
  if $*EXECUTABLE_NAME.IO ~~ :e {
    ok $*EXECUTABLE_NAME.IO ~~ :x, "~~:x returns true on executable files";
  }
  else {
    skip "'$*EXECUTABLE_NAME' is not present (interactive mode?)", 1;
  }
  ok 't'.IO ~~ :x,    "~~:x returns true on cwd()able directories";
}

nok "t".IO ~~ :f, "~~:f returns false on directories";
ok "t".IO ~~ :r,  "~~:r returns true on a readable directory";

ok 'doesnotexist'.IO !~~ :d, "~~:d returns false on non-existent directories";
ok 'doesnotexist'.IO !~~ :r, "~~:r returns false on non-existent directories";
ok 'doesnotexist'.IO !~~ :w, "~~:w returns false on non-existent directories";
ok 'doesnotexist'.IO !~~ :x, "~~:x returns false on non-existent directories";
ok 'doesnotexist'.IO !~~ :f, "~~:f returns false on non-existent directories";

ok not 'doesnotexist.t'.IO ~~ :f, "~~:f returns false on non-existent files";
ok not 'doesnotexist.t'.IO ~~ :r, "~~:r returns false on non-existent files";
ok not 'doesnotexist.t'.IO ~~ :w, "~~:w returns false on non-existent files";
ok not 'doesnotexist.t'.IO ~~ :x, "~~:x returns false on non-existent files";
ok not 'doesnotexist.t'.IO ~~ :f, "~~:f returns false on non-existent files";

#?niecza skip ".s NYI"
ok($*PROGRAM_NAME.IO.s > 42,   "~~:s returns size on existent files");

nok "doesnotexist.t".IO ~~ :s, "~~:s returns false on non-existent files";

nok $*PROGRAM_NAME.IO ~~ :z,   "~~:z returns false on existent files";
nok "doesnotexist.t".IO ~~ :z, "~~:z returns false on non-existent files";
nok "t".IO ~~ :z,              "~~:z returns false on directories";

my $fh = open("empty_file", :w);
close $fh;
#?niecza todo
ok "empty_file".IO ~~ :z,      "~~:z returns true for an empty file";
unlink "empty_file";

#?niecza skip "Asynchronous programming NYI exception generated"
{
    if $*OS eq any <MSWin32 mingw msys cygwin> {
      skip "~~:M/~~:C/~~:A not working on Win32 yet", 9
    }
    else {
        my $fn = 'test_file_filetest_t';
        my $fh = open($fn, :w);
        close $fh;
        sleep 1; # just to make sure
        #?rakudo 3 skip ':M, :C, :A'
        ok ($fn.IO ~~ :M) < 0,      "~~:M works on new file";
        ok ($fn.IO ~~ :C) < 0,      "~~:C works on new file";
        ok ($fn.IO ~~ :A) < 0,      "~~:A works on new file";
        unlink $fn;

        if "README".IO !~~ :f {
            skip "no file README", 3;
        } else {
            #?rakudo 3 skip ':M, :C, :A'
            ok ("README".IO ~~ :M) > 0, "~~:M works on existing file";
            ok ("README".IO ~~ :C) > 0, "~~:C works on existing file";
            ok ("README".IO ~~ :A) > 0, "~~:A works on existing file";
        }

        #?rakudo 3 skip ':M, :C, :A'
        ok not "xyzzy".IO ~~ :M, "~~:M returns undefined when no file";
        ok not "xyzzy".IO ~~ :C, "~~:C returns undefined when no file";
        ok not "xyzzy".IO ~~ :A, "~~:A returns undefined when no file";
    }
}

# potential parsing difficulties (pugs)
{
    sub f($) { return 8; }

    is(f($*PROGRAM_NAME), 8, "f(...) works");
    is(-f($*PROGRAM_NAME), -8, "- f(...) does not call the ~~:f filetest");
    is(- f($*PROGRAM_NAME), -8, "- f(...) does not call the ~~:f filetest");
}


# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/io_in_for_loops.t���������������������������������������������0000664�0001750�0001750�00000005136�12254646735�022214� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::IO/IO::File/open>
# old: L<S16/"Filehandles, files, and directories"/"open">
# old: L<S16/"Filehandles, files, and directories"/"close">

plan 29;

my $filename = 'tempfile_io_in_for_loop';

{ # write the file first
    my $fh = open($filename, :w);
    for (1 .. 6) -> $num {
        $fh.print("$num\n");
    }
    $fh.close();
}

{ # now read it in and check
    my $fh = open($filename);
    for (1 .. 6) -> $num {
        my $line = get $fh;
        is($line, "$num", '... got the right line (array controlled loop)');
    }
    $fh.close();
}

#?DOES 6
#?rakudo.moar skip 'infinite loop'
{ # now read it in with the $fh controling the loop
    my $fh = open($filename);
    my $num = 1;
    for ($fh.lines) -> $line {
        is($line, "$num", '... got the right line (($fh.lines) controlled loop)');
        $num++;
    }
    $fh.close();
}

#?DOES 6
#?rakudo.moar skip 'infinite loop'
{ # now read it in with the $fh controling the loop w/out parens
    my $fh = open($filename);
    my $num = 1;
    for $fh.lines -> $line {
        is($line, "$num", '... got the right line ($fh.lines controlled loop)');
        $num++;
    }
    $fh.close();
}

## more complex loops

#?DOES 6
{ # now read it in and check
    my $fh = open($filename);
    my $num = 1;
    for (1 .. 3) -> $_num {
        my $line = get $fh;
        is($line, "$num", '... got the right line (array controlled loop)');
        $num++;
        my $line2 = get $fh;
        is($line2, "$num", '... got the right line2 (array controlled loop)');        
        $num++;        
    }
    $fh.close();
}

{ # now read it in with the $fh controling the loop but call 
  # the $fh.get inside the loop inside parens (is this list context??)
    my $fh = open($filename);
    my $num = 1;
    for $fh.get -> $line {
        is($line, "$num", '... got the right line ((=$fh) controlled loop)');
        $num++;
        my $line2 = get $fh;
        is($line2, "$num", '... got the right line2 ((=$fh) controlled loop)');
        $num++;
    }
    $fh.close();
}

{ # now read it in with the $fh controling the loop but call 
  # the get $fh inside the loop w/out parens (is this scalar context??)
    my $fh = open($filename);
    my $num = 1;
    for get $fh -> $line {
        is($line, "$num", '... got the right line (=$fh controlled loop)');
        $num++;
        my $line2 = get $fh;
        is($line2, "$num", '... got the right line2 (=$fh controlled loop)');
        $num++;
    }
    $fh.close();
}

# old: L<S16/"Filehandles, files, and directories"/"unlink">
# L<S29/IO/unlink>

ok(unlink($filename), 'file has been removed');

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/io_in_while_loops.t�������������������������������������������0000664�0001750�0001750�00000001551�12241704255�022517� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::IO/IO::File/open>
# old: L<S16/"Filehandles, files, and directories"/"open">

plan 13; 

my $filename = 'tempfile_io_in_while_loop';

{ # write the file first
    my $fh = open($filename, :w);
    for 1 .. 6 -> $num {
        $fh.print("$num\n");
    }
    $fh.close();
}

{ # now read it in and check
    my $fh = open($filename);
    my $num = 1;
    while $num <= 6 {
        my $line = get $fh;
        is($line, "$num", '... got the right line (array controlled loop)');
        $num++;
    }
    $fh.close();
}

{ # now read it in with the $fh controling the loop
    my $fh = open($filename);
    my $num = 1;
    my $line;
    while $line = get $fh {
        is($line, "$num", '... got the right line (get $fh controlled loop)');
        $num++;
    }
    $fh.close();
}

ok(unlink($filename), 'file has been removed');

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/io.t����������������������������������������������������������0000664�0001750�0001750�00000020462�12241704255�017427� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::IO/IO::Handle/open>
# old: L<S16/"Filehandles, files, and directories"/"open">
# old: L<S16/"Filehandles, files, and directories"/"close">
# old: L<S16/Unfiled/IO.get>

=begin pod

I/O tests

=end pod

plan 84;

sub nonce () { return ".{$*PID}." ~ (1..1000).pick() }
my $filename = 'tempfile_filehandles_io' ~ nonce();

# create and write a file

my $out = open($filename, :w);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($out, IO::Handle);
$out.say("Hello World");
$out.say("Foo Bar Baz");
$out.say("The End");
ok($out.close, 'file closed okay');

# read the file all possible ways

my $in1 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in1, IO::Handle);
my $line1a = get($in1);
is($line1a, "Hello World", 'get($in) worked (and autochomps)');
#?niecza skip 'IO.ins NYI'
is $in1.ins, 1, 'read one line (.ins)';
my $line1b = get($in1);
is($line1b, "Foo Bar Baz", 'get($in) worked (and autochomps)');
#?niecza skip 'IO.ins NYI'
is $in1.ins, 2, 'read two lines (.ins)';
my $line1c = get($in1);
is($line1c, "The End", 'get($in) worked');
#?niecza skip 'IO.ins NYI'
is $in1.ins, 3, 'read three lines (.ins)';
ok($in1.close, 'file closed okay (1)');

my $in2 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in2, IO::Handle);
my $line2a = $in2.get();
is($line2a, "Hello World", '$in.get() worked');
my $line2b = $in2.get();
is($line2b, "Foo Bar Baz", '$in.get() worked');
my $line2c = $in2.get();
is($line2c, "The End", '$in.get() worked');
ok($in2.close, 'file closed okay (2)');

# L<S02/Files/you now write>
my $in3 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in3, IO::Handle);
{
    my $line3a = $in3.get;
    is($line3a, "Hello World", '$in.get worked(1)');
    my $line3b = $in3.get;
    is($line3b, "Foo Bar Baz", '$in.get worked(2)');
    my $line3c = $in3.get;
    is($line3c, "The End", '$in.get worked(3)');
}
ok($in3.close, 'file closed okay (3)');

# append to the file

my $append = open($filename, :a);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($append, IO::Handle);
$append.say("... Its not over yet!");
ok($append.close, 'file closed okay (append)');

# now read in in list context

my $in4 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in4, IO::Handle);
my @lines4 = lines($in4);
is(+@lines4, 4, 'we got four lines from the file');
#?niecza skip 'IO.ins NYI'
is $in4.ins, 4, 'same with .ins';
is(@lines4[0], "Hello World", 'lines($in) worked in list context');
is(@lines4[1], "Foo Bar Baz", 'lines($in) worked in list context');
is(@lines4[2], "The End", 'lines($in) worked in list context');
is(@lines4[3], "... Its not over yet!", 'lines($in) worked in list context');
ok($in4.close, 'file closed okay (4)');


{
my $in5 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in5, IO::Handle);
my @lines5 = lines($in5, 3);
is(+@lines5, 3, 'we got two lines from the file');
#?niecza skip 'IO.ins NYI'
is $in5.ins, 3, 'same with .ins';
is(@lines5[0], "Hello World", 'lines($in) worked in list context');
is(@lines5[1], "Foo Bar Baz", 'lines($in) worked in list context');
is(@lines5[2], "The End", 'lines($in) worked in list context');
ok($in5.close, 'file closed okay (5)');
}

my $in6 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in6, IO::Handle);
my @lines6 = $in6.lines();
is(+@lines6, 4, 'we got four lines from the file');
is(@lines6[0], "Hello World", '$in.lines() worked in list context');
is(@lines6[1], "Foo Bar Baz", '$in.lines() worked in list context');
is(@lines6[2], "The End", '$in.lines() worked in list context');
is(@lines6[3], "... Its not over yet!", '$in.lines() worked in list context');
ok($in6.close, 'file closed okay (6)');

my $in7 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in7, IO::Handle);
my @lines7 = $in7.lines;
is(+@lines7, 4, 'we got four lines from the file');
is(@lines7[0], "Hello World", '$in.lines worked in list context');
is(@lines7[1], "Foo Bar Baz", '$in.lines worked in list context');
is(@lines7[2], "The End", '$in.lines worked in list context');
is(@lines7[3], "... Its not over yet!", '$in.lines worked in list context');
ok($in7.close, 'file closed okay (7)');

{
# test reading a file into an array and then closing before 
# doing anything with the array (in other words, is pugs too lazy)
my $in8 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in8, IO::Handle);
my @lines8 = $in8.lines(3);
push @lines8, "and finally" ~ $in8.get;
ok($in8.close, 'file closed okay (8)');
is(+@lines8, 4, 'we got four lines from the file (lazily)');
is(@lines8[0], "Hello World", 'lines($in,3) worked in list context');
is(@lines8[1], "Foo Bar Baz", 'lines($in,3) worked in list context');
is(@lines8[2], "The End", 'lines($in,3) worked in list context');
is(@lines8[3], "and finally... Its not over yet!", 'get($in) worked after lines($in,$n)');
}

#now be sure to delete the file as well
ok(unlink($filename), 'file has been removed');

# new file for testing other types of open() calls


my $out8 = open($filename, :w);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($out8, IO::Handle);
$out8.say("Hello World");
ok($out8.close, 'file closed okay (out8)');

my $in8 = open($filename);
#?niecza skip 'open does not yet produce an IO object'
isa_ok($in8, IO::Handle);
my $line8_1 = get($in8);
is($line8_1, "Hello World", 'get($in) worked');
ok($in8.close, 'file closed okay (in8)');

#?niecza skip 'Not yet able to open both :r and :w'
{
    my $fh9 = open($filename, :r, :w);  # was "<+" ? 
    isa_ok($fh9, IO::Handle);
    #my $line9_1 = get($fh9);
    #is($line9_1, "Hello World");
    #$fh9.say("Second line");
    ok($fh9.close, 'file closed okay (9)');
}

#my $in9 = open($filename);
#isa_ok($in9, IO::Handle);
#my $line9_1 = get($in9);
#my $line9_2 = get($in9);
#is($line9_1, "Hello World", 'get($in) worked');
#is($line9_2, "Second line", 'get($in) worked');

#?rakudo skip ':rw on open() unimplemented'
#?niecza skip 'Not yet able to open both :r and :w'
{
    my $fh10 = open($filename, :rw);  # was "<+" ? 
    isa_ok($fh10, IO::Handle);
    #ok($fh10.close, 'file closed okay (10)');
}

# RT #65348
{
    my $rt65348_out = open($filename, :w);
    #?niecza skip 'open does not yet produce an IO object'
    isa_ok $rt65348_out, IO::Handle;
    $rt65348_out.say( 'RT #65348' );
    $rt65348_out.say( '13.37' );
    $rt65348_out.say( '42.17' );
    ok $rt65348_out.close, 'close worked (rt65348 out)';

    my $rt65348_in = open( $filename );
    #?niecza skip 'open does not yet produce an IO object'
    isa_ok $rt65348_in, IO::Handle;
    my @list_context = ($rt65348_in.get);
    is +@list_context, 1, '.get in list context reads only one line';
    ok $rt65348_in.get.Int ~~ Int, '.get.Int gets int';
    is $rt65348_in.get.Int, 42, '.get.Int gets the right int';
    ok $rt65348_in.close, 'close worked (rt65348 in)';
}

#?pugs todo 'buggy on Win32'
ok(unlink($filename), 'file has been removed');
nok $filename.IO ~~ :e, '... and the tempfile is gone, really';

#?niecza skip ':bin NYI'
{
    my $binary_out_fh = open($filename, :w, :bin);
    #?niecza skip 'open does not yet produce an IO object'
    isa_ok($binary_out_fh, IO::Handle);
    $binary_out_fh.write("föö".encode("ISO-8859-1"));
    ok($binary_out_fh.close(), "file closed OK");
}

#?niecza skip ':bin NYI'
{
    my $binary_in_fh = open($filename, :r, :bin);
    #?niecza skip 'open does not yet produce an IO object'
    isa_ok($binary_in_fh, IO::Handle);
    my $buf = $binary_in_fh.read(4);
    is $buf.elems, 3, "three bytes were read";
    is $buf.decode("ISO-8859-1"), "föö", "the bytes decode into the right Str";
    $binary_in_fh.close;
}

unlink($filename);

$out = open($filename, :w);
$out.say("Hello World");
$out.say("Foo Bar Baz");
$out.say("The End");
$out.close;

#?niecza skip 'IO.close'
{
    my $line;
    my $io = $filename.IO;
    lives_ok { $line = $io.get; }, "can read lines without explicitly opening IO";
    is $line, 'Hello World', 'got the right line from .IO.get';
    $io.close;
}
unlink($filename);

# RT #112130
{
    $out = open($filename, :w);
    $out.print('blarg');
    $out.close;
    my $in = open($filename);
    is $in.lines.join, 'blarg', 'can use .lines on a file without trailing newline';
    $in.close;
    unlink $filename;
}

done;

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/mkdir_rmdir.t�������������������������������������������������0000664�0001750�0001750�00000001565�12241704255�021326� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 14;

my $root = "mkdir-t-testfile-" ~ 1000000.rand.floor;

diag $root;

nok $root.IO ~~ :e, "$root does not currently exist";

ok mkdir($root), "mkdir $root returns true";
ok $root.IO ~~ :e, "$root now exists";
ok $root.IO ~~ :d, "... and is a directory";

ok mkdir("$root/green"), "mkdir $root/green returns true";
ok "$root/green".IO ~~ :e, "$root/green now exists";
ok "$root/green".IO ~~ :d, "... and is a directory";

#?rakudo skip 'deviation from spec because we do not have sink yet'
nok rmdir($root), "Get false when we try to rmdir a directory with something in it";
ok $root.IO ~~ :e, "$root still exists";

ok rmdir("$root/green"), "Can remove $root/green";
nok "$root/green".IO ~~ :e, "$root/green no longer exists";
ok $root.IO ~~ :e, "$root still exists";

ok rmdir("$root"), "Can remove $root now";
nok $root.IO ~~ :e, "$root no longer exists";


�������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/open.t��������������������������������������������������������0000664�0001750�0001750�00000001420�12241704255�017752� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 3;

# L<S32::IO/IO::File/open>
# old: L<S16/"Filehandles, files, and directories"/"open">

=begin pod

Some edge and error cases for open()

=end pod

# deal with non-existent files
{
    skip("open('nonexisting') => undefined is waiting on 'use fatal'", 1);

    if 0 {
        ok(!defined(open("file_which_does_not_exist")), 'open() on non-existent file returns undefined');
    }

    open("create_this_file", :w);
    ok('create_this_file'.IO ~~ :e, 'writing to a non-existent file creates it');
    unlink('create_this_file');

    open("create_this_file2", :w);
    ok('create_this_file2'.IO ~~ :e, 'appending to a non-existent file creates it');
    unlink('create_this_file2');
}


=begin pod

I/O Redirection to scalar tests

=end pod

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-filehandles/unlink.t������������������������������������������������������0000664�0001750�0001750�00000001646�12241704255�020323� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 6;

# L<S29/IO/unlink>
# old: L<S16/"Filehandles, files, and directories"/"unlink">

sub nonce() { "unlink-t-testfile-" ~ 1000.rand }

my $fn = "unlink-test-file" ~ nonce;

my $iswin32 = ?($*OS eq any <MSWin32 mingw msys cygwin>) ?? "Timely closing of file handles does not yet work" !! False;

# open, explicit close, unlink, test
{
  my $fh = open($fn, :w);
  close $fh;

  ok $fn.IO ~~ :e,   "open() created a tempfile";
  ok(unlink($fn), "unlink() returned true");
  ok $fn.IO !~~ :e,  "unlink() actually deleted the tempfile";
}

# open, implicit close because of scope exit, unlink, test
{
  { my $fh = open($fn, :w) }

  ok $fn.IO ~~ :e,   "open() created a tempfile";
  ok(unlink($fn), "unlink() returned true");
  #?rakudo skip 'implicit closure of file handle at scope exit not implemented (FAILS ON WINDOWS) (noauto)'
  ok $fn.IO !~~ :e,  "unlink() actually deleted the tempfile";
}

# vim: ft=perl6
������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/bare-say.t�������������������������������������������������������������0000664�0001750�0001750�00000002044�12224265625�016654� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;

plan 8;

# L<S32::IO/IO::Writeable::Encoded/"it is a compiler error">

#?rakudo 3 todo 'nom regression'
eval_dies_ok('say', 'bare say is a compiler error');
eval_dies_ok('print', 'bare print is a compiler error');
#?niecza todo
eval_dies_ok('say()', 'say requires an argument');

is_run( 'say ()',
        {
            status => 0,
            out    => "\n",
            err    => '',
        },
        'say ()' );

is_run( 'say("")',
        {
            status => 0,
            out    => "\n",
            err    => '',
        },
        'say("")' );

# RT #61494
#?rakudo todo 'bare say'
{
    eval_dies_ok('say for 1', 'say for 1  is an error');
    eval_dies_ok('say  for 1', 'say  for 1  is an error');
}

# RT #74822
is_run( 'my %h=<a b c> Z 1,2,3; for %h.sort(*.key) { .say }',
        {
            status => 0,
            out    => "\"a\" => 1\n\"b\" => 2\n\"c\" => 3\n",
            err    => '',
        },
        'for %h { .say } (RT 74822)' );

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/basic-open.t�����������������������������������������������������������0000664�0001750�0001750�00000002020�12224265625�017163� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/cwd.t������������������������������������������������������������������0000664�0001750�0001750�00000000276�12224265625�015733� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;

# L<S16/IO/$*CWD>
# see also S28-named-variables/cwd.t

plan 3;

isa_ok $*CWD, IO::Path;
lives_ok { $*CWD.perl }, '$*CWD.perl works';
lives_ok { $*CWD.gist }, '$*CWD.gist works';
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/getc.t�����������������������������������������������������������������0000664�0001750�0001750�00000001260�12241704255�016066� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 1;

# L<S32::IO/IO/"getc">

sub nonce () { return (".{$*PID}." ~ 1000.rand.Int) }

my $tmpfile = "temp-test" ~ nonce();
{
  my $fh = open($tmpfile, :w) or die "Couldn't open \"$tmpfile\" for writing: $!\n";
  $fh.print: "TestÄÖÜ\n\n0";
  close $fh or die "Couldn't close \"$tmpfile\": $!\n";
}

#?rakudo.jvm skip "Method 'read' not found"
{
  my $fh = open $tmpfile or die "Couldn't open \"$tmpfile\" for reading: $!\n";
  my @chars;
  push @chars, $_ while defined($_ = getc $fh);
  close $fh or die "Couldn't close \"$tmpfile\": $!\n";

  is ~@chars, "T e s t Ä Ö Ü \n \n 0", "getc() works even for utf-8 input";
}

END { unlink $tmpfile }

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/print.t����������������������������������������������������������������0000664�0001750�0001750�00000002344�12224265625�016310� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S32::IO/IO/=item print>

# doesn't use Test.pm and plan() intentionally

print "1..12\n";

# Tests for print
{
    print "ok 1 - basic form of print\n";
}

{
    print "o", "k 2 - print with multiple parame", "ters (1)\n";

    my @array = ("o", "k 3 - print with multiple parameters (2)\n");
    print @array;
}

{
    my $arrayref = (<ok 4 - print stringifies its args>, "\n");
    print $arrayref;
}

{
   "ok 5 - method form of print\n".print;
}

{
    print "o";
    print "k 6 - print doesn't add newlines\n";
}

# Perl6::Spec::IO mentions
# print FILEHANDLE: LIST
# FILEHANDLE.print(LIST)
#  FILEHANDLE.print: LIST
#  same holds for say, even though it is not (yet?) explicitly mentioned

{
    #?niecza emit #
    print $*OUT: 'ok 7 - print with $*OUT: as filehandle' ~ "\n";
    #?niecza emit #
    say $*OUT: 'ok 8 - say with $*OUT: as filehandle';
    #?niecza emit print "not ok 7 # TODO\n";
    #?niecza emit print "not ok 8 # TODO\n";
}

{
    $*OUT.print: 'ok 9 - $*OUT.print: list' ~ "\n";
    $*OUT.say: 'ok 10 - $OUT.say: list';

}

{
    my @array = 'ok', ' ',  '11 - $*OUT.print(LIST)', "\n";
    $*OUT.print(@array);
}

{
    my @array = 'ok', ' ',  '12 - $*OUT.say(LIST)';
    $*OUT.say(@array);
}



# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/quoting-syntax.t�������������������������������������������������������0000664�0001750�0001750�00000002072�12224265625�020164� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 11;
# L<S16::IO/IO/=head2 Special Quoting Syntax>

# basic
#?rakudo skip "two terms in a row / unrecognized adverb"
{
	#?niecza 2 skip "Unhandled exception"
	isa_ok qp{/path/to/file}, IO::Path;
	isa_ok q:p{/path/to/file}, IO::Path;
	is qp{/path/to/file}.path, "/path/to/file";
	is q:p{/path/to/file}.path, "/path/to/file";
}

#with interpolation
#?rakudo skip "undeclared routine / urecognized adverb"
{
	my $dir = "/tmp";
	my $file = "42";
	#?niecza skip "too late for: qq"
	isa_ok qp:qq{$dir/$file}, IO::Path;
	isa_ok qq:p{$dir/$file}, IO::Path;

	#?niecza skip "too late for: qq"
	is qp:qq{$dir/$file}.path, "/tmp/42";
	is qq:p{$dir/$file}.path, "/tmp/42";
}

# :win constraints
#?rakudo skip "two terms in a row"
#?niecza skip "confused"
{
	isa_ok p:win{C:\Program Files\MS Access\file.file}, IO::Path;

	# backlash quoting should be disabled
	ok p:win{c:\no}.path ~~ /no$/;
}

# :unix constraints
#?rakudo skip "Unsupported use of /s"
#?niecza skip "Unsupported use of suffix regex modifiers"
{
	isa_ok p:unix{/usr/src/bla/myfile?:%.file}, IO::Path;
}

����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/say-and-ref.t����������������������������������������������������������0000664�0001750�0001750�00000000746�12224265625�017266� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push: 't/spec/packages' }
use Test::Util;

plan 3;


is_run q{my $a = [1, 2, 3]; say   $a},
    {
        out     => "1 2 3\n",
        err     => '',
        status  => 0,
    }, 'Can say array ref';

is_run q{my $a = [1, 2, 3]; print  $a},
    {
        out     => "1 2 3",
        err     => '',
        status  => 0,
    }, 'Can print array ref';

# RT #80186
is_run q{IO.say},
    {
        out => "(IO)\n";
    }, 'Can do IO.say';

# vim: ft=perl6
��������������������������rakudo-2013.12/t/spec/S16-io/say.t������������������������������������������������������������������0000664�0001750�0001750�00000001253�12224265625�015746� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S32::IO/IO/=item say>

# doesn't use Test.pm and plan() intentionally

say "1..8";

# Tests for say
{
    say "ok 1 - basic form of say";
}

{
    say "o", "k 2 - say with multiple parame", "ters (1)";

    my @array = ("o", "k 3 - say with multiple parameters (2)");
    say |@array;
}

{
    my $arrayref = <ok 4 - say stringifies its args>;
    say $arrayref;
}

{
    "ok 5 - method form of say".say;
}

$*OUT.say('ok 6 - $*OUT.say(...)');

"ok 7 - Mu.print\n".print;

grammar A {
    token TOP { .+ };
}

#?pugs   emit if 0 {
A.parse("ok 8 - Match.print\n").print;
#?pugs   emit }

#?pugs   emit say 'ok 8 # SKIP method .print not found in Match';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/test-data��������������������������������������������������������������0000664�0001750�0001750�00000000160�12224265625�016572� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Please do not remove this file, used by S16-io/basic-open.t
Please don't change it either.
This is a test line.
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-io/tmpdir.t���������������������������������������������������������������0000664�0001750�0001750�00000000253�12224265625�016450� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;

# L<S16/IO/$*TMPDIR>

plan 3;

isa_ok $*TMPDIR, IO::Path;
lives_ok { $*TMPDIR.perl }, '$*TMPDIR.perl works';
lives_ok { $*TMPDIR.gist }, '$*TMPDIR.gist works';
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-unfiled/getpeername.t�����������������������������������������������������0000664�0001750�0001750�00000000376�12241704255�020466� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# old: L<S16/"Unfiled"/"IO.getpeername">
# L<S32::IO/IO::Socket/getpeername>

=begin pod

IO.getpeername test

=end pod

plan 1;

my $sock = connect('google.com', 80);
ok $sock.getpeername.defined, "IO.getpeer works";

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S16-unfiled/rebindstdhandles.t������������������������������������������������0000664�0001750�0001750�00000001463�12224265625�021511� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 2;

sub nonce () { return ".{$*PID}." ~ (1..1000).pick() }
my $filename = 'tempfile_rebindstdhandles' ~ nonce();

# Test for re-binding $*OUT.
#?rakudo skip 'contextual rebinding regression'
{
    my $old_out := $*OUT;
    $*OUT := open($filename, :w);
    print "OH ";
    say "HAI!";
    $*OUT.close();
    $*OUT := $old_out;

    is(slurp($filename), "OH HAI!\n", 'rebound $*OUT to file handle OK');
    
    unlink($filename);
}

# Test for re-binding $*ERR.
#?rakudo skip 'contextual rebinding regression'
{
    my $old_err := $*ERR;
    $*ERR := open($filename, :w);
    warn("OH NOES OUT OF CHEEZBURGER\n");
    $*ERR.close();
    $*ERR := $old_err;

    is(slurp($filename), "OH NOES OUT OF CHEEZBURGER\n", 'rebound $*ERR to file handle OK');

    unlink($filename);
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S17-async/async.t�������������������������������������������������������������0000664�0001750�0001750�00000004466�12224265625�017007� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 17;

# L<S17/Threads>
# try to stop duration of a simple async call
my $timestamp = time;

async {
    ok 1, 'async call started';
};

my $async_duration = time - $timestamp;

# now if the follwing call is really asynchron, next time stop should
# be smaller than C<$async_duration + .5>

$timestamp = time;
my $thr = async {
    sleep .1;
};

ok time - $timestamp  < $async_duration + .5, "yes, 'Im out of sync!";

ok ~$thr, 'stringify a thread';

ok +$thr, 'numerify a thread should be the thread id';

isnt +$thr, $*PID, 'childs id is not parents thread id';

ok $thr.join, 'thread now joined and back home';

# L<S17/"Thread methods"/"=item join">
# two async calls should do something important
sub do_something_very_important {
    return 1;
}

my @threads;
#?pugs skip 'async tests report wrong number sometimes'
@threads[0] = async { ok do_something_very_important(),'very important things from first thread' };
#?pugs skip 'async tests report wrong number sometimes'
@threads[1] = async { ok do_something_very_important(),'very important things from second thread' };


#?pugs skip 'async tests report wrong number sometimes'
ok  @threads[0].join,'first thread joined';
#?pugs skip 'async tests report wrong number sometimes'
ok  @threads[1].join,'second thread joined';
# currently a second join on a joined thread waits forever; not good
#?pugs skip 'async tests report wrong number sometimes'
ok  eval q{#!@threads[1].join},'second thread not joinable again';

# L<S17/"Thread methods"/"=item detach">
#?pugs skip 'async tests report wrong number sometimes'
@threads[2] = async { ok do_something_very_important(),'again start a thread' };
#?pugs skip 'async tests report wrong number sometimes'
ok eval q{threads[2].detach},'detach a thread';
#?pugs skip 'async tests report wrong number sometimes'
ok !@threads[2].join,'could not join a detached thread';

# L<S17/"Thread methods"/"=item suspend">
#?pugs skip 'async tests report wrong number sometimes'
@threads[3] = async { ok do_something_very_important(),'another thread' };
#?pugs skip 'async tests report wrong number sometimes'
ok eval q{@threads[3].suspend},' send him back to a waiting room..';

# L<S17/"Thread methods"/"=item resume">
#?pugs skip 'async tests report wrong number sometimes'
ok eval q{@threads[3].resume},'... now he is back';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S17-async/contend.t�����������������������������������������������������������0000664�0001750�0001750�00000003744�12224265625�017322� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 7;

# simple contend/maybe/defer
sub atomic_sub {
    state $state = 1;
    contend {  ++$state };
    return $state;
}

ok atomic_sub(), 'contend works';
is atomic_sub(), 2, 'contend preserves state';

# try to construct race condition
# see Stevens 'UNIX network programming', 23.17, threads/example01
my $counter = 0;
sub doit {
    my $val;
    loop (my $i = 0; $i < 500; $i++) {
        $val = $counter; $counter = $val + 1;
    }
    return $counter;
}
my @thr = gather {
    take async { doit(); };
    take async { doit(); };
}
is  +@thr, 2, 'one thousand threads';

for @thr { .join(); }; # all threads back

#?pugs skip 'race condition hits about 50% of the time'
ok $counter < 1000, 'the race condition strikes' or diag($counter);


$counter = 0; # new counter because not all threads should be back

# L<S17/Atomic Code blocks>
# now start making C<sub doit> a atomic function
sub doit_right {
    my $val;
    loop (my $i = 0; $i < 500; $i++) {
        contend { $val = $counter; $counter = $val + 1; };
    }
    return $counter;
}

# now raising counter using the protected contend block
my @atomic_thr = gather {
    take async { doit_right(); };
    take async { doit_right(); };
}
for @atomic_thr { .join(); }; # bring them home

is $counter, 1000, 'now we reach the end';

my @cache = ();
#  STM tests on arrays
#?pugs todo 'unimpl'
ok eval( q{
    contend { @cache.push( 42 ) };
} ),'method <contend> for arrays; <push> should be safe';

my %cache = ();
#  STM tests on hahses
#?pugs todo 'unimpl'
ok eval( q{
    contend { %cache{ 42 } == 1 };
} ),'method <contend> for hashes; insert should be safe';

=begin comment

Copied as a reminder for me from the IRC log.

http://irclog.perlgeek.de/perl6/2008-02-09
 
01:42
	TimToady
	mugwump: mostly we won't be using async {...} or locks, I hope

01:43
	TimToady
	most of the threading will be done by gather/take, lazy lists, and ==> operators
	and most of the (non)-locking will be handled by STM

=end comment

# vim: ft=perl6
����������������������������rakudo-2013.12/t/spec/S17-async/syntax.t������������������������������������������������������������0000664�0001750�0001750�00000001167�12224265625�017213� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 4;

# L<S17/Atomic Code blocks>
my ($x, $y);
sub c {
    $x -= 3; $y += 3;
    $x < 10 or defer;
}
sub d {
    $x += 3; $y -= 3;
    $y < 10 or defer;
}
#?pugs todo 'unimpl'
ok eval( q{
contend {
    # ...
    maybe { c() } maybe { d() };
    # ...
} } )
    ,'contend/maybe/defer construct';
# L<S17/Atomic Code blocks/maybe>
#?pugs todo 'unimpl'
ok eval( q{
    maybe { c() };
} ),'method <maybe> known';

# L<S17/Atomic Code blocks/defer>
ok c(),'method <defer> known';

# L<S17/Atomic Code blocks/contend>
sub e {
    my $x; return ++$x;
}
ok contend { e(); },'method <contend> known';

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S17-concurrency/channel.t�����������������������������������������������������0000664�0001750�0001750�00000001751�12250462647�020513� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

{
    my Channel $c .= new;
    $c.send(1);
    $c.send(2);
    is $c.receive, 1, "Received first value";
    is $c.poll, 2, "Polled for second value";
    ok $c.poll === Nil, "poll returns Nil when no values available";
}

{
    my $c = Channel.new;
    $c.send(42);
    $c.close();
    nok $c.closed, "Channel not closed before value received";
    is $c.receive, 42, "Received value";
    ok $c.closed, "Channel closed after all values received";
    dies_ok { $c.receive }, "Receiving from closed channel throws";
}

{
    my $c = Channel.new;
    $c.send(1);
    $c.fail("oh noes");
    is $c.receive, 1, "received first value";
    dies_ok { $c.receive }, "error thrown on receive";
    is $c.closed.cause.message, "oh noes", "failure reason conveyed";
}

{
    my $p = Supply.for(1..5);
    is ~$p.Channel.list, "1 2 3 4 5", "Supply.for and .Channel work";
}

{
    my $p = Supply.for(1..5);
    is ~@($p.Channel), "1 2 3 4 5", "Supply.for and @(.Channel) work";
}
�����������������������rakudo-2013.12/t/spec/S17-concurrency/lock.t��������������������������������������������������������0000664�0001750�0001750�00000001773�12241704255�020031� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

{
    my $l = Lock.new;
    $l.protect({
        pass "Running code under lock";
    });
    $l.protect({
        pass "Running another piece of code under lock";
    });
}

{
    my $l = Lock.new;
    dies_ok { $l.protect({ die "oops" }) }, "code that dies under lock throws";
    $l.protect({
        pass "Code that dies in run does release the lock";
    });
    Thread.start({
        $l.protect({
            pass "Even from another thread";i
        });
    }).finish();
}

{
    # Attempt to check lock actually enforces some locking.
    my $output = '';
    my $l = Lock.new;
    my $t1 = Thread.start({
        $l.protect({ 
            for 1..10000 {
                $output ~= 'a'
            }
        });
    });
    my $t2 = Thread.start({
        $l.protect({ 
            for 1..10000 {
                $output ~= 'b'
            }
        });
    });
    $t1.finish;
    $t2.finish;
    ok $output ~~ /^ [ a+: b+: | b+: a+: ] $/, 'Lock is at least somewhat effective'; 
}
�����rakudo-2013.12/t/spec/S17-concurrency/promise.t�����������������������������������������������������0000664�0001750�0001750�00000011660�12250462647�020561� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 64;

{
    my $p = Promise.new;
    is $p.status, Planned, "Newly created Promise has Planned status";
    nok $p.Bool, "Newly created Promise has now result yet";
    nok ?$p, "Newly created Promise is false";
    dies_ok { $p.cause }, "Cannot call cause on a Planned Promise";
    
    $p.keep("kittens");
    is $p.status, Kept, "Kept Promise has Kept status";
    ok $p.Bool, "Kept Promise has a result";
    ok ?$p, "Kept Promise is true";
    is $p.result, "kittens", "Correct result";
    
    dies_ok { $p.cause }, "Cannot call cause on a Kept Promise";
    dies_ok { $p.keep("eating") }, "Cannot re-keep a Kept Promise";
    dies_ok { $p.break("bad") }, "Cannot break a Kept Promise";
}

{
    my $p = Promise.new;
    $p.break("glass");
    is $p.status, Broken, "Broken Promise has Broken status";
    ok $p.Bool, "Broken Promise has a result";
    ok ?$p, "Broken Promise is true";
    isa_ok $p.cause, Exception, "cause returns an exception";
    is $p.cause.message, "glass", "Correct message";
    dies_ok { $p.result }, "result throws exception";
    
    dies_ok { $p.keep("eating") }, "Cannot keep a Broken Promise";
    dies_ok { $p.break("bad") }, "Cannot re-break a Broken Promise";
}

{
    my $p = Promise.start({
        pass "Promise.start actually runs";
        42
    });
    is $p.result, 42, "Correct result";
    is $p.status, Kept, "Promise was kept";
}

{
    my $p = start {
        pass "Promise.start actually runs";
        42
    };
    is $p.result, 42, "Correct result";
    is $p.status, Kept, "Promise was kept";
}

{
    my $p = Promise.start({
        pass "Promise.start actually runs";
        die "trying"
    });
    dies_ok { $p.result }, "result throws exception";
    is $p.status, Broken, "Promise was broken";
    is $p.cause.message, "trying", "Correct exception stored";
}

{
    my $start = now;
    my $p = Promise.in(1);
    is $p.result, True, "Promise.in result is True";
    ok now - $start >= 1, "Promise.in took long enough";
}

{
    my $run_then = 0;
    my $p1 = Promise.new;
    my $p2 = $p1.then(-> $res {
        $run_then = 1;
        ok $res === $p1, "Got correct Promise passed to then";
        is $res.status, Kept, "Promise passed to then was kept";
        is $res.result, 42, "Got correct result";
        101
    });
    isa_ok $p2, Promise, "then returns a Promise";
    is $run_then, 0, "Not run then yet";
    
    $p1.keep(42);
    is $p2.result, 101, "Got correct result from then Promise";
    ok $run_then, "Certainly ran the then";
}

{
    my $p1 = Promise.new;
    my $p2 = $p1.then(-> $res {
        ok $res === $p1, "Got correct Promise passed to then";
        is $res.status, Broken, "Promise passed to then was broken";
        is $res.cause.message, "we fail it", "Got correct cause";
        "oh noes"
    });
    
    $p1.break("we fail it");
    is $p2.result, "oh noes", "Got correct result from then Promise";
}

{
    my $run_then = 0;
    my $p1 = Promise.new;
    my $p2 = $p1.then(-> $res {
        die "then died"
    });

    $p1.keep(42);
    dies_ok { $p2.result }, "result from then Promise dies";
    is $p2.status, Broken, "then Promise is broken";
    is $p2.cause.message, "then died", "then Promise has correct cause";
}

{
    my $p1 = Promise.new;
    my $p2 = Promise.new;
    my $pany = Promise.anyof($p1, $p2);
    isa_ok $pany, Promise, "anyof returns a Promise";
    nok $pany.Bool, "No result yet";
    
    $p1.keep(1);
    is $pany.result, True, "result is true";
    is $pany.status, Kept, "Promise was kept";
    
    $p2.break("fail");
    is $pany.status, Kept, "Other promise breaking doesn't affect status";
}

{
    my $p1 = Promise.new;
    my $p2 = Promise.new;
    my $pany = Promise.anyof($p1, $p2);
    
    $p2.break("oh noes");
    dies_ok { $pany.result }, "Getting result of broken anyof dies";
    is $pany.status, Broken, "Promise was broken";
    is $pany.cause.message, "oh noes", "breakage reason conveyed";
    
    $p1.keep(1);
    is $pany.status, Broken, "Other promise keeping doesn't affect status";
}

{
    my $p1 = Promise.new;
    my $p2 = Promise.new;
    my $pall = Promise.allof($p1, $p2);
    isa_ok $pall, Promise, "allof returns a Promise";
    nok $pall.Bool, "No result yet";
    
    $p1.keep(1);
    nok $pall.Bool, "Still not kept";
    
    $p2.keep(1);
    is $pall.result, True, "result is true after both kept";
    is $pall.status, Kept, "Promise was kept";
}

{
    my @p;
    @p[0] = Promise.new;
    @p[1] = Promise.new;
    my $pall = Promise.allof(@p);
    @p[0].keep(1);
    @p[1].break("danger danger");
    dies_ok { $pall.result }, "result on broken all-Promise throws";
    is $pall.status, Broken, "all-Promise was broken";
}

{
    my @a;
    my @p = (^10).pick(*).map: { start { sleep $_; @a.push: $_ } };
    my $all = Promise.allof(@p);
    isa_ok $all, Promise, 'allof gives a Promise';
    my $b = $all.result;  # block
    isa_ok $b, Bool, 'get a bool of the result';
    is ~@a, "0 1 2 3 4 5 6 7 8 9", 'got the right order';
}
��������������������������������������������������������������������������������rakudo-2013.12/t/spec/S17-concurrency/scheduler.t���������������������������������������������������0000664�0001750�0001750�00000022217�12253134031�021043� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 54;

# real scheduling here
my $name = $*SCHEDULER.^name;
ok $*SCHEDULER ~~ Scheduler, "$name does Scheduler role";

{
    my $x = False;
    $*SCHEDULER.cue({
        pass "Cued code on $name ran";
        $x = True;
    });
    1 while $*SCHEDULER.loads;
    ok $x, "Code was cued to $name by default";
}

{
    my $message;
    $*SCHEDULER.uncaught_handler = sub ($exception) {
        $message = $exception.message;
    };
    $*SCHEDULER.cue({ die "oh noes" });
    1 while $*SCHEDULER.loads;
    is $message, "oh noes", "$name setting uncaught_handler works";
}

{
    my $tracker;
    $*SCHEDULER.cue(
      { $tracker = 'cued,'; die "oops" },
      :catch( -> $ex {
          is $ex.message, "oops", "$name passed correct exception to handler";
          $tracker ~= 'caught';
      })
    );
    1 while $*SCHEDULER.loads;
    is $tracker, "cued,caught", "Code run on $name, then handler";
}

{
    my $tracker;
    $*SCHEDULER.cue(
        { $tracker = 'cued,' },
        :catch( -> $ex { $tracker ~= 'caught' })
    );
    1 while $*SCHEDULER.loads;
    is $tracker, "cued,", "Catch handler on $name not run if no error";
}

{
    # Timing related tests are always a tad fragile, e.g. on a loaded system.
    # Hopefully the times are enough leeway.
    my $tracker = '';
    $*SCHEDULER.cue({ $tracker ~= '2s'; }, :in(2));
    $*SCHEDULER.cue({ $tracker ~= '1s'; }, :in(1));
    is $tracker, '', "Cue on $name with :in doesn't schedule immediately";
    sleep 3;
    is $tracker, "1s2s", "Timer tasks on $name with :in ran in right order";
}

{
    my $tracker = '';
    $*SCHEDULER.cue(
      { $tracker ~= '2s'; },
      :in(2),
      :catch({ $tracker ~= '2scatch'})
    );
    $*SCHEDULER.cue(
      { $tracker ~= '1s'; die },
      :in(1),
      :catch({ $tracker ~= '1scatch'})
    );
    is $tracker, '', "Cue on $name with :in/:catch doesn't schedule immediately";
    sleep 3;
    is $tracker, "1s1scatch2s", "Timer tasks on $name:in/:catch ran in right order";
}

{
    my $tracker = '';
    $*SCHEDULER.cue({ $tracker ~= '2s'; }, :at(now + 2));
    $*SCHEDULER.cue({ $tracker ~= '1s'; }, :at(now + 1));
    is $tracker, '', "Cue on $name with :at doesn't schedule immediately";
    sleep 3;
    is $tracker, "1s2s", "Timer tasks on $name with :at ran in right order";
}

{
    my $tracker = '';
    $*SCHEDULER.cue(
      { $tracker ~= '2s'; die },
      :at(now + 2),
      :catch({ $tracker ~= '2scatch'})
    );
    $*SCHEDULER.cue(
      { $tracker ~= '1s'; },
      :at(now + 1),
      :catch({ $tracker ~= '1scatch'})
    );
    is $tracker, '', "Cue on $name with :at/:catch doesn't schedule immediately";
    sleep 3;
    is $tracker, "1s2s2scatch", "Timer tasks on $name :at/:catch ran in right order";
}

{
    # Also at risk of being a little fragile, but again hopefully Ok on all
    # but the most ridiculously loaded systems.
    my $a = 0;
    $*SCHEDULER.cue({ $a++ }, :every(0.1));
    sleep 1;
    diag "seen $a runs"
      if !ok 5 < $a < 15, "Cue with :every schedules repeatedly";
}

{
    # Also at risk of being a little fragile, but again hopefully Ok on all
    # but the most ridiculously loaded systems.
    my $a = 0;
    my $b = 0;
    $*SCHEDULER.cue({ $a++; die }, :every(0.1), :catch({ $b++ }));
    sleep 1;
    diag "seen $a runs"
      if !ok 5 < $a < 15, "Cue with :every/:catch schedules repeatedly (1)";
    diag "seen $b deaths"
      if !ok 5 < $b < 15, "Cue with :every/:catch schedules repeatedly (2)";
}

{
    my $a = 0;
    $*SCHEDULER.cue({ $a++ }, :in(2), :every(0.1));
    sleep 3;
    diag "seen $a runs" if !ok 5 < $a < 15,
      "Cue with :every/:in schedules repeatedly";
}

{
    my $a = 0;
    my $b = 0;
    $*SCHEDULER.cue({ $a++; die }, :in(2), :every(0.1), :catch({ $b++ }));
    sleep 3;
    diag "seen $a runs" if !ok 5 < $a < 15,
      "Cue with :every/:in/:catch schedules repeatedly (1)";
    diag "seen $b deaths" if !ok 5 < $b < 15,
      "Cue with :every/:in/:catch schedules repeatedly (2)";
}

{
    my $a = 0;
    $*SCHEDULER.cue({ $a++ }, :at(now + 2), :every(0.1));
    sleep 3;
    diag "seen $a runs" if !ok 5 < $a < 15,
      "Cue with :every/:at schedules repeatedly";
}

{
    my $tracker;
    $*SCHEDULER.cue({ $tracker++ }, :times(10));
    sleep 3;
    is $tracker, 10, "Cue on $name with :times(10)";
}

{
    my $a = 0;
    my $b = 0;
    $*SCHEDULER.cue({ $a++; die }, :at(now + 2), :every(0.1), :catch({ $b++ }));
    sleep 3;
    diag "seen $a runs" if !ok 5 < $a < 15,
      "Cue with :every/:at/:catch schedules repeatedly (1)";
    diag "seen $b deaths" if !ok 5 < $b < 15,
      "Cue with :every/:at/:catch schedules repeatedly (2)";
}

{
    dies_ok { $*SCHEDULER.cue({ ... }, :at(now + 2), :in(1)) },
      "$name cannot combine :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :at(now + 2), :in(1)) },
      "$name cannot combine :every with :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :at(now + 2), :in(1)), :catch({...}) },
      "$name cannot combine :catch with :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :at(now + 2), :in(1)), :catch({...}) },
      "$name cannot combine :every/:catch with :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10)) },
      "$name cannot combine :every and :times";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10), :at(now + 2)) },
      "$name cannot combine :every and :times with :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10), :in(1)) },
      "$name cannot combine :every and :times with :in";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10), :catch({...})) },
      "$name cannot combine :every and :times with :catch";
}

# fake scheduling from here on out
$*SCHEDULER = CurrentThreadScheduler.new;
$name = $*SCHEDULER.^name;
ok $*SCHEDULER ~~ Scheduler, "{$*SCHEDULER.^name} does Scheduler role";

{
    my $x = False;
    $*SCHEDULER.cue({
        pass "Cued code on $name ran";
        $x = True;
    });
    1 while $*SCHEDULER.loads;
    ok $x, "Code was cued to $name by default";
}

{
    my $message;
    $*SCHEDULER.uncaught_handler = sub ($exception) {
        $message = $exception.message;
    };
    $*SCHEDULER.cue({ die "oh noes" });
    1 while $*SCHEDULER.loads;
    is $message, "oh noes", "$name setting uncaught_handler works";
}

{
    my $tracker;
    $*SCHEDULER.cue(
      { $tracker = 'cued,'; die "oops" },
      :catch( -> $ex {
          is $ex.message, "oops", "$name passed correct exception to handler";
          $tracker ~= 'caught';
      })
    );
    1 while $*SCHEDULER.loads;
    is $tracker, "cued,caught", "Code run on $name, then handler";
}

{
    my $tracker;
    $*SCHEDULER.cue(
        { $tracker = 'cued,' },
        :catch( -> $ex { $tracker ~= 'caught' })
    );
    1 while $*SCHEDULER.loads;
    is $tracker, "cued,", "Catch handler on $name not run if no error";
}

{
    my $tracker = '';
    $*SCHEDULER.cue({ $tracker ~= '2s'; }, :in(2));
    $*SCHEDULER.cue({ $tracker ~= '1s'; }, :in(1));
    is $tracker, '2s1s', "Cue on $name with :in *DOES* schedule immediately";
}

{
    my $tracker = '';
    $*SCHEDULER.cue(
      { $tracker ~= '2s'; },
      :in(2),
      :catch({ $tracker ~= '2scatch'})
    );
    $*SCHEDULER.cue(
      { $tracker ~= '1s'; die },
      :in(1),
      :catch({ $tracker ~= '1scatch'})
    );
    is $tracker, '2s1s1scatch', "Cue on $name with :in/:catch *DOES* schedule immediately";
}

{
    my $tracker = '';
    $*SCHEDULER.cue({ $tracker ~= '2s'; }, :at(now + 2));
    $*SCHEDULER.cue({ $tracker ~= '1s'; }, :at(now + 1));
    is $tracker, '2s1s', "Cue on $name with :at *DOES* schedule immediately";
}

{
    my $tracker;
    $*SCHEDULER.cue({ $tracker++ }, :times(10));
    sleep 5;
    is $tracker, 10, "Cue on $name with :times(10)";
}

{
    my $tracker = '';
    $*SCHEDULER.cue(
      { $tracker ~= '2s'; die },
      :at(now + 2),
      :catch({ $tracker ~= '2scatch'})
    );
    $*SCHEDULER.cue(
      { $tracker ~= '1s'; },
      :at(now + 1),
      :catch({ $tracker ~= '1scatch'})
    );
    is $tracker, '2s2scatch1s', "Cue on $name with :at/:catch *DOES* schedule immediately";
}

{
    dies_ok { $*SCHEDULER.cue({ ... }, :every(1)) },
      "$name cannot specify :every in CurrentThreadScheduler";
    dies_ok { $*SCHEDULER.cue({ ... }, :at(now + 2), :in(1)) },
      "$name cannot combine :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :at(now + 2), :in(1)) },
      "$name cannot combine :every with :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :at(now + 2), :in(1)), :catch({...}) },
      "$name cannot combine :catch with :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :at(now + 2), :in(1)), :catch({...}) },
      "$name cannot combine :every/:catch with :in and :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10)) },
      "$name cannot combine :every and :times";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10), :at(now + 2)) },
      "$name cannot combine :every and :times with :at";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10), :in(1)) },
      "$name cannot combine :every and :times with :in";
    dies_ok { $*SCHEDULER.cue({ ... }, :every(0.1), :times(10), :catch({...})) },
      "$name cannot combine :every and :times with :catch";
}
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S17-concurrency/supply.t������������������������������������������������������0000664�0001750�0001750�00000004737�12247420047�020440� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 16;

{
    my $p = Supply.new;
    
    my @vals;
    my $saw_done;
    my $tap = $p.tap( -> $val { @vals.push($val) },
      done => { $saw_done = True });

    $p.more(1);
    is ~@vals, "1", "Tap got initial value";
    nok $saw_done, "No done yet";
    
    $p.more(2);
    $p.more(3);
    $p.done;
    is ~@vals, "1 2 3", "Tap saw all values";
    ok $saw_done, "Saw done";
}

{
    my $p = Supply.new;
    
    my @tap1_vals;
    my @tap2_vals;
    my $tap1 = $p.tap(-> $val { @tap1_vals.push($val) });
    
    $p.more(1);
    is ~@tap1_vals, "1", "First tap got initial value";
    
    my $tap2 = $p.tap(-> $val { @tap2_vals.push($val) });
    $p.more(2);
    is ~@tap1_vals, "1 2", "First tap has both values";
    is ~@tap2_vals, "2", "Second tap missed first value";
    
    $tap1.close;
    $p.more(3);
    is ~@tap1_vals, "1 2", "First tap closed, missed third value";
    is ~@tap2_vals, "2 3", "Second tap gets third value";
}

{
    my $p = Supply.for(1..10, :scheduler(CurrentThreadScheduler));
    
    my @a1;
    my $tap1 = $p.tap( -> $val { @a1.push($val) },
      done => { @a1.push("end") });
    is ~@a1, "1 2 3 4 5 6 7 8 9 10 end", "Synchronous publish worked";
    
    my @a2;
    my $tap2 = $p.tap( -> $val { @a2.push($val) },
      done => { @a2.push("end") });
    is ~@a2, "1 2 3 4 5 6 7 8 9 10 end", "Second tap also gets all values";
}

#?rakudo skip "hangs"
{
    my $p = Supply.for(2..6);
    my @a;
    for $p.list {
        @a.push($_);
    }
    is ~@a, "2 3 4 5 6", "Supply.for and .list work";
}

{
    my $p1 = Supply.new;
    my $p2 = Supply.new;

    my @res;
    my $tap = $p1.zip($p2, &infix:<~>).tap({ @res.push($_) });

    $p1.more(1);
    $p1.more(2);
    $p2.more('a');
    $p2.more('b');
    $p2.more('c');
    $p1.done();
    $p2.done();
    
    is @res.join(','), '1a,2b', 'zipping taps works';
}

{
    my $p1 = Supply.new;
    my $p2 = Supply.new;

    my @res;
    my $tap = $p1.merge($p2).tap({ @res.push($_) });

    $p1.more(1);
    $p1.more(2);
    $p2.more('a');
    $p1.more(3);
    $p1.done();
    $p2.more('b');
    
    is @res.join(','), '1,2,a,3,b', "merging taps works";
}

{
    my $p1 = Supply.for(1..10, :scheduler(CurrentThreadScheduler));
    my @res;
    $p1.grep(* > 5).tap({ @res.push($_) });
    is ~@res, '6 7 8 9 10', "grepping taps works";
}

{
    my $p1 = Supply.for(1..5, :scheduler(CurrentThreadScheduler));
    my @res;
    $p1.map(2 * *).tap({ @res.push($_) });
    is ~@res, '2 4 6 8 10', "mapping taps works";
}
���������������������������������rakudo-2013.12/t/spec/S17-concurrency/thread.t������������������������������������������������������0000664�0001750�0001750�00000006232�12241704255�020343� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 25;

{
    my $t = Thread.start({ 1 });
    isa_ok $t, Thread;
    $t.finish;
}

{
    my $t = Thread.start({
        pass "Code in thread ran";
    });
    $t.finish;
    pass "Thread was finished";
}

{
    my $tracker;
    my $t = Thread.start({
        $tracker = "in thread,";
    });
    $t.finish;
    $tracker ~= "finished";
    is $tracker, "in thread,finished", "Thread.finish does block";
}

{
    # This test is a vulnerable to freak conditions, like closing your laptop
    # at the exact wrong time. Also, if this test file hangs for ages at exit,
    # something is probably wrong with regard to this test.
    my $start = now;
    my $alt = Thread.start({ sleep 10000 }, :app_lifetime);
    ok now - $start < 10, "Starting app_lifetime thread that sleeps won't block main thread";
}

{
    my ($a, $b);
    my $t1 = Thread.start({ $a = 21 });
    my $t2 = Thread.start({ $b = 42 });
    isnt $t1.id, 0, "Thread 1 got non-zero ID";
    isnt $t2.id, 0, "Thread 2 got non-zero ID";
    isnt $t1.id, $t2.id, "Threads got different IDs";
    $t1.finish;
    $t2.finish;
    is $a, 21, "Thread 1 actually ran";
    is $b, 42, "Thread 2 also ran";
}

{
    my $t = Thread.start(:name("My little thready"), { 1 });
    is $t.name, "My little thready", "Has correct name";
    $t.finish;
    is $t.name, "My little thready", "Name doesn't vanish after finishing";
}

{
    my $t = Thread.start({ 1 });
    is $t.name, "<anon>", "Default thread name is <anon>";
    $t.finish;
}

{
    my $t1 = Thread.start({ 1 });
    ok $t1.Str ~~ /^ Thread '<' \d+ '>' '(<anon>)' $/,
        "Correct Thread stringification (anon case)";
    $t1.finish;
    my $t2 = Thread.start(:name('Magical threader'), { 1 });
    ok $t2.Str ~~ /^ Thread '<' \d+ '>' '(Magical threader)' $/,
        "Correct Thread stringification (name case)";
    $t2.finish;
}

{
    my ($t1id, $t2id);
    my $t1 = Thread.start({ $t1id = $*THREAD.id; });
    my $t2 = Thread.start({ $t2id = $*THREAD.id; });
    sleep 2; # wait for threads to start, a little fragile, yes
    is $t1id, $t1.id, 'Correct $*THREAD instance in thread 1 before finish';
    is $t2id, $t2.id, 'Correct $*THREAD instance in thread 2 before finish';
    $t1.finish;
    $t2.finish;
    is $t1id, $t1.id, 'Correct $*THREAD instance in thread 1 after finish';
    is $t2id, $t2.id, 'Correct $*THREAD instance in thread 2 after finish';
}

{
    isa_ok $*THREAD, Thread, '$*THREAD available in initial thread';
    isnt $*THREAD.id, 0, 'Initial thread has an ID';
}

{
    my $seen;
    my $threads = 3;
    my $times   = 10000;
    my @t = (1..$threads).map: { Thread.start({ $seen++ for ^$times}) };
    .finish for @t;
    ok 0 <= $seen <= $threads * $times, "we didn't segfault"
}

#?rakudo.jvm skip 'Hangs about 20% of the time'
{
    my %seen;
    my $threads = 3;
    my $times   = 10000;
    my @t = (1..$threads).map: { Thread.start({ %seen{$_}++ for ^$times}) };
    .finish for @t;
    ok 0 <= ([+] %seen.values) <= $threads * $times, "we didn't segfault";
    unless
      is +%seen.keys, $times, 'did we get all keys'
    { .say for %seen.pairs.sort }
    is +%seen.values.grep({ 1 <= $_ <= $threads }), $times,
      'are all values in range';
}
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S17-concurrency/winner.t������������������������������������������������������0000664�0001750�0001750�00000001475�12254646735�020416� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 4;

#?rakudo.parrot skip 'no implementation of promise/winner'
{
    my $p1 = Promise.in(1);
    my $p2 = Promise.in(2);
    my @seen;
    is( winner * {
        done $p1 { @seen.push: 'a'; 'first' }
        done $p2 { @seen.push: 'b'; 'second' }
    }, 'first', 'did we get the first promise' );
    is(winner * {
        done $p2 { @seen.push: 'b'; 'second' }
    }, 'second', 'did we get the second promise' );
    is ~@seen, 'a b', 'did promises fire in right order';
}

#?rakudo.parrot skip 'no implementation of supply/winner'
{
    my $p = Supply.for(1..5);
    my $c = $p.Channel;
    my @a;
    loop {
        winner $c {
            more * -> $val { @a.push($val) }
            done * -> { @a.push("done"); last }
        }
    }
    is ~@a, "1 2 3 4 5 done", "Publish.for and .Channel work";
}
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S19-command-line/dash-e.t�����������������������������������������������������0000664�0001750�0001750�00000001325�12224265625�020252� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 3;

BEGIN { @*INC.push: 't/spec/packages' }
use Test::Util;

my Str $x;
#?rakudo.jvm 3 skip "nigh"
is_run $x,  :args['-e', 'print q[Moin]'],
    {
        out     => 'Moin',
        err     => '',
        status  => 0,
    },
    '-e print $something works';

is_run $x,  :args['-e', "print q[\c[LATIN SMALL LETTER A WITH DOT ABOVE]]"],
    {
        out     => "\c[LATIN SMALL LETTER A WITH DOT ABOVE]",
        err     => '',
        status  => 0,
    },
    '-e print $something works with non-ASCII string literals';

is_run $x,  :args['-e', 'print <1 2> »+« <1 1>'],
    {
        out     => "23",
        err     => '',
        status  => 0,
    },
    '-e works with non-ASCII program texts';
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S19-command-line/help.t�������������������������������������������������������0000664�0001750�0001750�00000000401�12224265625�020033� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 1;

BEGIN { @*INC.push: 't/spec/packages' }
use Test::Util;

is_run Str,  :args['--help'],
    {
        out     => { .chars > 20 },
        err     => '',
        status  => 0,
    },
    '--help tells us something, and returns 0';

���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S19-command-line-options/01-dash-uppercase-i.t��������������������������������0000664�0001750�0001750�00000003505�12241704255�024150� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S19-command-line-options/01-multiple-e.t��������������������������������������0000664�0001750�0001750�00000002670�12241704255�023075� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Test evaluation of multiple C<-e> switches.

Multiple C<-e> switches are supposed to work just
like C<join "\n"> concatenation .

=end pod

# L<S19/Reference/"Execute a single-line program.">

my @examples = (
 '-e print -e qq.Hello -e Pugs.',
 '-e print -we qq.Hello -e Pugs.',
 '-e print -wle qq.Hello -e Pugs.',
 '-e print -weqq.Hello -e Pugs.',
 '-e print -e qq.Hel. -e ";print" -e qq.lo. -e ";print" -e "qq.\nPugs."',
 '-e print -e qq.Hel. -w -e ";print" -e qq.lo. -w -e ";print" -e "qq.\nPugs."',
);

plan +@examples +1;

diag "Running under $*OS";

my $redir = ">";

if $*OS eq any <MSWin32 mingw msys cygwin> {
  $redir = '>';
};

sub nonce () { return (".{$*PID}." ~ (1..1000).pick) }
my $out_fn = "temp-ex-output" ~ nonce;

for @examples -> $ex {
  my $command = "$*EXECUTABLE_NAME $ex $redir $out_fn";
  diag $command;
  run $command;

  my $expected = "Hello\nPugs";
  my $got      = slurp $out_fn;

  is $got, $expected, "Multiple -e switches work and append the script";
}

my $command = qq[$*EXECUTABLE_NAME -e @ARGS.perl.say -e "" Hello Pugs $redir $out_fn];
diag $command;
run $command;

my @expected = <Hello Pugs>;
my $got      = slurp $out_fn;
$got .= chomp;
if (substr($got,0,1) ~~ "\\") {
  $got = substr($got,1);
};

my @got      = eval $got;
# fail "FIXME platform specific";
# ??? Worksforme on win32 (CORION)
is @got, @expected, "-e '' does not eat a following argument";

unlink $out_fn;

# vim: ft=perl6
������������������������������������������������������������������������rakudo-2013.12/t/spec/S19-command-line-options/02-dash-n.t������������������������������������������0000664�0001750�0001750�00000001571�12241704255�022172� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Test -n implementation

The -n command line switch mimics the Perl5 -n command line
switch, and wraps the whole script in

  for (lines) {
    ...
  };

=end pod

# L<S19/Reference/"Act like awk.">

my @examples = (
  '-n -e .say',
  '-ne .say',
  '-e "" -ne .say',
);

plan +@examples;

diag "Running under $*OS";

my ($redir_in, $redir_out) = ("<", ">");

my $str = "
foo
bar
";

sub nonce () { return (".{$*PID}." ~ (1..1000).pick) }
my ($in_fn, $out_fn) = <temp-ex-input temp-ext-output> >>~>> nonce;
my $h = open("$in_fn", :w);
$h.print($str);
$h.close();

for @examples -> $ex {
  my $command = "$*EXECUTABLE_NAME $ex $redir_in $in_fn $redir_out $out_fn";
  diag $command;
  run $command;

  my $expected = $str;
  my $got      = slurp $out_fn;
  unlink $out_fn;

  is $got, $expected, "-n -e print works like cat";
}

unlink $in_fn;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S19-command-line-options/03-dash-p.t������������������������������������������0000664�0001750�0001750�00000001703�12241704255�022172� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Test C<-p> implementation

The C<-p> command line switch mimics the Perl5 C<-p> command line
switch, and wraps the whole script in

  for (lines) {
    ...         # your script
    .say;
  };

=end pod

# L<S19/Reference/"Act like sed.">

my @examples = (
  '-p',
  '-p "-e1;"',
  '-pe ";"',
  '-pe ""',
  '-p "-e1;" "-e1;"',
  '"-e1;" -p "-e1;"',
);

plan +@examples;

diag "Running under $*OS";

my ($redir_in,$redir_out) = ("<", ">");

my $str = "
foo
bar
";

sub nonce () { return (".{$*PID}." ~ (1..1000).pick) }
my ($in_fn, $out_fn) = <temp-ex-input temp-ext-output> >>~>> nonce;
my $h = open("$in_fn", :w);
$h.print($str);
$h.close();

for @examples -> $ex {
  my $command = "$*EXECUTABLE_NAME $ex $redir_in $in_fn $redir_out $out_fn";
  diag $command;
  run $command;

  my $expected = $str;
  my $got      = slurp $out_fn;
  unlink $out_fn;

  is $got, $expected, "$ex works like cat";
}

unlink $in_fn;

# vim: ft=perl6
�������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/0-compile.t�������������������������������������������������������0000664�0001750�0001750�00000000141�12224265625�017777� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# Checking that testing is sane: Test.pm

use Test;

plan 1;

my $x = '0';
ok $x == $x;
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/1-basic.t���������������������������������������������������������0000664�0001750�0001750�00000011122�12224265625�017432� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 60;

=begin kwid

This file /exhaustivily/ tests the Test module. 

I try every variant of each Test function here
because we are using this module to test Pugs itself, 
so I want to be sure that the error is not coming from 
within this module.

We need to test that these functions produce 'not ok' at the
right times, too.  Here, we do that by abusing :todo to mean
"supposed to fail."  Thus, no ":todo" failure indicates
a missing feature.

If there is a bug in the implementation, you will see
a (non-TODO) failure or an unexpected success.

=end kwid

## ok

ok(2 + 2 == 4, '2 and 2 make 4');
ok(2 + 2 == 4, desc => '2 and 2 make 4');
ok(2 + 2 == 4, :desc('2 and 2 make 4'));

ok(2 + 2 == 5, desc => '2 and 2 doesnt make 5', todo => <bug>);
ok(2 + 2 == 5, :desc('2 and 2 doesnt make 5'), :todo(1));

## is

is(2 + 2, 4, '2 and 2 make 4');
is(2 + 2, 4, desc => '2 and 2 make 4');
is(2 + 2, 4, :desc('2 and 2 make 4'));

is(2 + 2, 5, todo => 1, desc => '2 and 2 doesnt make 5');
is(2 + 2, 5, :todo<feature>, :desc('2 and 2 doesnt make 5'));

## isnt

isnt(2 + 2, 5, '2 and 2 does not make 5');
isnt(2 + 2, 5, desc => '2 and 2 does not make 5');
isnt(2 + 2, 5, :desc('2 and 2 does not make 5'));

isnt(2 + 2, 4, '2 and 2 does make 4', :todo(1));
isnt(2 + 2, 4, desc => '2 and 2 does make 4', todo => 1);
isnt(2 + 2, 4, :desc('2 and 2 does make 4'), todo => 1);

## is_deeply

is_deeply([ 1..4 ], [ 1..4 ],
          "is_deeply (simple)");

is_deeply({ a => "b", c => "d", nums => [<1 2 3 4 5 6>] },
          { nums => ['1'..'6'], <a b c d> },
          "is_deeply (more complex)");

my @a = "a" .. "z";
my @b = @a.reverse;
@b = @b.map(sub ($a, $b) { $b, $a });
my %a = @a;
my %b = @b;
is_deeply(%a, %b, "is_deeply (test hash key ordering)");

## isa_ok

my @list = ( 1, 2, 3 );

isa_ok(@list, 'List');
isa_ok({ 'one' => 1 }, 'Hash');

isa_ok(@list, 'Hash', 'this is a description', todo => 1);
isa_ok(@list, 'Hash', desc => 'this is a description', :todo<bug>);
isa_ok(@list, 'Array', :desc('this is a description'));

class Foo {};
my $foo = Foo.new();
isa_ok($foo, 'Foo');
isa_ok(Foo.new(), 'Foo');

## like

like("Hello World", rx:P5/\s/, '... testing like()');
like("Hello World", rx:P5/\s/, desc => '... testing like()');
like("Hello World", rx:P5/\s/, :desc('... testing like()'));

like("HelloWorld", rx:P5/\s/, desc => '... testing like()', todo => 1);
like("HelloWorld", rx:P5/\s/, :todo(1), :desc('... testing like()'));

## unlike

unlike("HelloWorld", rx:P5/\s/, '... testing unlike()');
unlike("HelloWorld", rx:P5/\s/, desc => '... testing unlike()');
unlike("HelloWorld", rx:P5/\s/, :desc('... testing unlike()'));

unlike("Hello World", rx:P5/\s/, todo => 1, desc => '... testing unlike()');
unlike("Hello World", rx:P5/\s/, :desc('... testing unlike()'), :todo(1));

## cmp_ok

cmp_ok('test', sub ($a, $b) { ?($a gt $b) }, 'me', '... testing gt on two strings');
cmp_ok('test', sub ($a, $b) { ?($a gt $b) }, 'me', desc => '... testing gt on two strings');
cmp_ok('test', sub ($a, $b) { ?($a gt $b) }, 'me', :desc('... testing gt on two strings'));

cmp_ok('test', sub ($a, $b) { ?($a gt $b) }, 'you', :todo(1), desc => '... testing gt on two strings');
cmp_ok('test', sub ($a, $b) { ?($a gt $b) }, 'you', :desc('... testing gt on two strings'), todo => 1);

## use_ok

use lib <ext/Test>; # Hack if we're run from make smoke
#?pugs todo
use_ok('t::use_ok_test');

# Need to do a test loading a package that is not there,
# and see that the load fails. Gracefully. :)
use_ok('Non::Existent::Package', :todo(1));

## dies_ok

dies_ok -> { die "Testing dies_ok" }, '... it dies_ok';
dies_ok -> { die "Testing dies_ok" }, desc => '... it dies_ok';
dies_ok -> { die "Testing dies_ok" }, :desc('... it dies_ok');

dies_ok -> { "Testing dies_ok" }, desc => '... it dies_ok', todo => 1;
dies_ok -> { "Testing dies_ok" }, :desc('... it dies_ok'), :todo(1);

## lives_ok

lives_ok -> { "test" }, '... it lives_ok';
lives_ok -> { "test" }, desc => '... it lives_ok';
lives_ok -> { "test" }, :desc('... it lives_ok');

lives_ok -> { die "test" }, desc => '... it lives_ok', todo => 1;
lives_ok -> { die "test" }, :desc('... it lives_ok'), :todo(1);


## throws_ok

#throws_ok -> { die "Testing throws_ok" }, 'Testing throws_ok', '... it throws_ok with a Str';
#throws_ok -> { die "Testing throws_ok" }, rx:P5:i/testing throws_ok/, '... it throws_ok with a Rule';

## diag

diag('some misc comments and documentation');

## pass

pass('This test passed');

## flunk

flunk('This test failed', todo => 1);
flunk('This test failed', :todo(1));

## skip

skip('skip this test for now');
skip('skip 3 more tests for now', 3);
skip_rest('skipping the rest');

1;

����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/2-force_todo.t����������������������������������������������������0000664�0001750�0001750�00000001241�12224265625�020476� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 11;

force_todo(1, 3, 5, 7 .. 9, 11);

flunk("This will fail, but will be forced-TODO by force_todo()"); 
pass("This will pass normally");
flunk("This will fail, but will be forced-TODO by force_todo()");
pass("This will pass normally");
flunk("This will TODO fail, and will be forced-TODO by force_todo()", :todo(1));
pass("This will pass normally");
flunk("This will fail, and will be forced-TODO by force_todo()");
flunk("This will fail, and will be forced-TODO by force_todo()");
flunk("This will fail, and will be forced-TODO by force_todo()");
pass("This will pass normally");
flunk("This will fail, and will be forced-TODO by force_todo()");
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/3-output.t��������������������������������������������������������0000664�0001750�0001750�00000001752�12224265625�017723� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# this test tests that the output (text output and return code) of
# test scripts are correct.

use v6;
use Test;

plan 1;

skip_rest("skipping because redirection is not portable"); exit;

# this test tests that various failure conditions (that we don't want
# to show up as failures) happen, and test the the output of the test
# suite is correct.

# ... copied from t/run/05-unknown-option.t, but it looks wrong :)
sub nonce () { return (".{$*PID}." ~ (1..1000).pick) }
my $out_fn = "temp-ex-output" ~ nonce;
my $redir_pre = "2>&1 >";
my $redir_post = "2>&1";
if $*OS eq any <MSWin32 mingw msys cygwin> {
    $redir_pre = ">";
    $redir_post = "";
};

my $file = $?FILE;
$file ~~ s:P5/output.t/script.pl/;
my $cmd = "$*EXECUTABLE_NAME $file $redir_pre $out_fn $redir_post";
%*ENV<TEST_ALWAYS_CALLER> = 0;

diag($cmd);
run($cmd);

my $output = slurp $out_fn;
unlink($out_fn);

is($output, "1..1
ok 1 - TODO that passes # TODO
# Looks like 1 tests of 1 passed unexpectedly
", "got correct output");

����������������������rakudo-2013.12/t/spec/S24-testing/3-script.pl�������������������������������������������������������0000664�0001750�0001750�00000000131�12224265625�020025� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������
use Test;

plan 1;

# here is a TODO test that passes
ok(1, "TODO that passes", :todo);
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/4-version_lt.t����������������������������������������������������0000664�0001750�0001750�00000000413�12224265625�020541� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 6;

ok Test::version_lt('6.2.12', '6.2.13');
ok Test::version_lt('6.2.13', '6.28.0');
ok Test::version_lt('6.2.13', '6.28');
ok Test::version_lt('0.42', '0.50');
ok Test::version_lt('0.001', '0.002');
ok Test::version_lt('-10.001', '0.000');
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/5-todo.t����������������������������������������������������������0000664�0001750�0001750�00000001707�12224265625�017332� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 9;

ok !$Test::todo_next_test, '$Test::todo_next_test set to False intially';

if ($?COMPILER and $?COMPILER eq 'Pugs') {
    todo :pugs;  # never unTODO this.
    my $saved_val = $Test::todo_next_test;
    ok 0, "this test should be TODO'd";
    ok $saved_val, 'todo() sets $Test::todo_next_test to True';
    ok !$Test::todo_next_test, 'todo() only affects the next one test';

    todo :pugs('9999' ~ $?VERSION);  # never unTODO this.
    $saved_val = $Test::todo_next_test;
    ok 0, "this test should be TODO'd";
    ok $saved_val, 'todo() sets $Test::todo_next_test to True';
    ok !$Test::todo_next_test, 'todo() only affects the next one test';

    todo :pugs('-10.' ~ $?VERSION);  # never unTODO this.
    $saved_val = $Test::todo_next_test;
    ok 1, "this test should not be TODO'd";
    #warn ">>> $saved_val\n";
    ok !$saved_val, "todo() didn't set \$Test::todo_next_test to True";
} else {
    skip 'no general tests', 9;
}
���������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/6-done_testing.t��������������������������������������������������0000664�0001750�0001750�00000000053�12224265625�021041� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
pass;
ok 1;
ok 0,:todo(1);
done;
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S24-testing/use_ok_test.pm����������������������������������������������������0000664�0001750�0001750�00000000065�12224265625�020714� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������
module use_ok_test-0.0.1;

sub it_worked { 1 }

1;

���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/01-delimited.t����������������������������������������������0000664�0001750�0001750�00000007510�12224265625�021575� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 39;
my $r;

=begin foo
=end foo

$r = $=pod[0];
isa_ok $r, Pod::Block, 'returns a Pod Block';
isa_ok $r, Pod::Block::Named, 'returns a named Block';
is $r.name, 'foo', 'name is ok';
is $r.content, [], 'no content, all right';

=begin foo
some text
=end foo

$r = $=pod[1];
isa_ok $r.content[0], Pod::Block::Para;
is $r.content[0].content, "some text", 'the content is all right';
is $r.name, 'foo', 'name is ok';

=begin foo
some
spaced   text
=end foo

$r = $=pod[2];
is $r.name, 'foo', 'name is ok';
is $r.content[0].content,
   "some spaced text", 'additional whitespace removed from the content';

=begin foo
paragraph one

paragraph
two
=end foo
$r = $=pod[3];
is $r.name, 'foo', 'name is ok';
isa_ok $r.content[0], Pod::Block::Para;
isa_ok $r.content[1], Pod::Block::Para;
is $r.content[0].content, "paragraph one", 'paragraphs ok, 1/2';
is $r.content[1].content, "paragraph two", 'paragraphs ok, 2/2';

=begin something
    =begin somethingelse
    toot tooot!
    =end somethingelse
=end something

$r = $=pod[4];
is $r.name, 'something', 'parent name ok';
isa_ok $r.content[0], Pod::Block, "nested blocks work";
isa_ok $r.content[0].content[0], Pod::Block::Para, "nested blocks work";
is $r.content[0].content[0].content, "toot tooot!", "and their content";
is $r.content[0].name, 'somethingelse', 'child name ok';

# Albi
=begin foo
and so,  all  of  the  villages chased
Albi,   The   Racist  Dragon, into the
very   cold   and  very  scary    cave

and it was so cold and so scary in
there,  that  Albi  began  to  cry

    =begin bar
    Dragon Tears!
    =end bar

Which, as we all know...

    =begin bar
    Turn into Jelly Beans!
    =end bar
=end foo

$r = $=pod[5];
isa_ok $r, Pod::Block;
is $r.content.elems, 5, '5 sub-nodes in foo';
is $r.content[0].content,
   'and so, all of the villages chased Albi, The Racist Dragon, ' ~
   'into the very cold and very scary cave',
   '...in the marmelade forest';
is $r.content[1].content,
   'and it was so cold and so scary in there, that Albi began to cry',
   '...between the make-believe trees';
is $r.content[2].content[0].content, "Dragon Tears!",
   '...in a cottage cheese cottage';
is $r.content[3].content, "Which, as we all know...",
   '...lives Albi! Albi!';
is $r.content[4].content[0].content, "Turn into Jelly Beans!",
   '...Albi, the Racist Dragon';

=begin pod

someone accidentally left a space
 
between these two paragraphs

=end pod

$r = $=pod[6];
isa_ok $r, Pod::Block;
is $r.content[0].content, 'someone accidentally left a space',
   'accidental space, 1/2';
is $r.content[1].content, 'between these two paragraphs',
   'accidental space, 2/2';

# various things which caused the spectest to fail at some point
=begin kwid

= DESCRIPTION
bla bla

foo
=end kwid

$r = $=pod[7];
is $r.content[0].content, '= DESCRIPTION bla bla';
isa_ok $r.content[1], Pod::Block::Para;
is $r.content[1].content, 'foo';

=begin more-discussion-needed

XXX: chop(@array) should return an array of chopped strings?
XXX: chop(%has)   should return a  hash  of chopped strings?

=end more-discussion-needed

$r = $=pod[8];
isa_ok $r, Pod::Block;

=begin pod
    =head1 This is a heading block

    This is an ordinary paragraph.
    Its text  will   be     squeezed     and
    short lines filled. It is terminated by
    the first blank line.

    This is another ordinary paragraph.
    Its     text    will  also be squeezed and
    short lines filled. It is terminated by
    the trailing directive on the next line.
        =head2 This is another heading block

        This is yet another ordinary paragraph,
        at the first virtual column set by the
        previous directive
=end pod

$r = $=pod[9];
isa_ok $r.content[0], Pod::Heading;
isa_ok $r.content[1], Pod::Block::Para;
isa_ok $r.content[2], Pod::Block::Para;
isa_ok $r.content[3], Pod::Heading;
isa_ok $r.content[4], Pod::Block::Para;
is $r.content.elems, 5;
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/02-paragraph.t����������������������������������������������0000664�0001750�0001750�00000005304�12224265625�021602� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 27;
my $r;

=for foo

$r = $=pod[0];
isa_ok $r, Pod::Block, 'returns a Pod6 Block';
isa_ok $r, Pod::Block::Named, 'returns a named Block';
is $r.name, 'foo', 'name is ok';
is $r.content, [], 'no content, all right';

=for foo
some text

$r = $=pod[1];
isa_ok $r.content[0], Pod::Block::Para;
is $r.content[0].content, "some text", 'the content is all right';

=for foo
some
spaced   text

$r = $=pod[2];
is $r.content[0].content,
   "some spaced text", 'additional whitespace removed  from the content';
=begin pod

=for got
Inside got

    =for bidden
    Inside bidden

Outside blocks
=end pod

$r = $=pod[3];
isa_ok $r.content[0], Pod::Block;
is $r.content[0].content[0].content, "Inside got",
   'paragraph block content ok, 1/2';
isa_ok $r.content[1], Pod::Block;
is $r.content[1].content[0].content, "Inside bidden",
   'paragraph block content ok, 1/2';
isa_ok $r.content[2], Pod::Block::Para;
is $r.content[2].content, "Outside blocks",
   'content outside blocks is all right';

# mixed blocks
=begin pod
=begin one
one, delimited block
=end one
=for two
two, paragraph block
=for three
three, still a parablock

=begin four
four, another delimited one
=end four
=end pod

$r = $=pod[4];
is $r.content[0].content[0].content,
   "one, delimited block", "mixed blocks, 1";
is $r.content[1].content[0].content,
   "two, paragraph block", "mixed blocks, 2";
is $r.content[2].content[0].content,
   "three, still a parablock", "mixed blocks, 3";
is $r.content[3].content[0].content,
   "four, another delimited one", "mixed blocks, 4";

# tests without Albi would still be tests, but definitely very, very sad
# also, Albi without paragraph blocks wouldn't be the happiest dragon
# either
=begin foo
and so,  all  of  the  villages chased
Albi,   The   Racist  Dragon, into the
very   cold   and  very  scary    cave

and it was so cold and so scary in
there,  that  Albi  began  to  cry

    =for bar
    Dragon Tears!

Which, as we all know...

    =for bar
    Turn into Jelly Beans!
=end foo

$r = $=pod[5];
isa_ok $r, Pod::Block;
is $r.content.elems, 5, '5 sub-nodes in foo';
is $r.name, 'foo';
is $r.content[0].content,
   'and so, all of the villages chased Albi, The Racist Dragon, ' ~
   'into the very cold and very scary cave',
   '...in the marmelade forest';
is $r.content[1].content,
   'and it was so cold and so scary in there, that Albi began to cry',
   '...between the make-believe trees';
is $r.content[2].name, 'bar';
is $r.content[2].content[0].content, "Dragon Tears!",
   '...in a cottage cheese cottage';
is $r.content[3].content, "Which, as we all know...",
   '...lives Albi! Albi!';
is $r.content[4].name, 'bar';
is $r.content[4].content[0].content, "Turn into Jelly Beans!",
   '...Albi, the Racist Dragon';
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/03-abbreviated.t��������������������������������������������0000664�0001750�0001750�00000005743�12224265625�022115� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 30;
my $r;

=foo

$r = $=pod[0];
isa_ok $r, Pod::Block, 'returns a Pod6 Block';
isa_ok $r, Pod::Block::Named, 'returns a named Block';
is $r.content, [], 'no content, all right';

=foo some text

$r = $=pod[1];
is $r.content[0].content, "some text", 'the content is all right';

=foo some text
and some more

$r = $=pod[2];
is $r.content[0].content, "some text and some more", 'the content is all right';

=begin pod

=got Inside
got

=bidden Inside
bidden

Outside blocks
=end pod

$r = $=pod[3];
isa_ok $r.content[0], Pod::Block;
is $r.content[0].content[0].content, "Inside got",
   'paragraph block content ok, 1/2';
isa_ok $r.content[1], Pod::Block;
is $r.content[1].content[0].content, "Inside bidden",
   'paragraph block content ok, 1/2';
isa_ok $r.content[2], Pod::Block::Para;
is $r.content[2].content, "Outside blocks",
   'content outside blocks is all right';

# mixed blocks
=begin pod
    =begin one
    one, delimited block
    =end one
    =two two,
    paragraph block
    =for three
    three, still a parablock

    =begin four
    four, another delimited one
    =end four
    =head1 And just for the sake of having a working =head1 :)
=end pod

$r = $=pod[4];
is $r.content[0].content[0].content,
   "one, delimited block", "mixed blocks, 1";
is $r.content[1].content[0].content,
   "two, paragraph block", "mixed blocks, 2";
is $r.content[2].content[0].content,
   "three, still a parablock", "mixed blocks, 3";
is $r.content[3].content[0].content,
   "four, another delimited one", "mixed blocks, 4";
is $r.content[4].content[0].content,
   "And just for the sake of having a working =head1 :)", 'mixed blocks, 5';

=begin foo
and so,  all  of  the  villages chased
Albi,   The   Racist  Dragon, into the
very   cold   and  very  scary    cave

and it was so cold and so scary in
there,  that  Albi  began  to  cry

    =bold Dragon Tears!

Which, as we all know...

    =bold Turn
          into
          Jelly
          Beans!
=end foo

$r = $=pod[5];
isa_ok $r, Pod::Block;
is $r.content.elems, 5, '5 sub-nodes in foo';
is $r.content[0].content,
   'and so, all of the villages chased Albi, The Racist Dragon, ' ~
   'into the very cold and very scary cave',
   '...in the marmelade forest';
is $r.content[1].content,
   'and it was so cold and so scary in there, that Albi began to cry',
   '...between the make-believe trees';
is $r.content[2].content[0].content, "Dragon Tears!",
   '...in a cottage cheese cottage';
is $r.content[3].content, "Which, as we all know...",
   '...lives Albi! Albi!';
is $r.content[4].content[0].content, "Turn into Jelly Beans!",
   '...Albi, the Racist Dragon';

# from S26
=table_not
    Constants 1
    Variables 10
    Subroutines 33
    Everything else 57

$r = $=pod[6];
isa_ok $r, Pod::Block;
is $r.content.elems, 1;
is $r.content[0].content,
   'Constants 1 Variables 10 Subroutines 33 Everything else 57';

=head3
Heading level 3

$r = $=pod[7];
isa_ok $r, Pod::Block;
isa_ok $r, Pod::Heading;
is $r.level, '3';
is $r.content[0].content, 'Heading level 3';
�����������������������������rakudo-2013.12/t/spec/S26-documentation/04-code.t���������������������������������������������������0000664�0001750�0001750�00000007364�12224265625�020561� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 50;
my $r;

=begin pod
This ordinary paragraph introduces a code block:

    $this = 1 * code('block');
    $which.is_specified(:by<indenting>);
=end pod

$r = $=pod[0];
is $r.content[0].content, 'This ordinary paragraph introduces a code block:';
isa_ok $r.content[1], Pod::Block::Code;
is $r.content[1].content.Str.subst("\r", "", :g), q[$this = 1 * code('block');
$which.is_specified(:by<indenting>);].subst("\r", "", :g);

# more fancy code blocks
=begin pod
This is an ordinary paragraph

    While this is not
    This is a code block

    =head1 Mumble mumble

    Suprisingly, this is not a code block
        (with fancy indentation too)

But this is just a text. Again

=end pod

$r = $=pod[1];
is $r.content.elems, 5;
is $r.content[0].content, 'This is an ordinary paragraph';
isa_ok $r.content[1], Pod::Block::Code;
is $r.content[1].content, "While this is not\nThis is a code block";
isa_ok $r.content[2], Pod::Block;
is $r.content[2].content[0].content, 'Mumble mumble';
isa_ok $r.content[3], Pod::Block::Para;
is $r.content[3].content, "Suprisingly, this is not a code block"
                        ~ " (with fancy indentation too)";
is $r.content[4].content, "But this is just a text. Again";

=begin pod

Tests for the feed operators

    ==> and <==
    
=end pod

$r = $=pod[2];
is $r.content[0].content, 'Tests for the feed operators';
isa_ok $r.content[1], Pod::Block::Code;
is $r.content[1].content, "==> and <==";

=begin pod
Fun comes

    This is code
  Ha, what now?

 one more block of code
 just to make sure it works
  or better: maybe it'll break!
=end pod

$r = $=pod[3];
is $r.content.elems, 4;
is $r.content[0].content, 'Fun comes';
isa_ok $r.content[1], Pod::Block::Code;
is $r.content[1].content, 'This is code';
isa_ok $r.content[2], Pod::Block::Code;
is $r.content[2].content, 'Ha, what now?';
isa_ok $r.content[3], Pod::Block::Code;
is $r.content[3].content, "one more block of code\n"
                        ~ "just to make sure it works\n"
                        ~ " or better: maybe it'll break!";

=begin pod

=head1 A heading

This is Pod too. Specifically, this is a simple C<para> block

    $this = pod('also');  # Specifically, a code block

=end pod

$r = $=pod[4];
is $r.content.elems, 3;
isa_ok $r.content[0], Pod::Block;
is $r.content[0].content[0].content, 'A heading';
is $r.content[1].content[0],
   'This is Pod too. Specifically, this is a simple ';
isa_ok $r.content[1].content[1], Pod::FormattingCode;
is $r.content[1].content[1].type, 'C';
is $r.content[1].content[1].content, 'para';
is $r.content[1].content[2], ' block';
isa_ok $r.content[2], Pod::Block::Code;
is $r.content[2].content,
   q[$this = pod('also');  # Specifically, a code block];

=begin pod
    this is code

    =for podcast
        this is not

    this is not code either

    =begin itemization
        this is not
    =end itemization

    =begin quitem
        and this is not
    =end quitem

    =begin item
        and this is!
    =end item
=end pod

$r = $=pod[5];
is $r.content.elems, 6;
isa_ok $r.content[0], Pod::Block::Code;
is $r.content[0].content, 'this is code';

isa_ok $r.content[1], Pod::Block::Named;
is $r.content[1].name, 'podcast';
is $r.content[1].content[0].content, 'this is not';

isa_ok $r.content[2], Pod::Block::Para;
is $r.content[2].content, 'this is not code either';

isa_ok $r.content[3], Pod::Block::Named;
is $r.content[3].name, 'itemization';
is $r.content[3].content[0].content, 'this is not';

isa_ok $r.content[4], Pod::Block::Named;
is $r.content[4].name, 'quitem';
is $r.content[4].content[0].content, 'and this is not';

isa_ok $r.content[5].content[0], Pod::Block::Code;
is $r.content[5].content[0].content, 'and this is!';

=begin code
    foo foo
    =begin code
    =end code
=end code

$r = $=pod[6];
isa_ok $r, Pod::Block::Code;
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/05-comment.t������������������������������������������������0000664�0001750�0001750�00000001745�12224265625�021307� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 9;
my $r;

sub norm_crlf($str) {
    $str.subst("\r", "", :g)
}

=begin pod
=for comment
foo foo
bla bla    bla

This isn't a comment
=end pod

$r = $=pod[0];
isa_ok $r.content[0], Pod::Block::Comment;
is $r.content[0].content.elems, 1;
is norm_crlf($r.content[0].content), "foo foo\nbla bla    bla\n";

# from S26
=comment
This file is deliberately specified in Perl 6 Pod format

$r = $=pod[1];
isa_ok $r, Pod::Block::Comment;
is $r.content.elems, 1, 'one-line comment: number of elements';;
is norm_crlf($r.content[0]),
   "This file is deliberately specified in Perl 6 Pod format\n",
   'one-line comment: contents';

# this happens to break hilighting in some editors,
# so I put it at the end
=begin comment
foo foo
=begin invalid pod
=as many invalid pod as we want
===yay!
=end comment

$r = $=pod[2];
isa_ok $r, Pod::Block;
is $r.content.elems, 1;
is norm_crlf($r.content[0]), "foo foo\n=begin invalid pod\n"
                ~ "=as many invalid pod as we want\n===yay!\n";
���������������������������rakudo-2013.12/t/spec/S26-documentation/06-lists.t��������������������������������������������������0000664�0001750�0001750�00000004450�12224265625�021000� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 39;
my $r;

=begin pod
The seven suspects are:

=item  Happy
=item  Dopey
=item  Sleepy
=item  Bashful
=item  Sneezy
=item  Grumpy
=item  Keyser Soze
=end pod

$r = $=pod[0];
is $r.content.elems, 8;
for 1..7 {
    isa_ok $r.content[$_], Pod::Item;
}

is $r.content[1].content[0].content, 'Happy', 'content is happy :)';
is $r.content[2].content[0].content, 'Dopey';
is $r.content[7].content[0].content, 'Keyser Soze';
nok $r.content[4].level.defined, 'no level information';

=begin pod
=item1  Animal
=item2     Vertebrate
=item2     Invertebrate

=item1  Phase
=item2     Solid
=item2     Liquid
=item2     Gas
=item2     Chocolate
=end pod

$r = $=pod[1];
is $r.content.elems, 8;
for 0..7 {
    isa_ok $r.content[$_], Pod::Item;
}

is $r.content[0].content[0].content, 'Animal';
is $r.content[0].level,   1;
is $r.content[2].content[0].content, 'Invertebrate';
is $r.content[2].level,   2;
is $r.content[3].content[0].content, 'Phase';
is $r.content[3].level,   1;
is $r.content[4].content[0].content, 'Solid';
is $r.content[4].level,   2;

=begin pod
=comment CORRECT...
=begin item1
The choices are:
=end item1
=item2 Liberty
=item2 Death
=item2 Beer
=end pod

$r = $=pod[2];
is $r.content.elems, 5;
for 1..4 {
    isa_ok $r.content[$_], Pod::Item;
}

# XXX Those items are :numbered in S26, but we're waiting with block
# configuration until we're inside Rakudo, otherwise we'll have to
# pretty much implement Pair parsing in gsocmess only to get rid of
# it later.

=begin pod
Let's consider two common proverbs:

=begin item
I<The rain in Spain falls mainly on the plain.>

This is a common myth and an unconscionable slur on the Spanish
people, the majority of whom are extremely attractive.
=end item

=begin item
I<The early bird gets the worm.>

In deciding whether to become an early riser, it is worth
considering whether you would actually enjoy annelids
for breakfast.
=end item

As you can see, folk wisdom is often of dubious value.
=end pod

$r = $=pod[3];
is $r.content.elems, 4;
is $r.content[0].content, "Let's consider two common proverbs:";
ok $r.content[1].content[1].content
   ~~ /:s This is a common .+ are extremely attractive/;
ok $r.content[2].content[1].content
   ~~ /:s In deciding .+ annelids for breakfast/;
is $r.content[3].content, "As you can see, folk wisdom is often of dubious value.";
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/07-tables.t�������������������������������������������������0000664�0001750�0001750�00000007027�12224265625�021120� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 38;
my $r;

=begin table
        The Shoveller   Eddie Stevens     King Arthur's singing shovel
        Blue Raja       Geoffrey Smith    Master of cutlery
        Mr Furious      Roy Orson         Ticking time bomb of fury
        The Bowler      Carol Pinnsler    Haunted bowling ball
=end table

$r = $=pod[0];
isa_ok $r, Pod::Block::Table;
is $r.content.elems, 4;
is $r.content[0].join('|'),
   "The Shoveller|Eddie Stevens|King Arthur's singing shovel";
is $r.content[1].join('|'),
   "Blue Raja|Geoffrey Smith|Master of cutlery";
is $r.content[2].join('|'),
   "Mr Furious|Roy Orson|Ticking time bomb of fury";
is $r.content[3].join('|'),
   "The Bowler|Carol Pinnsler|Haunted bowling ball";

=table
    Constants           1
    Variables           10
    Subroutines         33
    Everything else     57

$r = $=pod[1];
is $r.content.elems, 4;
is $r.content[0].join('|'), "Constants|1";
is $r.content[1].join('|'), "Variables|10";
is $r.content[2].join('|'), "Subroutines|33";
is $r.content[3].join('|'), "Everything else|57";

=for table
    mouse    | mice
    horse    | horses
    elephant | elephants

$r = $=pod[2];
is $r.content.elems, 3;
is $r.content[0].join('|'), "mouse|mice";
is $r.content[1].join('|'), "horse|horses";
is $r.content[2].join('|'), "elephant|elephants";

=table
    Animal | Legs |    Eats
    =======================
    Zebra  +   4  + Cookies
    Human  +   2  +   Pizza
    Shark  +   0  +    Fish

$r = $=pod[3];
is $r.headers.join('|'), "Animal|Legs|Eats";
is $r.content.elems, 3;
is $r.content[0].join('|'), "Zebra|4|Cookies";
is $r.content[1].join('|'), "Human|2|Pizza";
is $r.content[2].join('|'), "Shark|0|Fish";

=table
        Superhero     | Secret          | 
                      | Identity        | Superpower
        ==============|=================|================================
        The Shoveller | Eddie Stevens   | King Arthur's singing shovel

$r = $=pod[4];
is $r.headers.join('|'), "Superhero|Secret Identity|Superpower";
is $r.content.elems, 1;
is $r.content[0].join('|'),
   "The Shoveller|Eddie Stevens|King Arthur's singing shovel";

=begin table

                        Secret
        Superhero       Identity          Superpower
        =============   ===============   ===================
        The Shoveller   Eddie Stevens     King Arthur's
                                          singing shovel

        Blue Raja       Geoffrey Smith    Master of cutlery

        Mr Furious      Roy Orson         Ticking time bomb
                                          of fury

        The Bowler      Carol Pinnsler    Haunted bowling ball

=end table

$r = $=pod[5];
is $r.headers.join('|'), "Superhero|Secret Identity|Superpower";
is $r.content.elems, 4;
is $r.content[0].join('|'),
   "The Shoveller|Eddie Stevens|King Arthur's singing shovel";
is $r.content[1].join('|'),
   "Blue Raja|Geoffrey Smith|Master of cutlery";
is $r.content[2].join('|'),
   "Mr Furious|Roy Orson|Ticking time bomb of fury";
is $r.content[3].join('|'),
   "The Bowler|Carol Pinnsler|Haunted bowling ball";

=table
    X | O |
   ---+---+---
      | X | O
   ---+---+---
      |   | X

$r = $=pod[6];
is $r.content.elems, 3;
is $r.content[0].join(','), 'X,O,';
is $r.content[1].join(','), ',X,O';
is $r.content[2].join(','), ',,X';

=table
    X   O     
   ===========
        X   O 
   ===========
            X 

$r = $=pod[7];
is $r.content.elems, 3;
is $r.content[0].join(','), 'X,O,';
is $r.content[1].join(','), ',X,O';
is $r.content[2].join(','), ',,X';

=begin table

foo
bar

=end table

$r = $=pod[8];
is $r.content.elems, 2;
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/08-formattingcodes.t����������������������������������������0000664�0001750�0001750�00000003434�12224265625�023035� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
my $r;

=pod
B<I am a formatting code>

$r = $=pod[0].content[0].content[1];
isa_ok $r, Pod::FormattingCode;
is $r.type, 'B';
is $r.content[0], 'I am a formatting code';

=pod
The basic C<ln> command is: C<ln> B<R<source_file> R<target_file>>

$r = $=pod[1].content[0].content;
is $r[0], 'The basic ';
isa_ok $r[1], Pod::FormattingCode;
is $r[1].type, 'C';
is $r[1].content, 'ln';
is $r[2], ' command is: ';
isa_ok $r[3], Pod::FormattingCode;
is $r[3].type, 'C';
is $r[3].content, 'ln';
isa_ok $r[5], Pod::FormattingCode;
is $r[4], " ";
is $r[5].type, 'B';
$r = $r[5].content;
is $r[0], "";
isa_ok $r[1], Pod::FormattingCode;
is $r[1].type, 'R';
is $r[1].content, 'source_file';
is $r[2], ' ';
isa_ok $r[3], Pod::FormattingCode;
is $r[3].type, 'R';
is $r[3].content, 'target_file';

=pod
L<C<b>|a>
L<C<b>|a>

$r = $=pod[2].content[0].content;
for $r[1], $r[3] -> $link {
    is $link.type, 'L';
    is $link.content[0], '';
    isa_ok $link.content[1], Pod::FormattingCode;
    is $link.content[1].content, 'b';
    is $link.content[2], '|a';
}

=begin pod

=head1 A heading

This is Pod too. Specifically, this is a simple C<para> block

    $this = pod('also');  # Specifically, a code block

=end pod

$r = $=pod[3];
is $r.content.elems, 3;
isa_ok $r.content[0], Pod::Block;
is $r.content[0].content[0].content, 'A heading';
is $r.content[1].content[0],
   'This is Pod too. Specifically, this is a simple ';
isa_ok $r.content[1].content[1], Pod::FormattingCode;
is $r.content[1].content[1].type, 'C';
is $r.content[1].content[1].content, 'para';
is $r.content[1].content[2], ' block';
isa_ok $r.content[2], Pod::Block::Code;
is $r.content[2].content,
   q[$this = pod('also');  # Specifically, a code block];

=pod V<C<boo> B<bar> asd>

$r = $=pod[4];
is $r.content[0].content, 'C<boo> B<bar> asd';

done;
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/09-configuration.t������������������������������������������0000664�0001750�0001750�00000001717�12224265625�022517� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 14;
my $r;

=begin pod
    =begin code :allow<B>
    =end code
=end pod

$r = $=pod[0].content[0];
isa_ok $r, Pod::Block::Code;
is $r.config<allow>, 'B';

=begin pod
    =config head2  :like<head1> :formatted<I>
=end pod

$r = $=pod[1].content[0];
isa_ok $r, Pod::Config;
is $r.type, 'head2';
is $r.config<like>, 'head1';
is $r.config<formatted>, 'I';

=begin pod
    =pod :number(42) :zebras :!sheep
=end pod

$r = $=pod[2].content[0];
is $r.config<number>, 42;
is $r.config<zebras>.Bool, True;
is $r.config<sheep>.Bool, False;

=begin pod
=for DESCRIPTION :title<presentation template>
=                :author<John Brown> :pubdate(2011)
=end pod

$r = $=pod[3].content[0];
is $r.config<title>, 'presentation template';
is $r.config<author>, 'John Brown';
is $r.config<pubdate>, 2011;

=begin pod
=for table :caption<Table of contents>
    foo bar
=end pod

$r = $=pod[4].content[0];
isa_ok $r, Pod::Block::Table;
is $r.config<caption>, 'Table of contents';
�������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/10-doc-cli.t������������������������������������������������0000664�0001750�0001750�00000000441�12224265625�021143� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use lib 't/spec/packages';

use Test;
use Test::Util;
plan 1;

my $POD = Q:to<POD>;
=begin pod

=head1 Some Heading

Some Text

=end pod
POD

is_run :compiler-args['--doc'], $POD, {
        out => rx/'Some Heading'/ & rx/'Some Text'/
    }, 'basic --doc sanity';


# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S26-documentation/why.t�������������������������������������������������������0000664�0001750�0001750�00000002646�12224265625�020233� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;
plan 19;

#= simple case
class Simple {
}

is Simple.WHY.content, 'simple case';
is ~Simple.WHY, 'simple case', 'stringifies correctly';

#= giraffe
class Outer {
    #= zebra
    class Inner {
    }
}

is Outer.WHY.content, 'giraffe';
is Outer::Inner.WHY.content, 'zebra';

#= a module
module foo {
    #= a package
    package bar {
        #= and a class
        class baz {
        }
    }
}

is foo.WHY.content,           'a module';
is foo::bar.WHY.content,      'a package';
is foo::bar::baz.WHY.content, 'and a class';

#= yellow
sub marine {}
is &marine.WHY.content, 'yellow';

#= pink
sub panther {}
is &panther.WHY.content, 'pink';

#= a sheep
class Sheep {
    #= usually white
    has $.wool;

    #= not too scary
    method roar { 'roar!' }
}

is Sheep.WHY.content, 'a sheep';
skip 'segfault', 1;
#is Sheep.^attributes.grep({ .name eq '$!wool' }).WHY, 'usually white';
is Sheep.^find_method('roar').WHY.content, 'not too scary';

sub routine {}
is &routine.WHY.defined, False;

#= our works too
our sub oursub {}
is &oursub.WHY, 'our works too', 'works for our subs';

# two subs in a row

#= one
sub one {}

#= two
sub two {}
is &one.WHY.content, 'one';
is &two.WHY.content, 'two';

#= that will break
sub first {}

#= that will break
sub second {}

is &first.WHY.content, 'that will break';
is &second.WHY.content, 'that will break';

#= trailing space here  
sub third {}
is &third.WHY.content, 'trailing space here';
������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S28-named-variables/cwd.t�����������������������������������������������������0000664�0001750�0001750�00000000552�12224265625�020356� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

# L<S28/Named variables/$*CWD>
# See also S16-io/cwd.t

use Test;

plan 2;

# $*CWD is currently just a string

ok( defined($*CWD), 'we have something in our $CWD');

# check if there is a t subfolder

my $subfolder_exists = 0;
if "$*CWD/t".IO ~~ :e {
    $subfolder_exists = 1;
}#if
ok( $subfolder_exists, 'we have a "t" subfolder');


# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S28-named-variables/inc.t�����������������������������������������������������0000664�0001750�0001750�00000001171�12224265625�020350� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 5;

# Note that @*INC is only provisional until we have plans for a "real"
# module database in place.
#
# L<S28/Perl5 to Perl6 special variable translation/"@*INC">

#?niecza todo
ok(+@*INC > 0, 'we have something in our @INC');

my $number_in_inc = +@*INC;
push @*INC, 'test';
is(+@*INC, $number_in_inc + 1, 'we added something to @INC');

#?pugs emit # cannot pop scalar
pop @*INC;
#?pugs skip 'cannot pop scalar'
is(+@*INC, $number_in_inc, 'we removed something from @INC');

lives_ok { @*INC = <a b c> }, 'Can assign to @*INC';
is @*INC.join(','), 'a,b,c', '... and assignment worked';

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S28-named-variables/slangs.t��������������������������������������������������0000664�0001750�0001750�00000000601�12224265625�021063� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 6;

# L<S02/Slangs/>

#?rakudo: 6 skip "Non-declarative sigil is missing its name"
ok(defined($~MAIN),    '$~MAIN is defined');
ok(defined($~Quote),   '$~Quote is defined');
ok(defined($~Quasi),   '$~Quasi is defined');
ok(defined($~Regex),   '$~Regex is defined');
ok(defined($~Trans),   '$~Trans is defined');
ok(defined($~P5Regex), '$~P5Regex is defined');
�������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-any/cmp.t�����������������������������������������������������������������0000664�0001750�0001750�00000000564�12237474612�016123� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

# L<S32::Basics/Any/"=item cmp">

is('a' cmp 'a', Order::Same, 'a is equal to a');
is('a' cmp 'b', Order::Less, 'a is less than b');
is('b' cmp 'a', Order::More, 'b is greater than a');

is(3   cmp   3, Order::Same, '3 cmp 3 is 0');
is(2   cmp   3, Order::Less, '2 cmp 3 is -1');
is(3   cmp   4, Order::Less, '3 cmp 4 is -1');

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-any/isa.t�����������������������������������������������������������������0000664�0001750�0001750�00000003221�12224265625�016107� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin kwid 

.isa() tests

These tests are specific to the .isa() which is attached to the
Perl6 Array "class". Which is actually @array.HOW.isa(), which 
is actually just the normal OO .isa(). This test does not attempt
to test anything other than the "normal" behavior of @array.isa()

Further clarification of .isa() can be found here:

L<"http://www.nntp.perl.org/group/perl.perl6.language/20974">
L<S29/Any/=item isa/>

=end kwid 

plan 10;

{ # invocant notation  
    my @arr = <1 2 3 4>;
    
    ok(@arr.isa(Array), '... @arr is-a Array (invocant notation)');
    
    # check a failing case
    ok(!@arr.isa(Hash), '... @arr is-not-a Hash (invocant notation)');
}


{ # invocant notation   
    my $arr_ref = <1 2 3 4>;

    # check a failing case
    nok($arr_ref.isa(Hash), '... $arr is-not-a Hash (invocant notation)');      
}

# check error cases

{
    my @arr = <1 2 3 4>;
    eval_dies_ok 'isa(@arr, Array)', 'no sub called isa()';
    dies_ok { @arr.isa() }, '... isa() with a single arg is a failing case (invocant notation)';  
      
    dies_ok { @arr.isa(Array, Hash)  }, '... isa() with a extra args is a failing case (invocant notation)';        
}

## some edge cases, and weirdness

{ # check .isa() on inline values

    ok([1, 2, 3, 4].isa(Array), '... [1, 2, 3, 4].isa("Array") works');
    ok(![1, 2, 3, 4].isa(Hash), '... [1, 2, 3, 4].isa("Hash") fail predicably');    
}

class Thing {};
{
    my $thing = Thing.new();
    ok($thing.isa(Thing), '.isa named class');
}
class Thing::something {};
{
    my $thing = Thing::something.new();
    ok($thing.isa(Thing::something), '.isa named class with colons');
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-context/die.t�������������������������������������������������������������0000664�0001750�0001750�00000004251�12224265625�016775� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;
plan 16;

# L<S29/Context/=item die>

=begin pod

Tests for the die() builtin

=end pod

{
    ok( !defined( try { die "foo"; 1; } ), 'die in try cuts off execution');
    my $error = $!;
    is($error, 'foo', 'got $! correctly');
}

my $foo = "-foo-";
try { $foo = die "bar" };
$foo; # this is testing for a bug where an error is stored into $foo in
      # the above eval; unfortunately the if below doesn't detect this on it's
      # own, so this lone $foo will die if the bug is present
ok($foo eq "-foo-");

sub recurse {
  my $level=@_[0];
  $level>0 or die "Only this\n";
  recurse(--$level);
}
try { recurse(1) };
is($!, "Only this\n", 'die() in recursively called sub');

# die in if,map,grep etc.
is ({ try { map    { die }; 1,2,3 }; 42 }()), 42, "die in map";
is ({ try { grep   { die }; 1,2,3 }; 42 }()), 42, "die in grep";
is ({ try { sort   { die }; 1,2,3 }; 42 }()), 42, "die in sort";
is ({ try { reduce { die }; 1,2,3 }; 42 }()), 42, "die in reduce";

is ({ try { for 1,2,3 { die }; 23 }; 42 }()), 42, "die in for";
is ({ try { if 1 { die } else { die } }; 42 }()), 42, "die in if";

my sub die_in_return () { return die };
is ({ try { die_in_return(); 23 }; 42 }()), 42, "die in return";

#?niecza skip 'test needs rewriting, eval does not catch exceptions'
{
    my $msg = 'RT 67374';
    try { die $msg };
    is "$!", $msg, 'die with argument sets $!';
    try { die };
    #?rakudo todo 'RT #67374'
    is "$!", $msg, 'die with no argument uses $!';
}

is_run( 'die "first line"',
        { status => sub { 0 != $^a },
          out    => '',
          err    => rx/'first line'/,
        },
        'die with no output' );

is_run( 'say "hello"; die "Nos morituri te salutant!\n"',
        { status => sub { 0 != $^a },
          out    => "hello\n",
          err    => rx/'Nos morituri te salutant!' \n/,
        },
        'say something and die' );

# If one of the above tests caused weird continuation bugs, the following line
# will be executed multiple times, resulting in a "too many tests run" error
# (which is what we want). (Test primarily aimed at PIL2JS)
is 42-19, 23, "basic sanity";

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-context/evalfile.t��������������������������������������������������������0000664�0001750�0001750�00000000507�12241704255�020017� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 1;

# L<S29/Context/"=item evalfile">

sub nonce () { return (".{$*PID}." ~ 1000.rand.Int) }

my $tmpfile = "temp-evalfile" ~ nonce();
{
    my $fh = open("$tmpfile", :w);
    say $fh: "32 + 10";
    close $fh;
}

is evalfile($tmpfile), 42, "evalfile() works";

END { unlink $tmpfile }

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-context/eval.t������������������������������������������������������������0000664�0001750�0001750�00000004755�12224265625�017174� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 18;

# L<S29/Context/"=item eval">

=begin pod

Tests for the eval() builtin

=end pod

# eval should evaluate the code in the lexical scope of eval's caller
{
    sub make_eval_closure {
        my $a = 5;   #OK not used
        return sub ($s) {
            eval $s 
        };
    };
    is(make_eval_closure().('$a'), 5, 'eval runs code in the proper lexical scope');
}

is(eval('5'), 5, 'simple eval works and returns the value');
my $foo = 1234;
is(eval('$foo'), $foo, 'simple eval using variable defined outside');

# traps die?
#?pugs todo
dies_ok {eval('die; 1')}, "eval does not trap die";

#?pugs todo
dies_ok {eval '1 1)'}, "eval throws on syntax error";

#?pugs todo
dies_ok {eval 'use Poison; 1'}, "eval dies on fatal use";

# L<S04/Exception handlers/Perl 6's eval function only evaluates strings, not blocks.>
#?pugs todo
dies_ok({eval {; 42} }, 'block eval is gone');

# RT #63978, eval didn't work in methods
{
    class EvalTester1 {
        method e($s) { eval $s };
    }
    is EvalTester1.e('5'),       5, 'eval works inside class methods';
    is EvalTester1.new.e('5'),   5, 'eval works inside instance methods';
}

{
    my $x = 5;
    class EvalTester2 {
        method e($s) { eval "$s + \$x" };
    }
    is EvalTester2.e('1'),       6, 
       'eval works inside class methods, with outer lexicals';
    is EvalTester2.new.e('1'),   6, 
       'eval works inside instance methods, with outer lexicals';
}

#?rakudo skip 'eval(Buf)'
#?niecza skip 'Unable to resolve method encode in class Str'
#?pugs skip 'encode'
is eval("'møp'".encode('UTF-8')), 'møp', 'eval(Buf)';

{
    #?rakudo skip 'eval coerce to string'
    is eval(88), 88, 'eval of non-string works';

    my $number = 2;
    #?rakudo skip 'eval coerce to string'
    is eval($number), $number, 'eval of non-string variable works';
}

# RT #77646
{
    my $x = 0;
    eval '$x++' for 1..4;
    is $x, 4, 'can execute the same eval multiple times, without surrounding block';

}

# RT 112472
#?niecza todo "No :lang argument yet..."
#?pugs skip 'Cannot cast from VUndef to VCode'
{
    try eval(:lang<rt112472>, '1');
    ok "$!" ~~ / 'rt112472' /, 'eval in bogus language mentions the language';
}

# RT 115344
my $rt115344 = 115344;
#?niecza skip 'method form of eval does not see outer lexicals'
is('$rt115344'.eval, $rt115344, 'method form of eval sees outer lexicals');

# RT #115774
#?niecza skip "int NYI"
{
    my int $a; eval('');
    ok(1, "presence of low level types doesn't cause eval error")
}


# vim: ft=perl6
�������������������rakudo-2013.12/t/spec/S29-context/exit-in-if.t������������������������������������������������������0000664�0001750�0001750�00000000622�12224265625�020203� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 1;

# L<S29/Context/"=item exit">

# This test is primarily aimed at PIL2JS.
# In conditionals, or, to be more exact, in all things using PIL2JS.cps2normal,
# exit() did call all END blocks, but the control flow was resumed afterwards.
# This is now fixed, but it's still good to have a test for it.


if 1 {
  pass;
  exit;
}

ok 0, "exit() in if didn't work";

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-context/exit.t������������������������������������������������������������0000664�0001750�0001750�00000000734�12224265625�017207� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 3;

# L<S29/Context/"=item exit">

BEGIN { @*INC.push: 't/spec/packages' };
use Test::Util;

is_run 'say 3; exit; say 5',
    { out => "3\n", err => "", status => 0 },
    'bare exit; works';

is_run 'say 3; exit 5; say 5',
    { out => "3\n", err => "", status => 5 +< 8 },
    'exit 5; works';

is_run 'say 3; try { exit 5 }; say 5',
    { out => "3\n", err => "", status => 5 +< 8 },
    'try-block does not catch exit exceptions';

# vim: ft=perl6
������������������������������������rakudo-2013.12/t/spec/S29-context/sleep.t�����������������������������������������������������������0000664�0001750�0001750�00000003553�12224265625�017350� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S29/Context/"=item sleep">

plan 17;

my $seconds = 3;
my $nil is default(Nil);
my $b;

{
    diag "sleep() for $seconds seconds";
    my $start = now;
    $nil = sleep $seconds;
    my $diff = now - $start;

    #?pugs   todo "NYI"
    #?niecza todo "NYI"
    ok $nil === Nil , 'sleep() always returns Nil';

    ok $diff >= $seconds - 1 , 'we actually slept at some seconds';
    ok $diff <= $seconds + 5 , '... but not too long';

    #?pugs   2 skip "NYI"
    #?niecza 2 skip "NYI"
    $nil = 1;
    lives_ok { $nil = sleep(-1) }, "silently ignores negative times";
    ok $nil === Nil , 'sleep() always returns Nil';
} #5

#?pugs   skip "NYI"
#?niecza skip "NYI"
{
    diag "sleep-timer() for $seconds seconds";
    my $then = now;
    my $left = sleep-timer $seconds;
    my $now  = now;

    isa_ok $left, Duration, 'did we get a Duration back (1)';
    ok $now - $then + $seconds >= $left, 'does Duration returned make sense';

    $left = sleep-timer -1;
    isa_ok $left, Duration, 'did we get a Duration back (2)';
    is $left, 0, 'no time left to wait';

    $left = sleep-timer 0;
    isa_ok $left, Duration, 'did we get a Duration back (3)';
    is $left, 0, 'no time left to wait either';
} #6

#?pugs   skip "NYI"
#?niecza skip "NYI"
{
    diag "sleep-till() for $seconds seconds";
    my $then  = now;
    my $slept = sleep-till $then + $seconds;
    my $now   = now;

    isa_ok $slept, Bool, 'did we get a Bool back';
    ok $slept, 'did we actually wait';
    ok $now - $then + $seconds >= 0, 'does elapsed time make sense';

    nok sleep-till($then + $seconds), 'should not actually sleep again';
} #4

#?pugs   todo "NYI"
#?niecza todo "NYI"
{
    diag "checking infinite waiting times";
    isa_ok eval('$b={sleep(Inf)}'),       Block, 'sleep(Inf) compiles';
    isa_ok eval('$b={sleep(*)}'),         Block, 'sleep(*) compiles';
} #2

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-conversions/hash.t��������������������������������������������������������0000664�0001750�0001750�00000001477�12224265625�020052� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 8;

=begin pod

Basic tests for the hash() built-in

=end pod

# L<S29/Conversions/hash>

{
    ok hash() ~~ Hash, 'hash() makes a hash';
}

{
    "foo" ~~ /foo/;
    is hash().elems, 0, "hash() doesn't auto-hash $/";
}

#?pugs skip 'Unimplemented unaryOp: hash'
{
    is ('a'..'c' Z 1..3).hash.<a>, 1, "hash() builds a sensible hash";
    is ('a'..'c' Z 1..3).hash.<b>, 2, "hash() builds a sensible hash";
    is ('a'..'c' Z 1..3).hash.<c>, 3, "hash() builds a sensible hash";
}

#?pugs todo 'Unimplemented unaryOp: hash'
{
    lives_ok {(a => 1, b => 2).hash.perl}, 'hash() on list of pairs lives (RT #76826)';
}

#?pugs skip 'Unimplemented unaryOp: hash'
{
    dies_ok {hash(<1 2 3>)}, "hash() won't create invalid hash";
}


{
    is ?hash(), Bool::False, "hash() is false";
}


done;

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-conversions/ord_and_chr.t�������������������������������������������������0000664�0001750�0001750�00000007222�12224265625�021363� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

Basic tests for the ord() and chr() built-in.

=end pod

# L<S29/Conversions/ord>
# L<S29/Conversions/ords>
# L<S29/Conversions/chr>
# L<S29/Conversions/chrs>

# What is the best way to test 0 through 31??
my @maps = (
  " ",    32,
  "!",    33,
  '"',    34,
  "#",    35,
  '$',    36,
  "%",    37,
  "&",    38,
  "'",    39,
  "(",    40,
  ")",    41,
  "*",    42,
  "+",    43,
  ",",    44,
  "-",    45,
  ".",    46,
  "/",    47,
  "0",    48,
  "1",    49,
  "2",    50,
  "3",    51,
  "4",    52,
  "5",    53,
  "6",    54,
  "7",    55,
  "8",    56,
  "9",    57,
  ":",    58,
  ";",    59,
  "<",    60,
  "=",    61,
  ">",    62,
  "?",    63,
  "@",    64,
  "A",    65,
  "B",    66,
  "C",    67,
  "D",    68,
  "E",    69,
  "F",    70,
  "G",    71,
  "H",    72,
  "I",    73,
  "J",    74,
  "K",    75,
  "L",    76,
  "M",    77,
  "N",    78,
  "O",    79,
  "P",    80,
  "Q",    81,
  "R",    82,
  "S",    83,
  "T",    84,
  "U",    85,
  "V",    86,
  "W",    87,
  "X",    88,
  "Y",    89,
  "Z",    90,
  "[",    91,
  "\\",   92,
  "]",    93,
  "^",    94,
  "_",    95,
  "`",    96,
  "a",    97,
  "b",    98,
  "c",    99,
  "d",    100,
  "e",    101,
  "f",    102,
  "g",    103,
  "h",    104,
  "i",    105,
  "j",    106,
  "k",    107,
  "l",    108,
  "m",    109,
  "n",    110,
  "o",    111,
  "p",    112,
  "q",    113,
  "r",    114,
  "s",    115,
  "t",    116,
  "u",    117,
  "v",    118,
  "w",    119,
  "x",    120,
  "y",    121,
  "z",    122,
  '{',    123,
  "|",    124,
  '}',    125,
  "~",    126,

  # Unicode tests
  "ä",    228,
  "€",    8364,
  "»",    187,
  "«",    171,

  # Special chars
  "\o00", 0,
  "\o01", 1,
  "\o03", 3,
);

plan 52 + @maps;

for @maps -> $char, $code {
  my $descr = "\\{$code}{$code >= 32 ?? " == '{$char}'" !! ""}";
  is ord($char), $code, "ord() works for $descr";
  is chr($code), $char, "chr() works for $descr";
}

for 0...31 -> $code {
  my $char = chr($code);
  is ord($char), $code, "ord(chr($code)) is $code";
}

is ords('ABCDEFGHIJK'), '65 66 67 68 69 70 71 72 73 74 75', "ords() works as expected";
is chrs(65..75), 'ABCDEFGHIJK', "chrs() method works as expected";
is chrs(ords('ABCDEFGHIJK')), 'ABCDEFGHIJK', "chrs(ords()) round-trips correctly";
is ords(chrs(65..75)), '65 66 67 68 69 70 71 72 73 74 75', "ords(chrs()) round-trips correctly";

is 'A'.ord, 65, "there's a .ord method";
is 65.chr, 'A', "there's a .chr method";

is ('ABCDEFGHIJK').ords, '65 66 67 68 69 70 71 72 73 74 75', "there's a .ords method";
is (65..75).chrs, 'ABCDEFGHIJK', "there's a .chrs method";
is ('ABCDEFGHIJK').ords.chrs, 'ABCDEFGHIJK', "ords > chrs round-trips correctly";
is (65..75).chrs.ords, '65 66 67 68 69 70 71 72 73 74 75', "chrs > ords round-trips correctly";

#?niecza skip "multi-arg variants of chr not in place yet"
is chrs(104, 101, 108, 108, 111), 'hello', 'chrs works with a list of ints';

#?niecza 4 skip "chr handling of invalid code-points"
dies_ok {chr(0xD800)}, "chr of surrogate";
dies_ok {chr(0x2FFFE)}, "chr of noncharacter";
dies_ok {chr(0x2FFFF)}, "chr of noncharacter";
dies_ok {chr(0x10FFFF+1)}, "chr out of range";

ok !defined(ord("")), 'ord("") returns an undefined value';

#?rakudo.jvm skip 'high character name lookup'
is "\c[DROMEDARY CAMEL]".ord, 0x1F42A, "ord of named high character";
is chr(0x1F42A).ord, 0x1F42A, "chr > ord round trip of high character";

{
    is "\c[LATIN CAPITAL LETTER A WITH DOT ABOVE]".ord, 550, '.ord defaults to graphemes (2)';

    #?rakudo todo 'RT #65172 - combining graphemes'
    #?niecza todo
    is "\c[LATIN CAPITAL LETTER A, COMBINING DOT ABOVE]".ord, 550, '.ord defaults to graphemes (1)';

}

#vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-os/system.t���������������������������������������������������������������0000664�0001750�0001750�00000001624�12241704255�016512� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S29/"OS"/"=item run">
# system is renamed to run, so link there. 

plan 5;

my $res;

$res = run($*EXECUTABLE_NAME,'-e1');
#?rakudo.jvm todo "nigh"
ok($res,"run() to an existing program does not die (and returns something true)");

$res = run("program_that_does_not_exist_ignore_this_error_please.exe");
ok(!$res, "run() to a nonexisting program does not die (and returns something false)");

$res = run("program_that_does_not_exist_ignore_errors_please.exe","a","b");
ok(!$res, "run() to a nonexisting program with an argument list does not die (and returns something false)");

chdir "t";
my $cwd;
BEGIN { $cwd = $*OS eq 'MSWin32' ?? 'cd' !! 'pwd' };
#?pugs skip 'qqx'
ok((qqx{$cwd} ne BEGIN qqx{$cwd}), 'qqx{} is affected by chdir()');
#?rakudo skip 'run() broken (and test questionable'
ok((run("dir", "t") != BEGIN { run("dir", "t") } ), 'run() is affected by chdir()');

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S29-type/declarations.t�������������������������������������������������������0000664�0001750�0001750�00000001144�12224265625�020177� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S29/"Type Declarations">

=begin pod

Test for some type declarations for built-in functions. 

=end pod

plan 9;

# Maybe this test should be modified to run with rakudo

my sub ok_eval1($code) {
    #?pugs todo 'feature'
    &Test::ok.nextwith(eval($code),$code)
}

ok_eval1('AnyChar.isa(Str)');
ok_eval1('Char.isa(Str)');
ok_eval1('Codepoint =:= Uni');
ok_eval1('CharLingua.isa(AnyChar)');
ok_eval1('Grapheme.isa(AnyChar)');
ok_eval1('Codepoint.isa(AnyChar)');
ok_eval1('Byte.isa(AnyChar)');
ok_eval1('Byte.isa(Num)');
ok_eval1('subset MatchTest of Item | junction;');

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/bool.t��������������������������������������������������������������0000664�0001750�0001750�00000002326�12224265625�016614� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 15;

{
    my @a;
    nok @a.Bool, '@a.Bool returns False for empty @a';
    nok ?@a,     '?@a returns False for empty @a';
    nok @a,      '@a in bool context returns False for empty @a';
    
    @a.push: 37;
    ok @a.Bool, '@a.Bool returns True for @a with one element';
    ok ?@a,     '?@a returns True for @a with one element';
    ok @a,      '@a in bool context returns True for @a with one element';

    @a.push: -23;
    ok @a.Bool, '@a.Bool returns True for @a with two elements';
    ok ?@a,     '?@a returns True for @a with two elements';
    ok @a,      '@a in bool context returns True for @a with two elements';
}

{
    my @a = 4..3;
    nok @a.Bool, '@a.Bool returns False for empty range in @a';
    nok ?@a,     '?@a returns False for empty range in @a';
    nok @a,      '@a in bool context returns False for empty range in @a';
    
    @a = 4..6;
    ok @a.Bool, '@a.Bool returns True for non-empty range in @a';
    ok ?@a,     '?@a returns True for non-empty range in @a';
    ok @a,      '@a in bool context returns True for non-empty range in @a';
}

# TODO: This could definitely use tests to make sure that @a.Bool only examines
# the first (few?) elements of @a.

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/create.t������������������������������������������������������������0000664�0001750�0001750�00000001163�12224265625�017122� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"Array"/"=item ">

=begin pod

built-in "Array" tests

=end pod

plan 8;

my $array_obj = Array.new(4, 5, 6);
is($array_obj.WHAT.gist, Array.gist, 'Creating a new list object with new works.');
is($array_obj, list(4, 5, 6), 'The list object contains the right values.');
is(+$array_obj, 3, 'Finding the length functions properly.');

{
    use lib "t/spec/packages";
    use Test::Util;
    ok +Array[Int].new(1, 2, 3, 4), "typed array";
    throws_like(q{ Array[Int].new(1, 2, "Foo") }, X::TypeCheck);
    throws_like(q{ Array[Str].new(1, 2, "Foo") }, X::TypeCheck);
}

# vim: ft=perl6

�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/delete-adverb-native.t����������������������������������������������0000664�0001750�0001750�00000025717�12225464703�021660� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 138;

# THIS IS A COPY OF S32-array/delete-adverb.t, WITH ALL MULTIPLE ELEMENT TESTS
# REMOVED AND THE REMAINING TESTS CHANGED SO THAT THEY USE A native int AS THE
# PARAMETER FOR THE POSITION.

# L<S02/Names and Variables/:delete> using native keys

#-------------------------------------------------------------------------------
# initialisations

my $default = Any;
my $dont    = False;
sub gen_array { (1..10).list }

#-------------------------------------------------------------------------------
# Array

{ # basic sanity
    my @a = gen_array;
    is @a.elems, 10, "do we have a valid array";
} #1

{ # single element
    my Int @a = gen_array;
    my $b     = @a[my int$=3];

    #?pugs   3 skip "no adverbials"
    #?niecza 3 skip "no adverbials"
    is @a[my int$=3]:delete, $b, "Test for delete single element";
    is @a[my int$=3], $default,  "3 should be deleted now";
    is +@a, 10,          "array still has same length";

    #?pugs   11 skip "no adverbials"
    #?niecza 11 skip "no adverbials"
    my $c = @a[my int$=9];
    is @a[my int$=9]:!delete, $c,       "Test non-deletion with ! single elem";
    is @a[my int$=9], $c,               "9 should not have been deleted";
    is @a[my int$=9]:delete(0), $c,     "Test non-deletion with (0) single elem";
    is @a[my int$=9], $c,               "9 should not have been deleted";
    is @a[my int$=9]:delete(False), $c, "Test non-deletion with (False) single elem";
    is @a[my int$=9], $c,               "9 should not have been deleted";
    is @a[my int$=9]:delete($dont), $c, "Test non-deletion with (\$dont) single elem";
    is @a[my int$=9], $c,               "9 should not have been deleted";
    is @a[my int$=9]:delete(1), $c,     "Test deletion with (1) single elem";
    is @a[my int$=9], $default,         "9 should be deleted now";
    is +@a, 9,                  "array should be shortened now";

    my $d = @a[my int$=8]:p;
    #?pugs   7 skip "no adverbials"
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply @a[my int$=8]:p:!delete, $d,       "return a single pair out";
    ok @a[my int$=8]:exists,                     "8 should not have been deleted";
    is_deeply @a[my int$=8]:p:delete,  $d,       "slice a single pair out";
    ok !defined(@a[my int$=8]),                  "8 should be deleted now";
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply @a[my int$=8]:p:delete,  (),       "slice unexisting single pair out";
    is_deeply @a[my int$=8]:!p:delete, (8=>Int), "slice unexisting single pair out";
    is @a.elems, 8, "should have been shortened";

    my $e= (7, @a[my int$=7]);
    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is_deeply @a[my int$=7]:kv:!delete, $e,      "return a single elem/value out";
    ok @a[my int$=7]:exists,                     "7 should not have been deleted";
    is_deeply @a[my int$=7]:kv:delete,  $e,      "slice a single elem/value out";
    ok @a[my int$=7]:!exists,                    "7 should be deleted now";
    is_deeply @a[my int$=7]:kv:delete,  (),      "slice unexisting single elem/value";
    is_deeply @a[my int$=7]:!kv:delete, (7,Int), "slice unexisting single elem/value";
    is @a.elems, 7, "should have been shortened";

    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is @a[my int$=6]:k:!delete,        6, "return a single elem out";
    ok @a[my int$=6]:exists,              "6 should not have been deleted";
    is @a[my int$=6]:k:delete,         6, "slice a single elem out";
    ok @a[my int$=6]:!exists,             "6 should be deleted now";
    is_deeply @a[my int$=6]:k:delete, (), "slice unexisting single elem";
    is @a[my int$=6]:!k:delete,        6, "slice unexisting single elem";
    is @a.elems, 6, "should have been shortened";

    my $g= @a[my int$=5];
    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is @a[my int$=5]:v:!delete,        $g, "return a single value out";
    ok @a[my int$=5]:exists,               "5 should not have been deleted";
    is @a[my int$=5]:v:delete,         $g, "slice a single value out";
    ok @a[my int$=5]:!exists,              "5 should be deleted now";
    is_deeply @a[my int$=5]:v:delete,  (), "slice unexisting single elem";
    is @a[my int$=5]:!v:delete,       Int, "slice unexisting single elem";
    is @a.elems, 5, "should have been shortened";
} #42

{ # single elem, combinations with :exists
    my @a = gen_array;

    #?pugs   5 skip "no adverbials"
    #?niecza 5 todo "cannot combine adverbial pairs"
    ok (@a[my int$=9]:delete:exists) === True,  "9:exists single existing elem";
    ok @a[my int$=9]:!exists,                   "9 should be deleted now";
    ok (@a[my int$=9]:delete:exists) === False, "9:exists one non-existing elem";
    ok (@a[my int$=9]:delete:!exists) === True, "9:!exists one non-existing elem";
    is @a.elems, 9, "should have been shortened";

    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is_deeply @a[my int$=8]:delete:!exists:kv, (8,False), "8:exists:kv 1 eelem";
    ok @a[my int$=8]:!exists,                             "8 should be deleted now";
    is_deeply @a[my int$=8]:delete:exists:!kv, (8,False), "1 neelem d:exists:!kv";
    is_deeply @a[my int$=8]:delete:!exists:!kv, (8,True), "1 neelem d:!exists:!kv";
    is_deeply @a[my int$=8]:delete:exists:kv, (),         "1 neelem d:exists:kv";
    is_deeply @a[my int$=8]:delete:!exists:kv, (),        "1 neelem d:!exists:kv";
    is @a.elems, 8, "should have been shortened";

    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is_deeply @a[my int$=7]:delete:!exists:p, (7=>False), "7:exists:p 1 eelem";
    ok @a[my int$=7]:!exists,                             "7 should be deleted now";
    is_deeply @a[my int$=7]:delete:exists:!p, (7=>False), "1 neelem exists:!p";
    is_deeply @a[my int$=7]:delete:!exists:!p, (7=>True), "1 neelem !exists:!p";
    is_deeply @a[my int$=7]:delete:exists:p, (),          "1 neelem exists:p";
    is_deeply @a[my int$=7]:delete:!exists:p, (),         "1 neelem !exists:p";
    is @a.elems, 7, "should have been shortened";
} #19

{
    my @a is default(42);
    is @a[my int $=0]:delete, 42,  ':delete non-existing';
    is @a.elems, 0,       'should not vivify';
    is @a[my int $=0]:!delete, 42, ':!delete non-existing';
    is @a.elems, 0,       'should not vivify';

    is @a[my int $=0]:delete:exists, False,  ':delete:exists non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!delete:exists, False, ':!delete:exists non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:delete:!exists, True,  ':delete:!exists non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!delete:!exists, True, ':!delete:!exists non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:delete:exists:kv, (),   ':delete:exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';
    is @a[my int $=0]:!delete:exists:kv, (),  ':!delete:exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';

    is @a[my int $=0]:delete:!exists:kv, (),  ':delete:!exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';
    is @a[my int $=0]:!delete:!exists:kv, (), ':!delete:!exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';

    is @a[my int $=0]:delete:exists:!kv, (0,False),  ':delete:exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[my int $=0]:!delete:exists:!kv, (0,False), ':!delete:exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[my int $=0]:delete:!exists:!kv, (0,True),  ':delete:!exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[my int $=0]:!delete:!exists:!kv, (0,True), ':!delete:!exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[my int $=0]:delete:exists:p, (),   ':delete:exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!delete:exists:p, (),  ':!delete:exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:delete:!exists:p, (),  ':delete:!exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!delete:!exists:p, (), ':!delete:!exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:delete:exists:!p, (0=>False),  ':delete:exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[my int $=0]:!delete:exists:!p, (0=>False), ':!delete:exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[my int $=0]:delete:!exists:!p, (0=>True),  ':delete:!exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[my int $=0]:!delete:!exists:!p, (0=>True), ':!delete:!exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[my int $=0]:exists:kv, (),         ':exists:kv non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!exists:kv, (),        ':!exists:kv non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:exists:!kv, (0,False), ':exists:!kv non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!exists:!kv, (0,True), ':!exists:!kv non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:exists:p, (),          ':exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!exists:p, (),         ':!exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:exists:!p, (0=>False), ':exists:!p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[my int $=0]:!exists:!p, (0=>True), ':!exists:!p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[my int $=0]:kv, (),      ':kv non-existing';
    is @a.elems, 0,       'should not vivify';
    is @a[my int $=0]:!kv, (0,42), ':!kv non-existing';
    is @a.elems, 0,       'should not vivify';

    is @a[my int $=0]:p, (),       ':p non-existing';
    is @a.elems, 0,       'should not vivify';
    is @a[my int $=0]:!p, (0=>42), ':!p non-existing';
    is @a.elems, 0,       'should not vivify';

    is @a[my int $=0]:k, (), ':k non-existing';
    is @a.elems, 0, 'should not vivify';
    is @a[my int $=0]:!k, 0, ':!k non-existing';
    is @a.elems, 0, 'should not vivify';

    is @a[my int $=0]:v, (),  ':v non-existing';
    is @a.elems, 0,  'should not vivify';
    is @a[my int $=0]:!v, 42, ':!v non-existing';
    is @a.elems, 0,  'should not vivify';
} #86
# vim: ft=perl6
�������������������������������������������������rakudo-2013.12/t/spec/S32-array/delete-adverb.t�����������������������������������������������������0000664�0001750�0001750�00000042744�12224265625�020374� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 216;

# L<S02/Names and Variables/:delete>

#-------------------------------------------------------------------------------
# initialisations

my $default = Any;
my $dont    = False;
sub gen_array { (1..10).list }

#-------------------------------------------------------------------------------
# Array

{ # basic sanity
    my @a = gen_array;
    is @a.elems, 10, "do we have a valid array";
} #1

{ # single element
    my Int @a = gen_array;
    my $b     = @a[3];

    #?pugs   3 skip "no adverbials"
    #?niecza 3 skip "no adverbials"
    is @a[3]:delete, $b, "Test for delete single element";
    is @a[3], $default,  "3 should be deleted now";
    is +@a, 10,          "array still has same length";

    #?pugs   11 skip "no adverbials"
    #?niecza 11 skip "no adverbials"
    my $c = @a[9];
    is @a[9]:!delete, $c,       "Test non-deletion with ! single elem";
    is @a[9], $c,               "9 should not have been deleted";
    is @a[9]:delete(0), $c,     "Test non-deletion with (0) single elem";
    is @a[9], $c,               "9 should not have been deleted";
    is @a[9]:delete(False), $c, "Test non-deletion with (False) single elem";
    is @a[9], $c,               "9 should not have been deleted";
    is @a[9]:delete($dont), $c, "Test non-deletion with (\$dont) single elem";
    is @a[9], $c,               "9 should not have been deleted";
    is @a[9]:delete(1), $c,     "Test deletion with (1) single elem";
    is @a[9], $default,         "9 should be deleted now";
    is +@a, 9,                  "array should be shortened now";

    my $d = @a[8]:p;
    #?pugs   7 skip "no adverbials"
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply @a[8]:p:!delete, $d,       "return a single pair out";
    ok @a[8]:exists,                     "8 should not have been deleted";
    is_deeply @a[8]:p:delete,  $d,       "slice a single pair out";
    ok !defined(@a[8]),                  "8 should be deleted now";
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply @a[8]:p:delete,  (),       "slice unexisting single pair out";
    is_deeply @a[8]:!p:delete, (8=>Int), "slice unexisting single pair out";
    is @a.elems, 8, "should have been shortened";

    my $e= (7, @a[7]);
    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is_deeply @a[7]:kv:!delete, $e,      "return a single elem/value out";
    ok @a[7]:exists,                     "7 should not have been deleted";
    is_deeply @a[7]:kv:delete,  $e,      "slice a single elem/value out";
    ok @a[7]:!exists,                    "7 should be deleted now";
    is_deeply @a[7]:kv:delete,  (),      "slice unexisting single elem/value";
    is_deeply @a[7]:!kv:delete, (7,Int), "slice unexisting single elem/value";
    is @a.elems, 7, "should have been shortened";

    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is @a[6]:k:!delete,        6, "return a single elem out";
    ok @a[6]:exists,              "6 should not have been deleted";
    is @a[6]:k:delete,         6, "slice a single elem out";
    ok @a[6]:!exists,             "6 should be deleted now";
    is_deeply @a[6]:k:delete, (), "slice unexisting single elem";
    is @a[6]:!k:delete,        6, "slice unexisting single elem";
    is @a.elems, 6, "should have been shortened";

    my $g= @a[5];
    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is @a[5]:v:!delete,        $g, "return a single value out";
    ok @a[5]:exists,               "5 should not have been deleted";
    is @a[5]:v:delete,         $g, "slice a single value out";
    ok @a[5]:!exists,              "5 should be deleted now";
    is_deeply @a[5]:v:delete,  (), "slice unexisting single elem";
    is @a[5]:!v:delete,       Int, "slice unexisting single elem";
    is @a.elems, 5, "should have been shortened";
} #42

{ # single elem, combinations with :exists
    my @a = gen_array;

    #?pugs   5 skip "no adverbials"
    #?niecza 5 todo "cannot combine adverbial pairs"
    ok (@a[9]:delete:exists) === True,  "9:exists single existing elem";
    ok @a[9]:!exists,                   "9 should be deleted now";
    ok (@a[9]:delete:exists) === False, "9:exists one non-existing elem";
    ok (@a[9]:delete:!exists) === True, "9:!exists one non-existing elem";
    is @a.elems, 9, "should have been shortened";

    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is_deeply @a[8]:delete:!exists:kv, (8,False), "8:exists:kv 1 eelem";
    ok @a[8]:!exists,                             "8 should be deleted now";
    is_deeply @a[8]:delete:exists:!kv, (8,False), "1 neelem d:exists:!kv";
    is_deeply @a[8]:delete:!exists:!kv, (8,True), "1 neelem d:!exists:!kv";
    is_deeply @a[8]:delete:exists:kv, (),         "1 neelem d:exists:kv";
    is_deeply @a[8]:delete:!exists:kv, (),        "1 neelem d:!exists:kv";
    is @a.elems, 8, "should have been shortened";

    #?pugs   7 skip "no adverbials"
    #?niecza 7 todo "cannot combine adverbial pairs"
    is_deeply @a[7]:delete:!exists:p, (7=>False), "7:exists:p 1 eelem";
    ok @a[7]:!exists,                             "7 should be deleted now";
    is_deeply @a[7]:delete:exists:!p, (7=>False), "1 neelem exists:!p";
    is_deeply @a[7]:delete:!exists:!p, (7=>True), "1 neelem !exists:!p";
    is_deeply @a[7]:delete:exists:p, (),          "1 neelem exists:p";
    is_deeply @a[7]:delete:!exists:p, (),         "1 neelem !exists:p";
    is @a.elems, 7, "should have been shortened";
} #19

{ # multiple elements, without :exists
    my Int @a = gen_array;
    my $b = @a[1,3];

    #?pugs   3 skip "no adverbials"
    #?niecza 3 skip "no adverbials"
    is_deeply @a[1,3]:delete, $b, "Test for delete multiple elements";
    is_deeply @a[1,3], (Int,Int), "1 3 should be deleted now";
    is +@a, 10,                   "1 3 should be deleted now";

    #?pugs   11 skip "no adverbials"
    #?niecza 11 skip "no adverbials"
    my $c = @a[2,4,9];
    is_deeply @a[2,4,9]:!delete,       $c, "Test non-deletion with ! N";
    is_deeply @a[2,4,9],               $c, "2 4 9 should not have been deleted";
    is_deeply @a[2,4,9]:delete(0),     $c, "Test non-deletion with (0) N";
    is_deeply @a[2,4,9],               $c, "2 4 9 should not have been deleted";
    is_deeply @a[2,4,9]:delete(False), $c, "Test non-deletion with (False) N";
    is_deeply @a[2,4,9],               $c, "2 4 9 should not have been deleted";
    is_deeply @a[2,4,9]:delete($dont), $c, "Test non-deletion with (\$dont) N";
    is_deeply @a[2,4,9],               $c, "2 4 9 should not have been deleted";
    is_deeply @a[2,4,9]:delete(1),     $c, "Test deletion with (1) N";
    is_deeply @a[2,4,9], (Int,Int,Int), "2 4 9 should be deleted now";
    is +@a, 9,                          "array should be shortened now";

    my $hi = @a[6,8]:p;
    #?pugs   4 skip "no adverbials"
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply @a[6,8]:p:!delete, $hi, "return pairs";
    is @a[6,8]:p, $hi,                "6 8 should not have been deleted";
    is_deeply @a[6,8]:p:delete,  $hi, "slice pairs out";
    is +@a, 8,                        "8 should be deleted now by count";
} #14

{ # multiple keys, combinations with :exists
    my @a = gen_array;

    #?pugs   9 skip "no adverbials"
    #?niecza 9 todo "cannot combine adverbial pairs"
    is_deeply @a[2,3]:!delete:exists, (True,True),  "!d:exists ekeys";
    is_deeply @a[2,3]:delete:exists, (True,True),   "d:exists ekeys";
    ok @a[2]:!exists,                               "2 should be deleted now";
    ok @a[3]:!exists,                               "3 should be deleted now";
    is_deeply @a[2,3]:delete:exists, (False,False), "d:exists nekeys";
    is_deeply @a[2,3]:delete:!exists, (True,True),  "d:!exists nekeys";
    is_deeply @a[1,2]:delete:exists, (True,False),  "d:exists nekeys";
    is_deeply @a[3,9]:delete:!exists, (True,False), "d:!exists nekeys";
    is +@a, 9,                        "9 should be deleted now by count";
} #9

{
    my @a = gen_array;

    #?pugs   8 skip "no adverbials"
    #?niecza 8 todo "cannot combine adverbial pairs"
    is_deeply @a[4,5]:!delete:!exists:kv,
    (4,False,5,False),              "!d:!exists:kv ekeys";
    is_deeply @a[4,5]:delete:!exists:kv,
    (4,False,5,False),              "d:!exists:kv ekeys";
    ok @a[4]:!exists,               "4 should be deleted now";
    ok @a[5]:!exists,               "5 should be deleted now";
    is_deeply @a[4,5]:delete:exists:!kv,
    (4,False,5,False),              "d:exists:!kv nekeys";
    is_deeply @a[4,5]:delete:!exists:!kv,
    (4,True,5,True),                "d:!exists:!kv nekeys";
    is_deeply @a[4,6]:delete:exists:kv,
    (6,True),                       "d:exists:kv nekey/ekey";
    is_deeply @a[7,4]:delete:!exists:kv,
    (7,False),                      "d:!exists:kv ekey/nekey";
    is +@a, 10,                     "only deletions in middle";
} #9

{
    my @a = gen_array;

    #?pugs   8 skip "no adverbials"
    #?niecza 8 todo "cannot combine adverbial pairs"
    is_deeply @a[4,5]:!delete:!exists:p,
    (4=>False,5=>False),            "!d:!exists:p ekeys";
    is_deeply @a[4,5]:delete:!exists:p,
    (4=>False,5=>False),            "d:!exists:p ekeys";
    ok @a[4]:!exists,               "4 should be deleted now";
    ok @a[5]:!exists,               "5 should be deleted now";
    is_deeply @a[4,5]:delete:exists:!p,
    (4=>False,5=>False),            "d:exists:!p nekeys";
    is_deeply @a[4,5]:delete:!exists:!p,
    (4=>True,5=>True),              "d:!exists:!p nekeys";
    is_deeply @a[4,6]:delete:exists:p,
    ((),6=>True),                   "d:exists:p nekey/ekey";
    is_deeply @a[7,4]:delete:!exists:p,
    (7=>False,()),                  "d:!exists:p ekey/nekey";
    is +@a, 10,                     "only deletions in middle";
} #9


{ # whatever
    my @a   = gen_array;
    my $all = @a[^@a.elems];

    #?pugs   2 skip "no adverbials"
    #?niecza 2 skip "no adverbials"
    is_deeply @a[*]:delete, $all, "Test deletion with whatever";
    is +@a, 0,                    "* should be deleted now";
} #2

{
    my @a   = gen_array;
    my $all = @a[^@a.elems];

    #?pugs   10 skip "no adverbials"
    #?niecza 10 skip "no adverbials"
    is_deeply @a[*]:!delete,       $all, "Test non-deletion with ! *";
    is_deeply @a[*]:delete(0),     $all, "Test non-deletion with (0) *";
    is_deeply @a[*]:delete(False), $all, "Test non-deletion with (False) *";
    is_deeply @a[*]:delete($dont), $all, "Test non-deletion with (\$dont) *";

    is +@a, 10,                      "* should not be deleted now";
    is_deeply @a[*]:delete(1), $all, "Test deletion with (1) whatever";
    is +@a, 0,                       "* should be deleted now";
} #7

{
    my @a   = gen_array;
    my $all = (^10).map: { $_ => @a[$_] };

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is @a[*]:p:!delete, $all, "return all pairs";
    is +@a, 10,               "* should not be deleted";
    is @a[*]:p:delete,  $all, "slice out all pairs";
    is +@a, 0,               "* should be deleted now";
} #4

{
    my @a  = gen_array;
    my @i  = True  xx @a.elems;
    my @ni = False xx @a.elems;

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is @a[*]:!delete:exists, @i,  "!d:exists whatever";
    is +@a, 10,                   "* should not be deleted";
    is @a[*]:delete:!exists, @ni, "d:!exists whatever";
    is +@a, 0,                    "* should be deleted now";
} #4

{
    my @a  = gen_array;
    my @i  = (^10).map: { ($_,True) };
    my @ni = (^10).map: { ($_,False) };

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is @a[*]:!delete:exists:kv, @i,  ":!d:exists:kv whatever";
    is +@a, 10,                      "* should not be deleted";
    is @a[*]:delete:!exists:kv, @ni, "d:!exists:kv whatever";
    is +@a, 0,                       "* should be deleted now";

    @a = gen_array;
    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is @a[*]:!delete:exists:!kv, @i,  ":!d:exists:!kv whatever";
    is +@a, 10,                      "* should not be deleted";
    is @a[*]:delete:!exists:!kv, @ni, "d:!exists:!kv whatever";
    is +@a, 0,                       "* should be deleted now";
} #8

{
    my @a  = gen_array;
    my @i  = (^10).map: { ($_ => True) };
    my @ni = (^10).map: { ($_ => False) };

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is @a[*]:!delete:exists:p, @i,  ":!d:exists:p whatever";
    is +@a, 10,                     "* should not be deleted";
    is @a[*]:delete:!exists:p, @ni, "d:!exists:p whatever";
    is +@a, 0,                      "* should be deleted now";

    @a = gen_array;
    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is @a[*]:!delete:exists:!p, @i,  ":!d:exists:!p whatever";
    is +@a, 10,                     "* should not be deleted";
    is @a[*]:delete:!exists:!p, @ni, "d:!exists:!p whatever";
    is +@a, 0,                      "* should be deleted now";
} #8

{
    my @a is default(42);
    is @a[0]:delete, 42,  ':delete non-existing';
    is @a.elems, 0,       'should not vivify';
    is @a[0]:!delete, 42, ':!delete non-existing';
    is @a.elems, 0,       'should not vivify';

    is @a[0]:delete:exists, False,  ':delete:exists non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!delete:exists, False, ':!delete:exists non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:delete:!exists, True,  ':delete:!exists non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!delete:!exists, True, ':!delete:!exists non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:delete:exists:kv, (),   ':delete:exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';
    is @a[0]:!delete:exists:kv, (),  ':!delete:exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';

    is @a[0]:delete:!exists:kv, (),  ':delete:!exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';
    is @a[0]:!delete:!exists:kv, (), ':!delete:!exists:kv non-existing';
    is @a.elems, 0,                  'should not vivify';

    is @a[0]:delete:exists:!kv, (0,False),  ':delete:exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[0]:!delete:exists:!kv, (0,False), ':!delete:exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[0]:delete:!exists:!kv, (0,True),  ':delete:!exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[0]:!delete:!exists:!kv, (0,True), ':!delete:!exists:!kv non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[0]:delete:exists:p, (),   ':delete:exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!delete:exists:p, (),  ':!delete:exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:delete:!exists:p, (),  ':delete:!exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!delete:!exists:p, (), ':!delete:!exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:delete:exists:!p, (0=>False),  ':delete:exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[0]:!delete:exists:!p, (0=>False), ':!delete:exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[0]:delete:!exists:!p, (0=>True),  ':delete:!exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';
    is @a[0]:!delete:!exists:!p, (0=>True), ':!delete:!exists:!p non-existing';
    is @a.elems, 0,                         'should not vivify';

    is @a[0]:exists:kv, (),         ':exists:kv non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!exists:kv, (),        ':!exists:kv non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:exists:!kv, (0,False), ':exists:!kv non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!exists:!kv, (0,True), ':!exists:!kv non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:exists:p, (),          ':exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!exists:p, (),         ':!exists:p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:exists:!p, (0=>False), ':exists:!p non-existing';
    is @a.elems, 0,                 'should not vivify';
    is @a[0]:!exists:!p, (0=>True), ':!exists:!p non-existing';
    is @a.elems, 0,                 'should not vivify';

    is @a[0]:kv, (),      ':kv non-existing';
    is @a.elems, 0,       'should not vivify';
    is @a[0]:!kv, (0,42), ':!kv non-existing';
    is @a.elems, 0,       'should not vivify';

    is @a[0]:p, (),       ':p non-existing';
    is @a.elems, 0,       'should not vivify';
    is @a[0]:!p, (0=>42), ':!p non-existing';
    is @a.elems, 0,       'should not vivify';

    is @a[0]:k, (), ':k non-existing';
    is @a.elems, 0, 'should not vivify';
    is @a[0]:!k, 0, ':!k non-existing';
    is @a.elems, 0, 'should not vivify';

    is @a[0]:v, (),  ':v non-existing';
    is @a.elems, 0,  'should not vivify';
    is @a[0]:!v, 42, ':!v non-existing';
    is @a.elems, 0,  'should not vivify';
} #86
# vim: ft=perl6
����������������������������rakudo-2013.12/t/spec/S32-array/delete.t������������������������������������������������������������0000664�0001750�0001750�00000007724�12224265625�017132� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 29;

=begin description

Basic C<delete> tests, see S32.

=end description

# L<S32::Containers/"Array"/=item delete>

sub make-string(@a) {
    ~@a.map({ $_ // "Any()" });
}

# W/ positive indices:
{
  my @array = <a b c d>;
  is ~@array, "a b c d", "basic sanity (1)";
  is ~(@array[2]:delete), "c",
    "deletion of an array element returned the right thing";
  is make-string(@array), "a b Any() d", "deletion of an array element";

  is ~(@array[3]:delete), "d",
    "deletion of array elements returned the right things";
  #?pugs todo
  is make-string(@array), "a b", "deletion of array elements (1)";
  #?pugs todo
  is +@array, 2,     "deletion of array elements (2)";
}

# W/ negative indices:
{
  my @array = <a b c d>;
  #?pugs todo
  is ~(@array[*-2]:delete), "c",
    "deletion of array element accessed by an negative index returned the right thing";
  # @array is now ("a", "b", Any, "d") ==> double spaces
  #?pugs todo
  is make-string(@array), "a b Any() d", "deletion of an array element accessed by an negative index (1)";
  is +@array,        4, "deletion of an array element accessed by an negative index (2)";

  #?pugs todo
  is ~(@array[*-1]:delete), "d",
    "deletion of last array element returned the right thing";
  # @array is now ("a", "b")
  #?pugs todo
  is ~@array, "a b", "deletion of last array element (1)";
  #?pugs todo
  is +@array,     2, "deletion of last array element (2)";
}

# W/ multiple positive and negative indices:
#?pugs todo
{
  my @array = <a b c d e f>;
  is ~(@array[2, *-3, *-1]:delete), "c d f",
    "deletion of array elements accessed by positive and negative indices returned right things";
  # @array is now ("a", "b", Any, Any, "e") ==> double spaces
  is make-string(@array), "a b Any() Any() e",
    "deletion of array elements accessed by positive and negative indices (1)";
  is +@array, 5,
    "deletion of array elements accessed by positive and negative indices (2)";
}

# Results taken from Perl 5
#?niecza todo "Not sure if this test is correct or not"
#?pugs   todo "Not sure if this test is correct or not"
{
  my @array = <a b c>;
  is ~(@array[2, *-1]:delete), "c ",
    "deletion of the same array element accessed by different indices returned right things";
  is ~@array, "a b",
    "deletion of the same array element accessed by different indices (1)";
  is +@array, 2,
    "deletion of the same array element accessed by different indices (2)";
}

# L<S32::Containers/"Array"/"Deleted elements at the end of an Array">
#?pugs todo
{
    my @array;
    @array[8] = 'eight';
    @array[8]:delete;
    is +@array, 0, 'deletion of trailing items purge empty positions';

}

# W/ one range of positive indices
{
  my @array = <a b c d e f>;
  is ~(@array[2..4]:delete), "c d e",
    "deletion of array elements accessed by a range of positives indices returned right things";
  # @array is now ("a", "b", Any, Any, Any, "f") ==> 4 spaces
  is make-string(@array), "a b Any() Any() Any() f",
    "deletion of array elements accessed by a range of positive indices (1)";
  is +@array, 6,
    "deletion of array elements accessed by a range of positive indices (2)";
}

{
  my @array = <a b c d e f>;
  is ~(@array[2^..4]:delete), "d e",
    "deletion of array elements accessed by a range of positives indices returned right things (2)";
  # @array is now ("a", "b", "c", Any, Any, "f") ==> 4 spaces
  is make-string(@array), "a b c Any() Any() f",
    "deletion of array elements accessed by a range of positive indices (3)";
  is +@array, 6,
    "deletion of array elements accessed by a range of positive indices (4)";
}

# RT #67446
{
    my @array = 0..1;
    #?pugs todo
    is ~(eval @array.perl ), '0 1', '@array.perl works after init';
    is ~( map { 1 }, @array ), '1 1', 'map @array works after init';
    @array[0]:delete;
    lives_ok { @array.perl }, '@array.perl lives after delete';
    lives_ok { map { 1 }, @array }, 'map @array lives after delete';
}

# TODO More exclusive bounds checks

# TODO W/ multiple ranges
# vim: ft=perl6
��������������������������������������������rakudo-2013.12/t/spec/S32-array/elems.t�������������������������������������������������������������0000664�0001750�0001750�00000001640�12224265625�016764� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::Containers/"Array"/=item "elems">
plan 11;

{
  my @a;
  is @a.elems, 0, ".elems works on uninitialized arrays";
}

{
  my @a = ();
  is @a.elems, 0, ".elems works on empty arrays";
}

{
  my @a = <a b c>;
  is @a.elems, 3, ".elems works on initialized arrays";
}

#?niecza todo
#?pugs todo
{
  my $a;
  is $a.elems, 0, ".elems does works on arbitrary scalars";
}

{
  my $a = [];
  is $a.elems, 0, ".elems works on empty arrayrefs";
}

{
  my $a = [<a b c>];
  is $a.elems, 3, ".elems works on initialized arrayrefs (1)";
}

{
  my $a = <a b c>;
  is $a.elems, 3, ".elems works on initialized arrayrefs (2)";
}

{
  eval_dies_ok 'elems(1,2,3,4', "elems(1,2,3,4) should not work";
}

{
  is (elems (1,2,3,4)), 4, "elems (1,2,3,4) should work";
}

{
  is (elems [1,2,3,4]), 4, "elems [1,2,3,4] should work";
}

{
  is (elems ([1,2,3,4],)), 1, "elems ([1,2,3,4],) should return 1";
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/end.t���������������������������������������������������������������0000664�0001750�0001750�00000001674�12224265625�016434� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::Containers/"Array"/"end">
plan 12;

{
  my @a;
  is @a.end, -1, ".end works on uninitialized arrays";
}

{
  my @a = ();
  is @a.end, -1, ".end works on empty arrays";
}

{
  my @a = <a b c>;
  is @a.end, 2, ".end works on initialized arrays";
}

{
  my $a;
  #?pugs todo
  is $a.end, -1, ".end works on arbitrary scalars (1)";
}

{
  my $a = 42;
  #?pugs todo
  is $a.end, 0, ".end works on arbitrary scalars (2)";
}

{
  my $a = [];
  is $a.end, -1, ".end works on empty arrayrefs";
}

{
  my $a = [<a b c>];
  is $a.end, 2, ".end works on initialized arrayrefs (1)";
}

{
  my $a = <a b c>;
  is $a.end, 2, ".end works on initialized arrayrefs (2)";
}

{
  eval_dies_ok 'end(1,2,3,4)', "end(1,2,3,4) should not work";
}

{
  is (end (1,2,3,4)), 3, "end (1,2,3,4) should work";
}

{
  is (end [1,2,3,4]), 3, "end [1,2,3,4] should work";
}

{
  is (end ([1,2,3,4],)), 0, "end ([1,2,3,4],) should return 0";
}

# vim: ft=perl6
��������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/exists-adverb.t�����������������������������������������������������0000664�0001750�0001750�00000011662�12237474612�020446� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 52;

# L<S02/Names and Variables/:exists>
# L<S32::Containers/"Array"/=item exists>

#?niecza skip "no adverbials"
#?pugs   skip "no adverbials"
{
    my @array = <a b c d>;
    ok @array[0]:exists,    "exists(positive index) on arrays (1)";
    ok @array[1]:exists,    "exists(positive index) on arrays (2)";
    ok @array[2]:exists,    "exists(positive index) on arrays (3)";
    ok @array[3]:exists,    "exists(positive index) on arrays (4)";
    ok @array[4]:!exists,   "exists(positive index) on arrays (5)";
    nok @array[42]:exists,  "exists(positive index) on arrays (6)";
}

#-------------------------------------------------------------------------------
# initialisations

my $default = Any;
my $dont    = False;
sub gen_array { (1..10).list }

#-------------------------------------------------------------------------------
# Array

#?pugs skip "no adverbials"
{
    my @a = gen_array;
    is @a.elems, 10, "basic sanity";

    #?niecza 4 skip "no adverbials"
    isa_ok @a[ 3]:exists, Bool,  "Bool test for exists single element";
    isa_ok @a[ 3]:!exists, Bool, "!Bool test for exists single element";
    isa_ok @a[10]:exists, Bool,  "Bool test for non-exists single element";
    isa_ok @a[10]:!exists, Bool, "!Bool test for non-exists single element";
    ok     @a[ 3]:exists,        "Test for exists single element";
    ok   !(@a[10]:exists),       "Test for non-exists single element";

    #?niecza 10 skip "no adverbials"
    ok !(@a[ 9]:!exists),       "Test non-exists with ! single elem 9";
    ok   @a[10]:!exists,        "Test non-exists with ! single elem 10";
    ok !(@a[ 9]:exists(0)),     "Test non-exists with (0) single elem 9";
    ok   @a[10]:exists(0),      "Test non-exists with (0) single elem 10";
    ok !(@a[ 9]:exists(False)), "Test non-exists with (False) single elem 9";
    ok   @a[10]:exists(False),  "Test non-exists with (False) single elem 10";
    ok !(@a[ 9]:exists($dont)), "Test non-exists with (\$dont) single elem 9";
    ok   @a[10]:exists($dont),  "Test non-exists with (\$dont) single elem 10";
    ok   @a[ 9]:exists(1),      "Test exists with (1) single elem 9";
    ok !(@a[10]:exists(1)),     "Test exists with (1) single elem 10";

    is_deeply @a[1,2, 4]:exists,   (True, True, True),   "Test exists TTT";
    is_deeply @a[1,2,10]:exists,   (True, True, False),  "Test exists TTF";
    is_deeply (@a[]:exists).list, True xx 10,            "Test non-exists T[]";
    is_deeply (@a[*]:exists).list, True xx 10,           "Test non-exists T[*]";
    #?niezca 3 todo "adverbial pairs only used as True"
    is_deeply @a[1,2, 4]:!exists,  (False,False,False),  "Test non-exists FFF";
    is_deeply @a[1,2,10]:!exists,  (False,False,True),   "Test non-exists FFT";
    is_deeply (@a[]:!exists).list, False xx 10,          "Test non-exists F[]";
    is_deeply (@a[*]:!exists).list, False xx 10,         "Test non-exists F[*]";

    #?niezca 6 todo "no combined adverbial pairs"
    is_deeply @a[1,2, 4]:exists:kv,
      (1,True,2,True,4,True),                     "Test exists:kv TTT";
    is_deeply @a[1,2,10]:exists:kv,
      (1,True,2,True),                            "Test exists:kv TT.";
    is_deeply @a[1,2,10]:exists:!kv,
      (1,True,2,True,10,False),                   "Test exists:!kv TTF";
    is_deeply @a[1,2, 4]:!exists:kv,
      (1,False,2,False,4,False),                  "Test !exists:kv FFF";
    is_deeply @a[1,2,10]:!exists:kv,
      (1,False,2,False),                          "Test !exists:kv FF.";
    is_deeply @a[1,2,10]:!exists:!kv,
      (1,False,2,False,10,True),                  "Test !exists:kv FFT";

    #?niezca 6 todo "no combined adverbial pairs"
    is_deeply @a[1,2, 4]:exists:p,
      (1=>True,2=>True,4=>True),                  "Test exists:p TTT";
    is_deeply @a[1,2,10]:exists:p,
      (1=>True,2=>True),                          "Test exists:p TT.";
    is_deeply @a[1,2,10]:exists:!p,
      (1=>True,2=>True,10=>False),                "Test exists:!p TTF";
    is_deeply @a[1,2, 4]:!exists:p,
      (1=>False,2=>False,4=>False),               "Test !exists:p FFF";
    is_deeply @a[1,2,10]:!exists:p,
      (1=>False,2=>False),                        "Test !exists:p FF.";
    is_deeply @a[1,2,10]:!exists:!p,
      (1=>False,2=>False,10=>True),               "Test !exists:!p FFT";

    #?niezca 6 todo "no combined adverbial pairs"
    dies_ok { @a[1]:exists:k },    "Test exists:k,   invalid combo";
    dies_ok { @a[1]:exists:!k },   "Test exists:!k,  invalid combo";
    dies_ok { @a[1]:!exists:k },   "Test !exists:k,  invalid combo";
    dies_ok { @a[1]:!exists:!k },  "Test !exists:!k, invalid combo";

    #?niezca 6 todo "no combined adverbial pairs"
    dies_ok { @a[1]:exists:v },    "Test exists:v,   invalid combo";
    dies_ok { @a[1]:exists:!v },   "Test exists:!v,  invalid combo";
    dies_ok { @a[1]:!exists:v },   "Test !exists:v,  invalid combo";
    dies_ok { @a[1]:!exists:!v },  "Test !exists:!v, invalid combo";

    is @a.elems, 10, "should be untouched";
} #46

# vim: ft=perl6
������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/keys_values.t�������������������������������������������������������0000664�0001750�0001750�00000001642�12224265625�020213� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 8;

=begin description

Basic C<keys> and C<values> tests for arrays, see S32.

=end description

my @array = <a b c d>;

# L<S32::Containers/"Array"/=item keys>
is(~@array.keys, '0 1 2 3', '@arrays.keys works');
is(~keys(@array), '0 1 2 3', 'keys(@array) works');
is(+@array.keys, +@array, 'we have the same number of keys as elements in the array');

# L<S32::Containers/"Array"/=item values>
is(~@array.values, 'a b c d', '@array.values works');
is(~values(@array), 'a b c d', 'values(@array) works');
is(+@array.values, +@array, 'we have the same number of values as elements in the array');

#?pugs emit #
my $v := @array.values;
#?pugs emit #
$v.shift; $v.shift;
#?pugs skip "Can't modify constant item: VUndef"
is($v.elems, 2, "shifting .values removes an element...");
#?pugs skip "Can't modify constant item: VUndef"
is(@array.elems, 4, "...while leaving original list alone.");

# vim: ft=perl6
����������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/kv.t����������������������������������������������������������������0000664�0001750�0001750�00000003451�12224265625�016301� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 18;

=begin description

Basic C<kv> tests, see S32.

=end description

# L<S32::Containers/"Array"/=item kv>

# (1,).kv works correctly
{
    my @a = ();
    @a = try { (1,).kv };
    #?pugs 2 todo 'bug'
    is(@a[0],0, "first element is 0");
    is(@a[1],1, "second element is 1");
}

# ('a',).kv works correctly
{
    my @a = try { ('a',).kv };
    #?pugs 2 todo 'bug'
    is(@a[0],0, "first element is 0");
    is(@a[1],'a', "second element is 'a'");
}

{ # check the invocant form
    my @array = <a b c d>;
    my @kv = @array.kv;
    is(+@kv, 8, '@array.kv returns the correct number of elems');
    is(~@kv, "0 a 1 b 2 c 3 d",  '@array.kv has no inner list');
}

{ # check the non-invocant form
    my @array = <a b c d>;
    my @kv = kv(@array);
    is(+@kv, 8, 'kv(@array) returns the correct number of elems');
    is(~@kv, "0 a 1 b 2 c 3 d", 'kv(@array) has no inner list');
}

is( 42.kv, [0, 42], "(42).kv works");

# bug in Rakudo found by masak++
{
    my $x = bar => [ baz => 42, sloth => 43 ];
    my $y = :bar[ baz => 42, sloth => 43 ];

    is $x.kv.elems, 2,      'Pair.kv (count)';
    is $x.kv.[0],   'bar',  'Pair.kv (first key)';
    is $y.kv.elems, 2,      'Pair.kv (colonpair)';
    is $y.kv.[0],   'bar',  'Pair.kv (first key) (colonpair)';

    is kv($x).elems, 2,     'kv(Pair) (count)';
    is kv($x).[0],  'bar',  'kv(Pair) (first key)';
    is kv($y).elems, 2,     'kv(Pair) (colonpair)';
    is kv($y).[0],  'bar',  'kv(Pair) (first key (colonpair))';
}

# RT #71086
{
    use MONKEY_TYPING;
    augment class Parcel {
        method test_kv() {
            my @a;
            for <a b c>.kv -> $x {
                @a.push($x);
            }
            @a.join('|');
        }
    }
    is (1, 2).test_kv, '0|a|1|b|2|c', '.kv works within class Parcel';
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/pairs.t�������������������������������������������������������������0000664�0001750�0001750�00000003331�12224265625�016774� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 14;

=begin description

Basic C<pairs> tests, see S32.

=end description

# L<S32::Containers/"Array"/=item pairs>

{
  my @array = <a>;
  my @pairs;
  ok((@pairs = pairs(@array)), "basic pairs on arrays with a function");
  is +@pairs, 1,            "pairs on arrays returned the correct number of elems";
  if +@pairs != 1 {
    skip "skipped tests which depend on a test which failed", 2;
  } else {
    is @pairs[0].key,     0,  "key of pair returned by array.pairs was correct (1)";
    is @pairs[0].value, "a",  "value of pair returned by array.pairs was correct (1)";
  }
}

{
  my @array = <a b c>;
  my @pairs;
  ok((@pairs = @array.pairs), "basic pairs on arrays with oo invocation");
  is +@pairs, 3,            "pairs on arrays returned the correct number of elems";
  if +@pairs != 3 {
    skip "skipped tests which depend on a test which failed", 6;
  } else {
    is @pairs[0].key,     0,  "key of pair returned by array.pairs was correct (1)";
    is @pairs[1].key,     1,  "key of pair returned by array.pairs was correct (2)";
    is @pairs[2].key,     2,  "key of pair returned by array.pairs was correct (3)";
    is @pairs[0].value, "a",  "value of pair returned by array.pairs was correct (1)";
    is @pairs[1].value, "b",  "value of pair returned by array.pairs was correct (2)";
    is @pairs[2].value, "c",  "value of pair returned by array.pairs was correct (3)";
  }
}

#?pugs todo 'bug'
{
    my @array = (17, 23, 42);

    lives_ok { for @array.pairs -> $pair {
        $pair.value += 100;
    } }, 'aliases returned by @array.pairs should be rw (1)';

    #?rakudo todo 'Apparently not rw yet?'
    is @array[1], 123, 'aliases returned by @array.pairs should be rw (2)';
}

# vim: filetype=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/perl.t��������������������������������������������������������������0000664�0001750�0001750�00000001475�12224265625�016627� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

#?pugs   todo "cannot roundtrip arrays"
#?niecza todo "cannot roundtrip arrays"
# simple array
{
    my @a = 1,2;
    is @a.perl, 'Array.new(1, 2)',
      'can we serialize a simple array';
    my $ra = eval(@a.perl);
    is_deeply $ra, @a, 'can we roundtrip simple array';
    ok $ra.of =:= Mu, 'make sure any value can be stored';
} #3

#?pugs   skip "cannot roundtrip arrays with constrained values"
#?niecza skip "cannot roundtrip arrays with constrained values"
# array with constrained values
{
    my Int @a = 1,2;
    is @a.perl, 'Array[Int].new(1, 2)',
      'can we serialize a array with constrained values';
    my $ra = eval(@a.perl);
    is_deeply $ra, @a, 'can we roundtrip array constrained values';
    ok $ra.of =:= Int, 'make sure roundtripped values are Int';
} #3

#vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/pop.t���������������������������������������������������������������0000664�0001750�0001750�00000005636�12224265625�016466� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"Array"/"=item pop">

=begin description

Pop tests

=end description

plan 36;

{ # pop() elements into variables
    my @pop = (-1, 1, 2, 3, 4);
    is(+@pop, 5, 'we have 4 elements in the array');

    my $a = pop(@pop);
    is($a, 4, 'pop(@pop) works');

    is(+@pop, 4, 'we have 3 elements in the array');
    $a = pop @pop;
    is($a, 3, 'pop @pop works');

    is(+@pop, 3, 'we have 2 elements in the array');
    $a = @pop.pop();
    is($a, 2, '@pop.pop() works');

    is(+@pop, 2, 'we have 1 element in the array');
    $a = @pop.pop;
    is($a, 1, '@pop.pop works');

    is(+@pop, 1, 'we have 1 element in the array');
    
    {
        $a = pop(@pop);
        is($a, -1, '@pop.pop works');

        is(+@pop, 0, 'we have no more element in the array');
        ok(!defined(pop(@pop)), 'after the array is exhausted pop() returns undefined');
        #?niecza skip 'undeclared name Failure'
        ok(pop(@pop) ~~ Failure, 'after the array is exhausted pop() returns Failure');
    }
} #13

{ # pop() elements inline
    my @pop = (1, 2, 3, 4);

    is(+@pop, 4, 'we have 4 elements in the array');
    is(pop(@pop), 4, 'inline pop(@pop) works');

    is(+@pop, 3, 'we have 3 elements in the array');
    is((pop @pop), 3, 'inline pop @pop works');

    is(+@pop, 2, 'we have 2 elements in the array');
    is(@pop.pop(), 2, 'inline @pop.pop() works');

    is(+@pop, 1, 'we have 1 element in the array');
    is(@pop.pop, 1, 'inline @pop.pop works');

    is(+@pop, 0, 'we have no more element in the array');
    ok(!defined(pop(@pop)), 'after the array is exhausted pop() returns undefined');
    #?niecza skip 'undeclared name Failure'
    ok(pop(@pop) ~~ Failure, 'after the array is exhausted pop() returns Failure');
} #11

# invocant syntax with inline arrays
{
    is([1, 2, 3].pop, 3, 'this will return 3');
    ok(!defined([].pop), 'this will return undefined');
    #?niecza skip 'undeclared name Failure'
    ok( [].pop ~~ Failure, '[].pop is a Failure' );
} #3

# some edge cases
{
    my @pop;
    ok(!defined(@pop.pop()), 'pop on an un-initialized array returns undefined');
    #?niecza skip 'undeclared name Failure'
    ok( @pop.pop() ~~ Failure, 'pop off uninitialized array is a Failure' );
}

# testing some error cases
{
    my @pop = 1 .. 5;
    eval_dies_ok('pop',            'pop() requires arguments');
    eval_dies_ok('42.pop',         '.pop should not work on scalars');
    eval_dies_ok('pop(@pop,10)'),  'pop() should not allow extra arguments';
    eval_dies_ok('@pop.pop(10)'),  '.pop() should not allow extra arguments';
    eval_dies_ok('@pop.pop = 3'),  'Cannot assign to a readonly variable or a value';
    eval_dies_ok('pop(@pop) = 3'), 'Cannot assign to a readonly variable or a value';
} #6

#?pugs       skip "may run forever"
#?niecza     skip "may run forever"
{
    my @push = 1 .. Inf;
    eval_dies_ok( 'pop @push', 'cannot pop from an Inf array' );
} #1

# vim: ft=perl6
��������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/push.t��������������������������������������������������������������0000664�0001750�0001750�00000011032�12224265625�016632� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/Array/"=item push">

=begin description

Push tests

=end description

plan 51;

# basic push tests
{
    my @push = ();

    is(+@push, 0, 'we have an empty array');

    push(@push, 1);
    is(+@push, 1, 'we have 1 element in the array');
    is(@push[0], 1, 'we found the right element');

    push(@push, 2);
    is(+@push, 2, 'we have 2 elements in the array');
    is(@push[1], 2, 'we found the right element');

    push(@push, 3);
    is(+@push, 3, 'we have 3 elements in the array');
    is(@push[2], 3, 'we found the right element');

    push(@push, 4);
    is(+@push, 4, 'we have 4 elements in the array');
    is(@push[3], 4, 'we found the right element');
}

{
    my @p = ();
    @p.push( 'bughunt' );

    is( +@p, 1, 'single element array' );
    ok( @p ~~ Array, '@p ~~ Array' );

    my @push_result = @p.push( 'yo, check it' );

    is( +@p, 2, 'array received second element' );
    #?pugs todo
    ok( @push_result ~~ @p, 'modified array, returned' );
    is( ~@p, 'bughunt yo, check it', '~@p' );
    #?pugs todo
    is( ~@p.push('!'), 'bughunt yo, check it !', '~ on the push' );
}

# try other variations on calling push()
{
    my @push = ();

    my $val = 100;

    push @push, $val;
    is(+@push, 1, 'we have 1 element in the array');
    is(@push[0], $val, 'push @array, $val worked');

    @push.push(200);
    is(+@push, 2, 'we have 2 elements in the array');
    is(@push[1], 200, '@push.push(200) works');

    @push.push(400);
    is(+@push, 3, 'we have 3 elements in the array');
    is(@push[2], 400, '@push.push(400) works');
}

# try pushing more than one element
{
    my @push = ();

    push @push, (1, 2, 3);
    is(+@push, 3, 'we have 3 elements in the array');
    is(@push[0], 1, 'got the expected element');
    is(@push[1], 2, 'got the expected element');
    is(@push[2], 3, 'got the expected element');

    my @val2 = (4, 5);
    push @push, @val2;
    is(+@push, 5, 'we have 5 elements in the array');
    is(@push[3], 4, 'got the expected element');
    is(@push[4], 5, 'got the expected element');

    push @push, 6, 7, 8;  # push() should be slurpy
    is(+@push, 8, 'we have 8 elements in the array');
    is(@push[5], 6, 'got the expected element');
    is(@push[6], 7, 'got the expected element');
    is(@push[7], 8, 'got the expected element');
}

# now for the push() on an uninitialized array issue
{
    my @push;

    push @push, 42;
    is(+@push, 1, 'we have 1 element in the array');
    is(@push[0], 42, 'got the element expected');

    @push.push(2000);
    is(+@push, 2, 'we have 1 element in the array');
    is(@push[0], 42, 'got the element expected');
    is(@push[1], 2000, 'got the element expected');
}

# testing some edge cases
#?pugs skip '...'
{
    my @push = 0 ... 5;
    is(+@push, 6, 'starting length is 6');

    push(@push);
    is(+@push, 6, 'length is still 6');

    @push.push();
    is(+@push, 6, 'length is still 6');
}

# testing some error cases
{
    eval_dies_ok 'push()', 'push() requires arguments (1)';
    # This one is okay, as push will push 0 elems to a rw arrayref.
    lives_ok({ push([])  }, 'push() requires arguments (2)');
    eval_dies_ok '42.push(3)', '.push should not work on scalars';
}

# Push with Inf arrays (waiting on answers to perl6-compiler email)
# {
#     my @push = 1 .. Inf;
#     # best not to uncomment this it just go on forever
#     todo_throws_ok { 'push @push, 10' }, '?? what should this error message be ??', 'cannot push onto a Inf array';
# }

# nested arrayref
#?pugs skip '...'
{
    my @push = ();
    push @push, [ 21 ... 25 ];

    is(@push.elems,     1, 'nested arrayref, array length is 1');
    is(@push[0].elems,  5, 'nested arrayref, arrayref length is 5');
    is(@push[0][0],    21, 'nested arrayref, first value is 21');
    is(@push[0][*-1],  25, 'nested arrayref, last value is 25');
}

# RT #69548
{
    {
        my $x = 1;
        my @a = ();
        push @a, $x;
        ++$x;

        is @a[0], 1, 'New element created by push(@a, $x) isn\'t affected by changes to $x';
    }
    {
        my $x = 1;
        my @a = ();
        push @a, $x;
        ++@a[0];

        is $x, 1, '$x isn\'t affected by changes to new element created by push(@a, $x)';
    }
}

# RT #109476
#?pugs skip 'Odd number of elements'
{
    my %h = ( <foo> => []);
    push %h<foo>, my $foo = 'bar';
    is %h<foo>, 'bar', 'pushing assignment to array-in-hash';
}

# RT 119061
#?pugs todo
#?niecza todo "https://github.com/sorear/niecza/issues/184"
{
    my Int @a;
    dies_ok( { @a.push: "a" }, "cannot push strings onto in Int array" );
}

# vim: syn=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/rotate.t������������������������������������������������������������0000664�0001750�0001750�00000003261�12231454405�017150� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 27;

# L<S32::Containers/Array/rotate>

{
    my @a = <a b c d e>;
    is ~@a.rotate, 'b c d e a', 'Array.rotate defaults to +1';
    is ~@a, 'a b c d e', 'original array unmodified';
    ok @a.rotate ~~ Positional, 'Array.rotate returns a Positional';

    is ~@a.rotate(2), 'c d e a b', '.rotate(2)';
    is ~@a, 'a b c d e', 'original array still unmodified';

    is ~@a.rotate(-2), 'd e a b c', '.rotate(-2)';
    is ~@a, 'a b c d e', 'original still unmodified (negative)';

    is ~@a.rotate(0), 'a b c d e', '.rotate(0)';
    is ~@a.rotate(5), 'a b c d e', '.rotate(5)';
    is ~@a.rotate(15), 'a b c d e', '.rotate(15)';

    is ~@a.rotate(7), 'c d e a b', '.rotate(7)';
    is ~@a, 'a b c d e', 'original still unmodified (negative)';

    is ~@a.rotate(-8), 'c d e a b', '.rotate(-8)';
    is ~@a, 'a b c d e', 'original still unmodified (negative)';
} #14

# all the same but rotate() sub
{
    my @a = <a b c d e>;
    is ~rotate(@a), 'b c d e a', 'rotate(@a)';
    is ~@a, 'a b c d e', 'original array unmodified';

    is ~rotate(@a, 2), 'c d e a b', 'rotate(@a, 2)';
    is ~@a, 'a b c d e', 'original array still unmodified';

    is ~rotate(@a, -2), 'd e a b c', 'rotate(@a, -2)';
    is ~@a, 'a b c d e', 'original still unmodified (negative)';

    is ~rotate(@a, 0), 'a b c d e', 'rotate(@a, 0)';
    is ~rotate(@a, 5), 'a b c d e', 'rotate(@a, 5)';
    is ~rotate(@a, 15), 'a b c d e', 'rotate(@a, 15)';

    is ~rotate(@a, 7), 'c d e a b', 'rotate(@a, 7)';
    is ~@a, 'a b c d e', 'original still unmodified (negative)';

    is ~rotate(@a, -8), 'c d e a b', 'rotate(@a, -8)';
    is ~@a, 'a b c d e', 'original still unmodified (negative)';
} #13

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/shift.t�������������������������������������������������������������0000664�0001750�0001750�00000005353�12224265625�017001� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"Array"/"=item shift">

=begin description

Shift tests

=end description

plan 31;

{

    my @shift = (1, 2, 3, 4, 5);

    is(+@shift, 5, 'we have 4 elements in our array');
    my $a = shift(@shift);
    is($a, 1, 'shift(@shift) works');

    is(+@shift, 4, 'we have 3 elements in our array');
    $a = shift @shift;
    is($a, 2, 'shift @shift works');

    is(+@shift, 3, 'we have 2 elements in our array');
    $a = @shift.shift();
    is($a, 3, '@shift.shift() works');

    is(+@shift, 2, 'we have 1 element in our array');
    $a = @shift.shift;
    is($a, 4, '@shift.shift works');

    {
        is(+@shift, 1, 'we have 1 element in our array');
        $a = shift(@shift);

        is(+@shift, 0, 'we have no elements in our array');
        ok(!defined(shift(@shift)), 'after the array is exhausted it gives undefined');
    }
}

{
    my @shift = (1, 2, 3, 4);

    is(+@shift, 4, 'we have 4 elements in our array');
    is(shift(@shift), 1, 'inline shift(@shift) works');

    is(+@shift, 3, 'we have 3 elements in our array');
    is((shift @shift), 2, 'inline shift @shift works');

    is(+@shift, 2, 'we have 2 elements in our array');
    is(@shift.shift(), 3, 'inline @shift.shift() works');

    is(+@shift, 1, 'we have 1 elements in our array');
    is(@shift.shift, 4, 'inline @shift.shift works');

    is(+@shift, 0, 'we have no elements in our array');
    ok(!defined(shift(@shift)), 'again, the array is exhausted and we get undefined');
    #?niecza skip 'undeclared name Failure'
    ok( shift(@shift) ~~ Failure, 'again, Failure from shifting empty array' );
}

# invocant syntax with inline arrays
{
    is([1, 2, 3].shift, 1, 'this will return 1');
    ok(!defined([].shift), 'this will return undefined');
    #?niecza skip 'undeclared name Failure'
    ok( [].shift ~~ Failure, 'shift of empty array is Failure' );
}

# testing some edge cases
{
    my @shift;
    ok(!defined(shift(@shift)), 'shift on an empty array returns undefined');
    #?niecza skip 'undeclared name Failure'
    ok( shift(@shift) ~~ Failure, 'shift on empty array is Failure');
}

# testing some error cases
{
    my @shift = 1 .. 5;
    eval_dies_ok('shift() ', 'shift() requires arguments');
    eval_dies_ok('42.shift', '.shift should not work on scalars');
    dies_ok { eval('shift(@shift, 10)') }, 'shift() should not allow extra arguments';
    dies_ok { eval(' @shift.shift(10)') }, 'shift() should not allow extra arguments';
}

# Push with Inf arrays (waiting on answers to perl6-compiler email)
# {
#     my @shift = 1 .. Inf;
#     # best not to uncomment this it just go on forever
#     todo_throws_ok { 'shift(@shift)' }, '?? what should this error message be ??', 'cannot shift off of a Inf array';
# }

done;

# vim: syn=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/splice.t������������������������������������������������������������0000664�0001750�0001750�00000007036�12224265625�017143� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"Array"/"=item splice">

=begin description

This test tests the C<splice> builtin

=end description

plan 38;

my (@a,@b,@res);

#?DOES 2
sub splice_ok (@got, @ref, @exp, @exp_ref, Str $comment) {
  is @got, @exp, "$comment - results match";
  is @ref, @exp_ref, "$comment - array got modified in-place";
};

@a = (1..10);
@b = splice(@a,+@a,0,11,12);

is( @b, [], "push-via-splice result works" );
is( @a, [1..12], "push-via-splice modification works");

{
    my @a = (1..10);
    my @b = splice(@a,+@a,0,11,12);

    is( @b, [], "push-via-splice result works" );
    is( @a, [1..12], "push-via-splice modification works");
}

@a  = ('red', 'green', 'blue');
is( splice(@a, 1, 2), [<green blue>],
  "splice() in scalar context returns an array references");

# Test the single arg form of splice (which should die IMO)
@a = (1..10);
@res = splice(@a);
splice_ok( @res, @a, [1..10],[], "Single-arg splice returns the whole array" );

@a = (1..10);
@res = splice(@a,8,2);
splice_ok( @res, @a, [9,10], [1..8], "3-arg positive indices work");

@a = (1..12);
splice_ok splice(@a,0,1), @a, [1], [2..12], "Simple 3-arg splice";

@a = (1..10);
@res = splice(@a,8);
splice_ok @res, @a, [9,10], [1..8], "2-arg positive indices work";

{
    @a = (1..10);
    @res = splice(@a,*-2,2);
    splice_ok @res, @a, [9,10], [1..8], "3-arg negative indices work";
}

{
    @a = (1..10);
    @res = splice(@a,*-2);
    splice_ok @res, @a, [9,10], [1..8], "2-arg negative indices work";
}

# to be converted into more descriptive tests
@a = (2..10);
splice_ok splice(@a,0,0,0,1), @a, [], [0..10], "Prepending values works";

# Need to convert these
# skip 5, "Need to convert more tests from Perl5";
@a = (0..11);
splice_ok splice(@a,5,1,5), @a, [5], [0..11], "Replacing an element with itself";

@a = (0..11);
splice_ok splice(@a, +@a, 0, 12, 13), @a, [], [0..13], "Appending an array";

{
    @a = (0..13);
    @res = splice(@a, *-@a, +@a, 1, 2, 3);
    splice_ok @res, @a, [0..13], [1..3], "Replacing the array contents from right end";
}

{
    @a = (1, 2, 3);
    splice_ok splice(@a, 1, *-1, 7, 7), @a, [2], [1,7,7,3], "Replacing a array into the middle";
} 

{
    @a = (1,7,7,3);
    splice_ok splice(@a,*-3,*-2,2), @a, [7], [1,2,7,3], "Replacing negative count of elements";
}

# Test the identity of calls to splice:
sub indirect_slurpy_context( *@got ) { @got };

# splice4 gets "CxtItem _" or "CxtArray _" instead of "CxtSlurpy _"
my @tmp = (1..10);
{
    @a = splice @tmp, 5, 3;
    @a = indirect_slurpy_context( @a );
    @tmp = (1..10);
    @b = indirect_slurpy_context( splice @tmp, 5, 3 );
    is( @b, @a, "Calling splice with immediate and indirect context returns consistent results");
    is( @a, [6,7,8], "Explicit call/assignment gives the expected results");
    is( @b, [6,7,8], "Implicit context gives the expected results"); # this is due to the method-fallback bug
}

{
    @tmp = (1..10);
    @a = item splice @tmp, 5, 3;
    is( @a, [6..8], "Explicit scalar context returns an array reference");
}

## test some error conditions

@a = splice([], 1);
is +@a, 0, '... empty arrays are not fatal anymore';
# But this should generate a warning, but unfortunately we can't test for
# warnings yet.

#?pugs todo 'bug'
dies_ok({ 42.splice }, '.splice should not work on scalars');

@a = (1..10);
dies_ok({use fatal; splice(@a,-2)}, "negative offset dies");
dies_ok({use fatal; splice(@a,2,-20)}, "negative size dies");

{
    my @empty;
    #?rakudo todo 'slice bug'
    nok @empty.splice(0, 3), 'splicing an empty array should return the empty ilst';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-array/unshift.t�����������������������������������������������������������0000664�0001750�0001750�00000011252�12224265625�017337� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"Array"/"=item unshift">

=begin description

Unshift tests

=end description

plan 57;

# basic unshift tests

{
    my @unshift = ();

    is(+@unshift, 0, 'we have an empty array');

    unshift(@unshift, 1);
    is(+@unshift, 1, 'we have 1 element in the array');
    is(@unshift[0], 1, 'we found the right element');

    unshift(@unshift, 2);
    is(+@unshift, 2, 'we have 2 elements in the array');
    is(@unshift[0], 2, 'we found the right element');
    is(@unshift[1], 1, 'we found the right element');

    unshift(@unshift, 3);
    is(+@unshift, 3, 'we have 3 element in the array');
    is(@unshift[0], 3, 'we found the right element');
    is(@unshift[1], 2, 'we found the right element');
    is(@unshift[2], 1, 'we found the right element');

    unshift(@unshift, 4);
    is(+@unshift, 4, 'we have 4 element in the array');
    is(@unshift[0], 4, 'we found the right element');
    is(@unshift[1], 3, 'we found the right element');
    is(@unshift[2], 2, 'we found the right element');
    is(@unshift[3], 1, 'we found the right element');
}

# try other variations on calling unshift()

{
    my @unshift = ();

    my $val = 100;

    unshift @unshift, $val;
    is(+@unshift, 1, 'we have 1 element in the array');
    is(@unshift[0], $val, 'unshift @array, $val worked');

    @unshift.unshift(200);
    is(+@unshift, 2, 'we have 2 elements in the array');
    is(@unshift[0], 200, '@unshift.unshift(200) works');
    is(@unshift[1], $val, 'unshift @array, $val worked');

    @unshift.unshift(400);
    is(+@unshift, 3, 'we have 3 elements in the array');
    is(@unshift[0], 400, '@unshift.unshift(400) works');
    is(@unshift[1], 200, '@unshift.unshift(200) works');
    is(@unshift[2], $val, 'unshift @array, $val worked');
}

# try unshifting more than one element

{
    my @unshift = ();

    unshift @unshift, (1, 2, 3);
    is(+@unshift, 3, 'we have 3 elements in the array');
    is(@unshift[0], 1, 'got the expected element');
    is(@unshift[1], 2, 'got the expected element');
    is(@unshift[2], 3, 'got the expected element');

    my @val2 = (4, 5);
    unshift @unshift, @val2;
    is(+@unshift, 5, 'we have 5 elements in the array');
    is(@unshift[0], 4, 'got the expected element');
    is(@unshift[1], 5, 'got the expected element');
    is(@unshift[2], 1, 'got the expected element');
    is(@unshift[3], 2, 'got the expected element');
    is(@unshift[4], 3, 'got the expected element');

    unshift @unshift, 6, 7, 8;
    is(+@unshift, 8, 'we have 8 elements in the array');
    is(@unshift[0], 6, 'got the expected element');
    is(@unshift[1], 7, 'got the expected element');
    is(@unshift[2], 8, 'got the expected element');
    is(@unshift[3], 4, 'got the expected element');
    is(@unshift[4], 5, 'got the expected element');
    is(@unshift[5], 1, 'got the expected element');
    is(@unshift[6], 2, 'got the expected element');
    is(@unshift[7], 3, 'got the expected element');
}

# now for the unshift() on an uninitialized array issue
{
    my @unshift;

    unshift @unshift, 42;
    is(+@unshift, 1, 'we have 1 element in the array');
    is(@unshift[0], 42, 'got the element expected');

    unshift @unshift, 2000;
    is(+@unshift, 2, 'we have 2 elements in the array');
    is(@unshift[0], 2000, 'got the element expected');
    is(@unshift[1], 42, 'got the element expected');
}

# testing some edge cases
#?pugs skip '...'
{
    my @unshift = 0 ... 5;
    is(+@unshift, 6, 'starting length is 6');

    unshift(@unshift);
    is(+@unshift, 6, 'length is still 6');

    @unshift.push();
    is(+@unshift, 6, 'length is still 6');
}

# testing some error cases
{
    eval_dies_ok('unshift()    ', 'unshift() requires arguments');
    eval_dies_ok('42.unshift(3)', '.unshift should not work on scalars');
}

# Push with Inf arrays (waiting on answers to perl6-compiler email)
# {
#     my @unshift = 1 .. Inf;
#     # best not to uncomment this it just go on forever
#     todo_throws_ok { 'unshift @unshift, 10' }, '?? what should this error message be ??', 'cannot unshift onto a Inf array';
# }

# RT #69548
{
     my $x = 1;
     my @a = ();
     unshift @a, $x;
     ++$x;

     is @a[0], 1, 'New element created by unshift(@a, $x) isn\'t affected by changes to $x';
}

# RT #69548
{
    my $x = 1;
    my @a = ();
    unshift @a, $x;
    ++@a[0];

    is $x, 1, '$x isn\'t affected by changes to new element created by unshift(@a, $x)';
}

{
    my @a = <b c>;
    @a.unshift(0);
    is @a.join(','), '0,b,c', 'can unshift an element that boolifies to False';
}


# RT 119061
#?pugs todo
#?niecza todo "https://github.com/sorear/niecza/issues/184"
{
    my Int @a;
    dies_ok( { @a.unshift: "a" }, "cannot unshift strings onto in Int array" );
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-basics/warn.t�������������������������������������������������������������0000664�0001750�0001750�00000002640�12224265625�016755� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 7;

BEGIN { @*INC.push('t/spec/packages') };

use Test::Util;

{
    # RT #69520
    my $alive = 0;
    try {
        warn "# It's OK to see this warning during a test run";
        $alive = 1;
    }
    ok $alive, 'try blocks do not catch exceptions'
}

{
    my $caught = 0;
    {
        CONTROL { default { $caught = 1 } };
        warn "# You shouldn't see this warning";
    }
    ok $caught, 'CONTROL catches exceptions'
}

# RT #73768
{
    my $caught = 0;
    {
        CONTROL { default { $caught = 1 } };
        ~Any
    }
    ok $caught, 'Stringifying Any warns';
}

#?niecza todo
is_run 'use v6; warn; say "alive"',
    {
        status => 0,
        out => rx/alive/,
        err => /:i Warning/,
    },
    'warn() without arguments';

#?rakudo todo 'nom regression'
is_run 'use v6; warn("OH NOEZ"); say "alive"',
    {
        status => 0,
        out => rx/alive/,
        err => rx/ 'OH NOEZ'/ & rx/:i 'line 1'>>/,
    },
    'warn() with arguments; line number';

is_run 'use v6; try {warn("OH NOEZ") }; say "alive"',
    {
        status => 0,
        out => rx/alive/,
        err => rx/ 'OH NOEZ'/,
    },
    'try does not surpress warnings';

#?rakudo todo 'quietly'
#?niecza todo 'quietly NYI'
is_run 'use v6; quietly {warn("OH NOEZ") }; say "alive"',
    {
        status => 0,
        out => rx/alive/,
        err => '',
    },
    'quietly does not surpress warnings';

# vim: ft=perl6
������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-container/cat.t�����������������������������������������������������������0000664�0001750�0001750�00000001143�12224265625�017270� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 6;

# L<S32::Containers/Container/"=item cat">

=begin pod

Tests of

  our Lazy multi Container::cat( **@list );

=end pod

ok(cat() eqv (), 'cat null identity');

ok(cat(1) eqv (1,), 'cat scalar identity');

ok(cat(1..3) eqv 1..3, 'cat list identity');

ok(cat([1..3]) eqv 1..3, 'cat array identity');

# These below work.  Just waiting on eqv.

#?pugs 2 todo 'These tests depend on eqv'
ok(cat({'a'=>1,'b'=>2,'c'=>3}) eqv ('a'=>1, 'b'=>2, 'c'=>3),
    'cat hash identity');

ok(cat((); 1; 2..4; [5..7], {'a'=>1,'b'=>2}) eqv (1..7, 'a'=>1, 'b'=>2),
    'basic cat');

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-container/roundrobin.t����������������������������������������������������0000664�0001750�0001750�00000001303�12224265625�020700� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 5;

# L<S32::Containers/Container/"=item roundrobin">

=begin pod

Tests of

  our Lazy multi Container::roundrobin( Bool :$shortest,
      Bool :$finite, **@list );

=end pod

is roundrobin().elems, 0, 'roundrobin null identity';

is roundrobin(1).join, '1', 'roundrobin scalar identity';

#?pugs skip 'No such method in class Array: "&Str"'
is(roundrobin(1..3).Str,  (1..3).Str, 'roundrobin list identity');

#?rakudo todo 'over-flattening'
#?pugs todo
is(roundrobin([1..3]).elems, 1, 'roundrobin does not flatten array items');


#?pugs todo
is(roundrobin((); 1; 2..4; (5..7); <a b>).join(' '),
   (1, 2, 5, 'a', 3, 6, 'b', 4, 7).join(' '), 'basic roundrobin');

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-container/stringify.t�����������������������������������������������������0000664�0001750�0001750�00000001716�12225464703�020544� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 16;

# quick check that type objects stringify correctly - this has been a problem
# for Niecza in the past

# XXX Should ~Set and Set.Str return something specific?  For now
# just make sure they don't die

is Set.gist, '(Set)', 'Set.gist';
is Set.perl, 'Set', 'Set.perl';
is Set.Str, "", "Set.Str is empty string";
is ~Set, "", "~Set is empty string";

#?niecza 4 skip 'SetHash'
is SetHash.gist, '(SetHash)', 'SetHash.gist';
is SetHash.perl, 'SetHash', 'SetHash.perl';
is SetHash.Str, "", "SetHash.Str is empty string";
is ~SetHash, "", "~SetHash is empty string";

is Bag.gist, '(Bag)', 'Bag.gist';
is Bag.perl, 'Bag', 'Bag.perl';
is Bag.Str, "", "Bag.Str is empty string";
is ~Bag, "", "~Bag is empty string";

#?niecza 4 skip 'BagHash'
is BagHash.gist, '(BagHash)', 'BagHash.gist';
is BagHash.perl, 'BagHash', 'BagHash.perl';
is BagHash.Str, "", "BagHash.Str is empty string";
is ~BagHash, "", "~BagHash is empty string";

# vim: ft=perl6
done;
��������������������������������������������������rakudo-2013.12/t/spec/S32-container/zip.t�����������������������������������������������������������0000664�0001750�0001750�00000002652�12224265625�017331� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin pod

The zip() builtin and operator tests

=end pod

# L<S03/"Traversing arrays in parallel">
# L<S32::Containers/Container/"=item zip">

plan 10;

{
    my @a = (0, 2, 4);
    my @b = (1, 3, 5);

    my @e = (0 .. 5);

    #?niecza skip 'Slicel lists are NYI'
    is(~zip(@a; @b), ~@e, "simple zip");
    is(~(@a Z @b), ~@e, "also with Z char");
};

{
    my @a = (0, 3);
    my @b = (1, 4);
    my @c = (2, 5);

    my @e = (0 .. 5);

    #?niecza skip 'Slicel lists are NYI'
    is(~zip(@a; @b; @c), ~@e, "zip of 3 arrays");
    is(~(@a Z @b Z @c), ~@e, "also with Z char");
};

{
    my @a = (0, 2);
    my @b = (1, 3, 5);
    my @e = (0, 1, 2, 3);

    is (@a Z @b), @e, "zip uses length of shortest";
}

#?rakudo skip 'lvalue zip'
#?niecza skip 'Unable to resolve method LISTSTORE in class List'
{
    my @a;
    my @b;

    (@a Z @b) = (1, 2, 3, 4);
#?pugs todo 'unimpl'
    is(@a, [1, 3], "first half of two zipped arrays as lvalues");
#?pugs todo 'unimpl'
    is(@b, [2, 4], "second half of the lvalue zip");
}

#?pugs todo
{
    my @a = (1..3, 5) Z (6..8, 10);
    is @a.join(', '), "1, 6, 2, 7, 3, 8, 5, 10", 'infix:<Z> imposes list context';
}

# mix arrays and ranges
#?pugs todo
is ('a'..'c' Z 1, 2, 3).join(','), 'a,1,b,2,c,3',
    'can mix arrays and ranges for infix:<Z>';

#?pugs todo
is ("a".."c" Z "?", "a".."b").join('|'), 'a|?|b|a|c|b',
    'can mix arrays and ranges for infix:<Z>';

# vim: ft=perl6
��������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-exceptions/misc.t���������������������������������������������������������0000664�0001750�0001750�00000043632�12241704255�017660� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;

#?DOES 1
throws_like { Buf.new().Str }, X::Buf::AsStr, method => 'Str';;
throws_like 'pack("B",  1)',       X::Buf::Pack, directive => 'B';
throws_like 'Buf.new.unpack("B")', X::Buf::Pack, directive => 'B';
throws_like 'pack "A1", "mÄ"',     X::Buf::Pack::NonASCII, char => 'Ä';
throws_like 'my class Foo { method a() { $!bar } }', X::Attribute::Undeclared,
            symbol => '$!bar', package-name => 'Foo', package-kind => 'class',
            what => 'attribute';
throws_like 'sub f() { $^x }', X::Signature::Placeholder,
            line => 1,
            placeholder => '$^x',
            ;

throws_like 'qr/a/', X::Obsolete, old => rx/<<qr>>/, replacement => rx/<<rx>>/;
throws_like '"a" . "b"', X::Obsolete, replacement => '~';
throws_like 's/a/b/i', X::Obsolete;
# RT #112470
throws_like 'my ${a} = 5', X::Obsolete;

throws_like 'do    { $^x }', X::Placeholder::Block, placeholder => '$^x';
throws_like 'do    { @_  }', X::Placeholder::Block, placeholder => '@_';
throws_like 'class { $^x }', X::Placeholder::Block, placeholder => '$^x';
# RT #76956
throws_like '$^x',           X::Placeholder::Mainline, placeholder => '$^x';
# RT #73502
throws_like '@_',            X::Placeholder::Mainline, placeholder => '@_';
# RT #85942
throws_like '"foo".{ say $^a }', X::Placeholder::Mainline;


throws_like 'sub f(*@ = 2) { }', X::Parameter::Default, how => 'slurpy', parameter => *.not;
throws_like 'sub f($x! = 3) { }', X::Parameter::Default, how => 'required', parameter => '$x';
throws_like 'sub f(:$x! = 3) { }', X::Parameter::Default, how => 'required';
throws_like 'sub f($:x) { }',  X::Parameter::Placeholder,
        parameter => '$:x',
        right     => ':$x';
throws_like 'sub f($?x) { }',  X::Parameter::Twigil,
        parameter => '$?x',
        twigil    => '?';
throws_like 'sub (Int Str $x) { }', X::Parameter::MultipleTypeConstraints;



# some of these redeclaration errors take different code
# paths in rakudo, so we over-test a bit to catch them all,
# even if the tests look rather boring;
throws_like 'sub a { }; sub a { }',X::Redeclaration, symbol => 'a', what => 'routine';
# RT #78370
throws_like 'my &a; multi a { }', X::Redeclaration, symbol => 'a', what => 'routine';
throws_like 'sub a { }; multi sub a { }',X::Redeclaration, symbol => 'a', what => 'routine';
throws_like 'my class A { }; my class A { }',  X::Redeclaration, symbol => 'A';
throws_like 'my class B { }; my subset B of Any;', X::Redeclaration, symbol => 'B';
throws_like 'CATCH { }; CATCH { }', X::Phaser::Multiple, block => 'CATCH';
# multiple return types
throws_like 'sub f(--> List) returns Str { }', X::Redeclaration;
throws_like 'my Int sub f(--> Str) { }', X::Redeclaration;
# RT #115356
throws_like 'class F { }; role F { }', X::Redeclaration, symbol => 'F';

throws_like 'my class A { my @a; @a!List::foo() }',
    X::Method::Private::Permission,
    method          => 'foo',
    calling-package => 'A',
    source-package  => 'List';

throws_like '1!foo()',
    X::Method::Private::Unqualified,
    method          => 'foo';

throws_like 'sub f() { }; f() := 2', X::Bind;
throws_like 'OUTER := 5', X::Bind, target => /OUTER/;
throws_like 'my int $x := 2', X::Bind::NativeType, name => '$x';
throws_like 'my @a; @a[] := <foo bar baz>', X::Bind::ZenSlice, type => Array;
throws_like 'my %a; %a{} := foo=>1, bar=>2, baz=>3', X::Bind::ZenSlice, type => Hash;
throws_like 'my @a; @a[0, 1] := (2, 3)', X::Bind::Slice, type => Array;
throws_like 'my %a; %a<a b> := (2, 3)', X::Bind::Slice, type => Hash;


throws_like 'for (1; 1; 1) { }', X::Obsolete,
    old         => rx/<<for>>/,
    replacement => rx/<<loop>>/;
throws_like 'foreach (1..10) { }', X::Obsolete,
    old         => "'foreach'",
    replacement => "'for'";
throws_like 'undef', X::Obsolete,
    old         => rx/<<undef>>/;
# RT #77118
{
    throws_like '<>', X::Obsolete, old => "<>";
}
# RT #92408
throws_like 'my ($a, $b); $a . $b', X::Obsolete;

throws_like 'my $a::::b', X::Syntax::Name::Null;
throws_like 'unless 1 { } else { }', X::Syntax::UnlessElse;
throws_like 'for my $x (1, 2, 3) { }', X::Syntax::P5;
throws_like ':!foo(3)', X::Syntax::NegatedPair, key => 'foo';
throws_like 'my $0', X::Syntax::Variable::Numeric;
throws_like 'my sub f($0) { }', X::Syntax::Variable::Numeric, what => 'parameter';
throws_like 'my $<a>', X::Syntax::Variable::Match;
throws_like 'my class A { my $!foo }', X::Syntax::Variable::Twigil, twigil => '!', scope => 'my';
#RT #86880
throws_like 'role Breakable { my $!broken = Bool::False; }; class Frobnitz does Breakable {};',
    X::Syntax::Variable::Twigil, twigil => '!', scope => 'my';
throws_like 'my $?FILE', X::Syntax::Variable::Twigil, twigil => '?', scope => 'my';
throws_like 'my $::("foo")', X::Syntax::Variable::IndirectDeclaration;
throws_like '@a', X::Undeclared, symbol => '@a';
# RT #115396
throws_like '"@a[]"', X::Undeclared, symbol => '@a';
throws_like 'augment class Any { }', X::Syntax::Augment::WithoutMonkeyTyping;
throws_like 'use MONKEY_TYPING; augment role Positional { }', X::Syntax::Augment::Illegal;
throws_like 'use MONKEY_TYPING; enum Weekday <Mon Tue>; augment class Weekday { }', X::Syntax::Augment::Illegal;
throws_like 'sub postbla:sym<foo>() { }', X::Syntax::Extension::Category, category => 'postbla';
# RT #73938
throws_like 'sub twigil:<@>() { }', X::Syntax::Extension::Category, category => 'twigil';
throws_like 'sub infix:sym< >() { }', X::Syntax::Extension::Null;
# RT #83992
throws_like 'my @a = 1, => 2', X::Syntax::InfixInTermPosition, infix => '=>';
throws_like 'sub f(:in(:$in)) { }', X::Signature::NameClash, name => 'in';
throws_like '(my $foo) does Int', X::Does::TypeObject;
throws_like '(my $foo) does Int, Bool', X::Does::TypeObject;
# RT #76742
throws_like 'Bool does role { method Str() { $.perl } };', X::Does::TypeObject;
throws_like 'my role R { }; 99 but R("wrong");', X::Role::Initialization;
throws_like 'my role R { has $.x; has $.y }; 99 but R("wrong");', X::Role::Initialization;
throws_like 'my role R { }; 99 does R("wrong");', X::Role::Initialization;
throws_like 'my role R { has $.x; has $.y }; 99 does R("wrong");', X::Role::Initialization;
# RT #73806
throws_like q[if() {}], X::Comp::Group, sorrows => sub (@s) { @s[0] ~~ X::Syntax::KeywordAsFunction};


throws_like 'sub f($a?, $b) { }', X::Parameter::WrongOrder,
    misplaced   => 'required',
    after       => 'optional';
throws_like 'sub f(*@a, $b) { }', X::Parameter::WrongOrder,
    misplaced   => 'required',
    after       => 'variadic';
throws_like 'sub f(*@a, $b?) { }', X::Parameter::WrongOrder,
    misplaced   => 'optional positional',
    after       => 'variadic';

#?rakudo skip 'parsing regression'
throws_like '#`', X::Syntax::Comment::Embedded;
# RT #71814
throws_like "=begin\n", X::Syntax::Pod::BeginWithoutIdentifier, line => 1, filename => rx/eval/;

for <
  $ @ % &
  $^A $^B $^C $^D $^E $^F $^G $^H $^I $^J $^K $^L $^M
  $^N $^O $^P $^Q $^R $^S $^T $^U $^V $^W $^X $^Y $^Z
  $* $" $$ $) $; $& $` $' $| $? $@ $[ $]
  $: $- $+ $= $% $^ $~ @- @+ %- %+ %!
> {
    throws_like $_, X::Syntax::Perl5Var;
}
for  '$<', '$#', '$>' {
    #?rakudo skip 'still handled by <special_var>'
    throws_like $_, X::Syntax::Perl5Var;
}
throws_like '1∞', X::Syntax::Confused;
throws_like 'for 1, 2', X::Syntax::Missing, what => 'block';
throws_like 'my @a()', X::Syntax::Reserved, reserved => /shape/ & /array/;
throws_like 'my &a()', X::Syntax::Reserved, instead  => /':()'/;

# RT #115922
throws_like '"\u"', X::Backslash::UnrecognizedSequence, sequence => 'u';
throws_like '"$"', X::Backslash::NonVariableDollar;

throws_like 'm:i(@*ARGS[0])/foo/', X::Value::Dynamic;

throws_like 'self', X::Syntax::Self::WithoutObject;
throws_like 'class { has $.x = $.y }', X::Syntax::VirtualCall, call => '$.y';
throws_like '$.a', X::Syntax::NoSelf, variable => '$.a';
# RT #59118
throws_like 'my class B0Rk { $.a }',  X::Syntax::NoSelf, variable => '$.a';

throws_like 'has $.x', X::Attribute::NoPackage;
throws_like 'my module A { has $.x }', X::Attribute::Package, package-kind => 'module';

throws_like 'has sub a() { }', X::Declaration::Scope, scope => 'has', declaration => 'sub';
throws_like 'has package a { }', X::Declaration::Scope, scope => 'has', declaration => 'package';
throws_like 'our multi a() { }', X::Declaration::Scope::Multi, scope => 'our';
throws_like 'multi sub () { }', X::Anon::Multi, multiness => 'multi';
throws_like 'proto sub () { }', X::Anon::Multi, multiness => 'proto';
throws_like 'class { multi method () { }}', X::Anon::Multi, routine-type => 'method';
throws_like 'use MONKEY_TYPING; augment class { }', X::Anon::Augment, package-kind => 'class';
throws_like 'use MONKEY_TYPING; augment class NoSuchClass { }', X::Augment::NoSuchType,
    package-kind => 'class',
    package => 'NoSuchClass';
throws_like 'use MONKEY_TYPING; augment class No::Such::Class { }', X::Augment::NoSuchType,
    package => 'No::Such::Class';

throws_like ':45<abcd>', X::Syntax::Number::RadixOutOfRange, radix => 45;
throws_like ':0<0>', X::Syntax::Number::RadixOutOfRange, message => rx/0/;
throws_like 'rx:g/a/',   X::Syntax::Regex::Adverb, adverb => 'g', construct => 'rx';
throws_like 'my sub f($x, $y:) { }', X::Syntax::Signature::InvocantMarker;

throws_like 'Date.new("2012-02-30")', X::OutOfRange,
    range => Range, message => rx/<<1\.\.29>>/;
throws_like 'DateTime.new(year => 2012, month => 5, day => 22, hour => 18, minute => 3, second => 60)',
            X::OutOfRange, comment => /'leap second'/;
throws_like 'use fatal; "foo"[2]', X::OutOfRange, what => rx:i/index/, range => 0..0, got => 2;

throws_like 'sub f() { }; &f.unwrap("foo")', X::Routine::Unwrap;

# X::Constructor::Positional
{
    class Foo { };
    throws_like 'Mu.new(1)',         X::Constructor::Positional, type => Mu;
    throws_like 'Foo.new(1, 2, 3);', X::Constructor::Positional, type => Foo;
}

throws_like 'my %h = 1', X::Hash::Store::OddNumber;

# TOOD: might be X::Syntax::Malformed too...
throws_like 'sub foo;', X::Syntax::Missing, what => 'block';
# RT #75776
throws_like 'my $d; my class A {method x { $d }}; for () { sub }', X::Syntax::Missing, what => 'block';
throws_like 'constant foo;', X::Syntax::Missing, what => /initializer/;
throws_like 'constant * = 3;', X::Syntax::Missing, what => /constant/;
throws_like '1 <=> 2 <=> 3', X::Syntax::NonAssociative, left => '<=>', right => '<=>';

throws_like 'class A {...}; grammar B { ... }', X::Package::Stubbed, packages => <A B>;

throws_like 'my sub a { PRE 0  }; a()', X::Phaser::PrePost, phaser => 'PRE', condition => /0/;
throws_like 'my sub a { POST 0 }; a()', X::Phaser::PrePost, phaser => 'POST', condition => /0/;

throws_like 'use fatal; my $x = "5 foo" + 8;', X::Str::Numeric, source => '5 foo', pos => 1,
            reason => /trailing/;
throws_like '"a".match(:x([1, 2, 3]), /a/).Str', X::Str::Match::x, got => Array;
throws_like '"a".trans([Any.new] => [Any.new])', X::Str::Trans::IllegalKey, key => Any;
throws_like '"a".trans(rx/a/)', X::Str::Trans::InvalidArg, got => Regex;

throws_like '1.foo',  X::Method::NotFound, method => 'foo', typename => 'Int';
throws_like '1.+foo', X::Method::NotFound, method => 'foo', typename => 'Int';
throws_like 'my class Priv { method x { self!foo } }; Priv.x',
                      X::Method::NotFound,
                      method    => '!foo',
                      typename  => 'Priv',
                      private   => { $_ === True };
# RT #77582
throws_like 'my %h; %h.nosuchmethods', X::Method::NotFound, typename => 'Hash';

throws_like '1.List::join', X::Method::InvalidQualifier,
            method         => 'join',
            invocant       => 1,
            qualifier-type => List;

# RT #58558
throws_like '!!! 42', X::AdHoc, payload => 42;
throws_like 'use fatal; ... 42', X::AdHoc, payload => 42;
{
    my $c = 0;
    try {
        ??? 42;
        CONTROL { default { $c++ } }
    }
    is $c, 1, '??? with argument warns';
}

throws_like 'die "foo"', X::AdHoc, backtrace => Backtrace;
throws_like 'use fatal; ~(1, 2, 6 ... 10)', X::Sequence::Deduction;

throws_like 'my class B does Int { }', X::Composition::NotComposable, target-name => 'B', composer => Int;
throws_like 'my Str $x := 3', X::TypeCheck::Binding, got => Int, expected => Str;
throws_like 'sub f() returns Str { 5 }; f', X::TypeCheck::Return, got => Int, expected => Str;
throws_like 'my Int $x = "foo"', X::TypeCheck::Assignment, got => 'foo',
            expected => Int, symbol => '$x';

throws_like 'sub f() { }; f() = 3', X::Assignment::RO;
throws_like '1.0 = 3', X::Assignment::RO;
# RT #113534
throws_like '120 = 3', X::Assignment::RO;
throws_like '1e0 = 3', X::Assignment::RO;
throws_like '"a" = 3', X::Assignment::RO;

throws_like '1.foo', X::Method::NotFound, method => 'foo', typename => 'Int';
throws_like 'my class NC { }; NC.new does NC', X::Mixin::NotComposable,
            :target(*.defined), :rolish(*.^name eq 'NC');
throws_like 'my class NC { }; NC.new but  NC', X::Mixin::NotComposable,
            :target(*.defined), :rolish(*.^name eq 'NC');

throws_like 'last', X::ControlFlow,
            illegal => 'last', enclosing => 'loop construct';
throws_like 'next', X::ControlFlow,
            illegal => 'next', enclosing => 'loop construct';
throws_like 'redo', X::ControlFlow,
            illegal => 'redo', enclosing => 'loop construct';

throws_like 'my package A { }; my class B is A { }', X::Inheritance::Unsupported;

throws_like 'my module Expo { sub f is export { }; { sub f is export { } } }',
                X::Export::NameClash, symbol => '&f';

# RT #113408
throws_like '<a b> »+« <c>', X::HyperOp::NonDWIM,
            left-elems => 2, right-elems => 1,
            operator => { .name eq 'infix:<+>' };

throws_like 'my sub f() { gather { return } }; ~f()', X::ControlFlow::Return;

throws_like 'DateTime.new("2012/04")', X::Temporal::InvalidFormat,
            invalid-str => '2012/04',
            target      => 'DateTime';

throws_like 'Date.new("2012/04")', X::Temporal::InvalidFormat,
            invalid-str => '2012/04',
            target      => 'Date';

throws_like 'eval("foo", :lang<no-such-language>)',
           X::Eval::NoSuchLang,
           lang => 'no-such-language';

throws_like 'DateTime.new("1998-12-31T23:59:60+0200", :timezone<Z>)', X::DateTime::TimezoneClash;

throws_like 'use fatal; (1+2i).Num',  X::Numeric::Real, target => Num;
throws_like 'use fatal; (1+2i).Real', X::Numeric::Real, target => Real;

#RT #114134
{
#?rakudo skip 'RT 114134'
throws_like 'my class A {}; (-> &c, $m { A.new()(); CATCH { default { $m } } } )(A, "")', X::TypeCheck::Binding;

dies_ok {eval(class A{}; (-> &c, $m { A.new()(); CATCH { default { $m } } } )(A, "")) }, "Should fail type check with unbound variable";
}

# RT #75640
# cannot use dies_ok, because it puts the call in the dynamic scope of a
# dispatcher
try {
    proto a() { nextsame };
    a();
}
ok $! ~~ X::NoDispatcher, 'nextsame in proto';

# probably not quite spec, but good enough for now
# RT #79162
throws_like '["a" "b"]', X::Syntax::Confused, reason => 'Two terms in a row';

# suggestions
my $emits_suggestions = False;
{
    try eval('my $foo = 10; say $Foo');
    $emits_suggestions = True if $!.^can("suggestions");
}

if $emits_suggestions {
    throws_like 'my $foo = 10; say $Foo;', X::Undeclared, suggestions => '$foo';
    throws_like 'my @barf = 1, 2, 3; say $barf[2]', X::Undeclared, suggestions => '@barf';

    throws_like 'my $intergalactic-planetary = "planetary intergalactic"; say $IntergalacticPlanetary', X::Undeclared, suggestions => '$intergalactic-planetary';

    throws_like 'class Foo is Junktion {}', X::Inheritance::UnknownParent, suggestions => 'Junction';
    throws_like 'class Bar is junction {}', X::Inheritance::UnknownParent, suggestions => 'Junction';
    throws_like 'class Baz is Juntcion {}', X::Inheritance::UnknownParent, suggestions => 'Junction';

    {
        try eval('say huc("foo")');
        ok $! ~~ X::Undeclared::Symbols, "huc throws X::Undeclared::Symbols";
        is $!.routine_suggestion<huc>, ["&uc"], '&uc is a suggestion';
    }

    try eval('toolongtomatchanything()');
    is +($!.routine_suggestion<toolongtomatchanything>), 0, "no suggestions for a strange name";
    ok $!.message !~~ /Did you mean/, "doesn't show suggestions if there are none.";

    try eval('class TestClassFactoryInterfaceBridgeMock is TooLongOfANameToBeConsideredGoodPerl { }');
    is +($!.suggestions), 0, "no suggestions for a strange class";
    ok $!.message !~~ /Did you mean/, "doesn't show suggestions if there are none.";

    try eval('$i-just-made-this-up = "yup"');
    is +($!.suggestions), 0, "no suggestions for a strange variable";
    ok $!.message !~~ /Did you mean/, "doesn't suggest if there's no suggestions.";

    throws_like 'sub yoink(Junctoin $barf) { }', X::Parameter::InvalidType, suggestions => 'Junction';

    {
        try eval('my cool $a');
        ok $! ~~ X::Comp::Group, 'my cool $a throws an X::Comp::Group.';
        ok $!.sorrows[0] ~~ X::Undeclared, "the first sorrow is X::Undeclared.";
        is $!.sorrows[0].suggestions, <Cool Bool>, "the suggestions are Cool and Bool";
    }

    {
        try eval('Ecxeption.new("wrong!")');
        ok $! ~~ X::Undeclared::Symbols, "Ecxeption.new throws X::Undeclared::Symbols";
        is $!.type_suggestion<Ecxeption>, ["Exception"], 'Exception is a suggestion';
    }
}

throws_like 'class Foobar is Foobar', X::Inheritance::SelfInherit, name => "Foobar";

{
    # RT #69760
    my $code = q{class GrammarUserClass { method bar { PostDeclaredGrammar.parse('OH HAI'); } }; grammar PostDeclaredGrammar { rule TOP { .* } }; GrammarUserClass.bar;};
    throws_like $code, X::Undeclared::Symbols, post_types => { .{"PostDeclaredGrammar"} :exists };
}

{
    throws_like q{if 10 > 5 { say "maths works!" } else if 10 == 5 { say "identity is weird" } else { say "math is weird" }}, X::Syntax::Malformed::Elsif;
}

{
    # RT #72958
    throws_like q{1/2.''()}, X::Method::NotFound, method => '', typename => 'Int';
}

{
    # RT #78314
    throws_like q{role Bottle[::T] { method Str { "a bottle of {T}" } }; class Wine { ... }; say Bottle[Wine].new;}, X::Package::Stubbed;
}

throws_like q[sub f() {CALLER::<$x>}; my $x; f], X::Caller::NotDynamic, symbol => '$x';

done;
������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/delete-adverb.t������������������������������������������������������0000664�0001750�0001750�00000031013�12224265625�020164� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 130;

# L<S02/Names and Variables/:delete>

#-------------------------------------------------------------------------------
# initialisations

my $default = Any;
my $dont    = False;

sub gen_hash {

    # alas not supported by pugs
    #return ("a".."z" Z 1..26).hash;

    my %h;
    my $i = 0;
    for 'a'..'z' { %h{$_} = ++$i; }
    return %h;
}

#-------------------------------------------------------------------------------
# Hash

{ # basic sanity
    my %h = gen_hash;
    is +%h, 26, "basic sanity";
} #1

{ # single key
    my Int %h = gen_hash;
    my $b = %h<b>;

    #?pugs 3 skip "no adverbials"
    is %h<b>:delete, $b, "Test for delete single key";
    ok !defined(%h<b>),  "b hould be deleted now";
    is +%h, 25,          "b should be deleted now by count";

    #?pugs   11 skip "no adverbials"
    #?niecza 11 todo "adverbial pairs only used as boolean True"
    my $c = %h<c>;
    is %h<c>:!delete, $c,       "Test non-deletion with ! single key";
    is %h<c>, $c,               "c should not have been deleted";
    is %h<c>:delete(0), $c,     "Test non-deletion with (0) single key";
    is %h<c>, $c,               "c should not have been deleted";
    is %h<c>:delete(False), $c, "Test non-deletion with (False) single key";
    is %h<c>, $c,               "c should not have been deleted";
    is %h<c>:delete($dont), $c, "Test non-deletion with (\$dont) single key";
    is %h<c>, $c,               "c should not have been deleted";
    is %h<c>:delete(1), $c,     "Test deletion with (1) single key";
    ok !defined(%h<c>),         "c should be deleted now";
    is +%h, 24,                 "c should be deleted now by count";

    my $d = %h<d>:p;
    #?pugs   6 skip "no adverbials"
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply %h<d>:p:!delete, $d,       "return a single pair out";
    ok %h<d>:exists,                     "d should not have been deleted";
    is_deeply %h<d>:p:delete,  $d,       "slice a single pair out";
    ok !defined(%h<d>),                  "d should be deleted now";
    #?niecza 2 todo "cannot combine adverbial pairs"
    is_deeply %h<d>:p:delete,  (),       "slice unexisting single pair out";
    is_deeply %h<d>:!p:delete, (d=>Int), "slice unexisting single pair out";

    my $e= ("e", %h<e>);
    #?pugs   6 skip "no adverbials"
    #?niecza 6 todo "cannot combine adverbial pairs"
    is_deeply %h<e>:kv:!delete, $e,        "return a single key/value out";
    ok %h<e>:exists,                       "e should not have been deleted";
    is_deeply %h<e>:kv:delete,  $e,        "slice a single key/value out";
    ok %h<e>:!exists,                      "e should be deleted now";
    is_deeply %h<e>:kv:delete,  (),        "slice unexisting single key/value";
    is_deeply %h<e>:!kv:delete, ('e',Int), "slice unexisting single key/value";

    #?pugs   6 skip "no adverbials"
    #?niecza 6 todo "cannot combine adverbial pairs"
    is %h<f>:k:!delete,      'f', "return a single key out";
    ok %h<f>:exists,              "f should not have been deleted";
    is %h<f>:k:delete,       'f', "slice a single key out";
    ok %h<f>:!exists,             "f should be deleted now";
    is_deeply %h<f>:k:delete, (), "slice unexisting single key";
    is %h<f>:!k:delete,      'f', "slice unexisting single key";

    my $g= %h<g>;
    #?pugs   6 skip "no adverbials"
    #?niecza 6 todo "cannot combine adverbial pairs"
    is %h<g>:v:!delete,        $g,  "return a single value out";
    ok %h<g>:exists,                "g should not have been deleted";
    is %h<g>:v:delete,         $g,  "slice a single value out";
    ok %h<g>:!exists,               "g should be deleted now";
    is_deeply %h<g>:v:delete,  (),  "slice unexisting single key";
    is %h<g>:!v:delete,        Int, "slice unexisting single key";
} #38

{ # single key, combinations with :exists
    my %h = gen_hash;

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    ok (%h<b>:delete:exists) === True,  "d:exists single existing key";
    ok %h<b>:!exists,                   "b should be deleted now";
    ok (%h<b>:delete:exists) === False, "b:exists one non-existing key";
    ok (%h<b>:delete:!exists) === True, "b:!exists one non-existing key";

    #?pugs   6 skip "no adverbials"
    #?niecza 6 todo "cannot combine adverbial pairs"
    is_deeply %h<d>:delete:!exists:kv, ("d",False), "d:exists:kv 1 ekey";
    ok %h<d>:!exists,                               "d should be deleted now";
    is_deeply %h<d>:delete:exists:!kv, ("d",False), "1 nekey d:exists:!kv";
    is_deeply %h<d>:delete:!exists:!kv, ("d",True), "1 nekey d:!exists:!kv";
    is_deeply %h<d>:delete:exists:kv, (),           "1 nekey d:exists:kv";
    is_deeply %h<d>:delete:!exists:kv, (),          "1 nekey d:!exists:kv";

    #?pugs   6 skip "no adverbials"
    #?niecza 6 todo "cannot combine adverbial pairs"
    is_deeply %h<e>:delete:!exists:p, (e=>False), "d:exists:p 1 ekey";
    ok %h<e>:!exists,                             "e should be deleted now";
    is_deeply %h<e>:delete:exists:!p, (e=>False), "1 nekey exists:!p";
    is_deeply %h<e>:delete:!exists:!p, (e=>True), "1 nekey !exists:!p";
    is_deeply %h<e>:delete:exists:p, (),          "1 nekey exists:p";
    is_deeply %h<e>:delete:!exists:p, (),         "1 nekey !exists:p";
} #16

{ # multiple key, not with :exists
    my Int %h   = gen_hash;
    my @cde = %h<c d e>;

    #?pugs 3 skip "no adverbials"
    is %h<c d e>:delete, @cde, "Test for delete multiple keys";
    ok !any(%h<c d e>),        "c d e should be deleted now";
    is +%h, 23,                "c d e should be deleted now by count";

    #?pugs   11 skip "no adverbials"
    #?niecza 11 todo "adverbial pairs only used as boolean True"
    my $fg = %h<f g>;
    is_deeply %h<f g>:!delete, $fg,       "non-deletion with ! mult";
    is_deeply %h<f g>, $fg,               "f g should not have been deleted";
    is_deeply %h<f g>:delete(0), $fg,     "non-deletion with (0) mult";
    is_deeply %h<f g>, $fg,               "f g should not have been deleted";
    is_deeply %h<f g>:delete(False), $fg, "non-deletion with (False) mult";
    is_deeply %h<f g>, $fg,               "f g should not have been deleted";
    is_deeply %h<f g>:delete($dont), $fg, "non-deletion with (\$dont) multi";
    is_deeply %h<f g>, $fg,               "f g should not have been deleted";
    is_deeply %h<f g>:delete(1), $fg,     "deletion with (1) multi";
    is_deeply %h<f g>, (Int,Int),         "f g should be deleted now";
    is +%h, 21,                           "f g should be deleted now by count";

    my $hi = %h<h i>:p;
    #?pugs   4 skip "no adverbials"
    #?niecza 3 todo "cannot combine adverbial pairs"
    is_deeply %h<h i>:p:!delete, $hi, "return pairs";
    is %h<h i>:p, $hi,                "h i should not have been deleted";
    is_deeply %h<h i>:p:delete,  $hi, "slice pairs out";
    is +%h, 19,                       "h i should be deleted now by count";
} #18

{ # multiple keys, combinations with :exists
    my %h = gen_hash;

    #?pugs   8 skip "no adverbials"
    #?niecza 8 todo "cannot combine adverbial pairs"
    is_deeply %h<b c>:!delete:exists, (True,True),  "!d:exists ekeys";
    is_deeply %h<b c>:delete:exists, (True,True),   "d:exists ekeys";
    ok %h<b>:!exists,                               "b should be deleted now";
    ok %h<c>:!exists,                               "c should be deleted now";
    is_deeply %h<b c>:delete:exists, (False,False), "d:exists nekeys";
    is_deeply %h<b c>:delete:!exists, (True,True),  "d:!exists nekeys";
    is_deeply %h<a b>:delete:exists, (True,False),  "d:exists nekeys";
    is_deeply %h<c x>:delete:!exists, (True,False), "d:!exists nekeys";

    #?pugs   8 skip "no adverbials"
    #?niecza 8 todo "cannot combine adverbial pairs"
    is_deeply %h<e f>:!delete:!exists:kv,
      ("e",False,"f",False),              "!d:!exists:kv ekeys";
    is_deeply %h<e f>:delete:!exists:kv,
      ("e",False,"f",False),              "d:!exists:kv ekeys";
    ok %h<e>:!exists,                     "e should be deleted now";
    ok %h<f>:!exists,                     "f should be deleted now";
    is_deeply %h<e f>:delete:exists:!kv,
      ("e",False,"f",False),              "d:exists:!kv nekeys";
    is_deeply %h<e f>:delete:!exists:!kv,
      ("e",True,"f",True),                "d:!exists:!kv nekeys";
    is_deeply %h<e g>:delete:exists:kv,
      ("g",True),                         "d:exists:kv nekey/ekey";
    is_deeply %h<h e>:delete:!exists:kv,
      ("h",False),                        "d:!exists:kv ekey/nekey";

    #?pugs   8 skip "no adverbials"
    #?niecza 8 todo "cannot combine adverbial pairs"
    is_deeply %h<m n>:!delete:!exists:p,
      (m=>False,n=>False),                "!d:!exists:p ekeys";
    is_deeply %h<m n>:delete:!exists:p,
      (m=>False,n=>False),                "d:!exists:p ekeys";
    ok %h<m>:!exists,                     "m should be deleted now";
    ok %h<n>:!exists,                     "n should be deleted now";
    is_deeply %h<m n>:delete:exists:!p,
      (m=>False,n=>False),                "d:exists:!p nekeys";
    is_deeply %h<m n>:delete:!exists:!p,
      (m=>True,n=>True),                  "d:!exists:!p nekeys";
    is_deeply %h<m o>:delete:exists:p,
      ((),o=>True),                       "d:exists:p nekey/ekey";
    is_deeply %h<p n>:delete:!exists:p,
      (p=>False,()),                      "d:!exists:p ekey/nekey";
} #24

{ # whatever
    my %h   = gen_hash;
    my @all = %h{ %h.keys };

    #?pugs 2 skip "no adverbials"
    is %h{*}:delete, @all, "Test deletion with whatever";
    is +%h, 0,             "* should be deleted now";
} #2

{
    my %h   = gen_hash;
    my $all = %h{ %h.keys };

    #?pugs   10 skip "no adverbials"
    #?niecza 10 todo "adverbial pairs only used as boolean True"
    is_deeply %h{*}:!delete, $all,       "Test non-deletion with ! *";
    is_deeply %h{*}:delete(0), $all,     "Test non-deletion with (0) *";
    is_deeply %h{*}:delete(False), $all, "Test non-deletion with (False) *";
    is_deeply %h{*}:delete($dont), $all, "Test non-deletion with (\$dont) *";
    is_deeply +%h, 26,                   "* should not be deleted now";
    is_deeply %h{*}:delete(1), $all,     "Test deletion with (1) *";
    is_deeply +%h, 0,                    "* should be deleted now by count";
} #7

{
    my %h = gen_hash;
    my %i = %h.clone;

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is %h{*}:p:!delete, %i, "return all pairs";
    is +%h, 26,             "* should not be deleted";
    is %h{*}:p:delete,  %i, "slice out all pairs";
    is +%h, 0,             "* should be deleted now";
} #4

{
    my %h  = gen_hash;
    my @i  = True  xx %h.keys;
    my @ni = False xx %h.keys;

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is %h{*}:!delete:exists, @i,  "!d:exists whatever";
    is +%h, 26,                   "* should not be deleted";
    is %h{*}:delete:!exists, @ni, "d:!exists whatever";
    is +%h, 0,                    "* should be deleted now";
} #4

{
    my %h  = gen_hash;
    my @i  = map { ($_,True) },  %h.keys;
    my @ni = map { ($_,False) }, %h.keys;

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is %h{*}:!delete:exists:kv, @i,  ":!d:exists:kv whatever";
    is +%h, 26,                      "* should not be deleted";
    is %h{*}:delete:!exists:kv, @ni, "d:!exists:kv whatever";
    is +%h, 0,                       "* should be deleted now";

    %h = gen_hash;
    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is %h{*}:!delete:exists:!kv, @i,  ":!d:exists:!kv whatever";
    is +%h, 26,                      "* should not be deleted";
    is %h{*}:delete:!exists:!kv, @ni, "d:!exists:!kv whatever";
    is +%h, 0,                       "* should be deleted now";
} #8

{
    my %h  = gen_hash;
    my %i  = map { $_ => True },  %h.keys;
    my %ni = map { $_ => False }, %h.keys;

    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is %h{*}:!delete:exists:p, %i,  ":!d:exists:p whatever";
    is +%h, 26,                     "* should not be deleted";
    is %h{*}:delete:!exists:p, %ni, "d:!exists:p whatever";
    is +%h, 0,                      "* should be deleted now";

    %h = gen_hash;
    #?pugs   4 skip "no adverbials"
    #?niecza 4 todo "cannot combine adverbial pairs"
    is %h{*}:!delete:exists:!p, %i,  ":!d:exists:!p whatever";
    is +%h, 26,                     "* should not be deleted";
    is %h{*}:delete:!exists:!p, %ni, "d:!exists:!p whatever";
    is +%h, 0,                      "* should be deleted now";
} #8

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/delete.t�������������������������������������������������������������0000664�0001750�0001750�00000001621�12224265625�016725� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;
plan 8;

# L<S02/Names and Variables/:delete>

sub gen_hash {
    my %h;
    my $i = 0;
    for 'a'..'z' { %h{$_} = ++$i; }
    return %h;
}

{
    my %h1 = gen_hash;

    my $b = %h1<b>;
    is %h1<b>:delete, $b, "Test for delete single key.";
}

my %hash = (a => 1, b => 2, c => 3, d => 4);

is +%hash, 4, "basic sanity (2)";
is ~(%hash<a>:delete), "1",
  "deletion of a hash element returned the right value";
is +%hash, 3, "deletion of a hash element";
ok !defined(%hash{"a"}), "deleted hash elements are really deleted";

{
    my $a = 1;
    eval_dies_ok '$a:delete', "Can't :delete a scalar";
}

# RT #68482
{
    my %rt68482 = 1 => 3;
    is (%rt68482<1>:delete).WHAT.gist, 3.WHAT.gist, 'delete.WHAT is the element';

    %rt68482 = 1 => 3;
    my $rt68482 = %rt68482<1>:delete;
    is $rt68482.WHAT.gist, 3.WHAT.gist, '.WHAT of stored delete is the element';
}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/exists-adverb.t������������������������������������������������������0000664�0001750�0001750�00000010743�12237474612�020252� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 46;

# L<S02/Names and Variables/:exists>

#-------------------------------------------------------------------------------
# initialisations

my $default = Any;
my $dont    = False;

sub gen_hash {

    # alas not supported by pugs
    #return ("a".."z" Z 1..26).hash;

    my %h;
    my $i = 0;
    for 'a'..'z' { %h{$_} = ++$i; }
    return %h;
}

#-------------------------------------------------------------------------------
# Hash

#?pugs skip "no adverbials"
{
    my %h = gen_hash;
    is %h.elems, 26, "basic sanity";

    isa_ok %h<b>:exists, Bool,  "Bool test for exists single key";
    isa_ok %h<b>:!exists, Bool, "!Bool test for exists single key";
    isa_ok %h<X>:exists, Bool,  "Bool test for non-exists single key";
    isa_ok %h<X>:!exists, Bool, "!Bool test for non-exists single key";
    ok     %h<b>:exists,       "Test for exists single key";
    ok   !(%h<X>:exists),      "Test for non-exists single key";

    #?niecza  8 todo "adverbial pairs only used as True"
    ok !(%h<c>:!exists),       "Test non-exists with ! single key c";
    ok   %h<X>:!exists,        "Test non-exists with ! single key X";
    ok !(%h<c>:exists(0)),     "Test non-exists with (0) single key c";
    ok   %h<X>:exists(0),      "Test non-exists with (0) single key X";
    ok !(%h<c>:exists(False)), "Test non-exists with (False) single key c";
    ok   %h<X>:exists(False),  "Test non-exists with (False) single key X";
    ok !(%h<c>:exists($dont)), "Test non-exists with (\$dont) single key c";
    ok   %h<X>:exists($dont),  "Test non-exists with (\$dont) single key X";
    ok   %h<c>:exists(1),      "Test exists with (1) single key c";
    ok !(%h<X>:exists(1)),     "Test exists with (1) single key X";

    is_deeply %h<c d e>:exists,  (True, True, True),   "Test exists TTT";
    is_deeply %h<c d X>:exists,  (True, True, False),  "Test exists TTF";
    is_deeply %h{}:exists,       (True  xx 26).Parcel, "Test exists T{}";
    is_deeply %h{*}:exists,      (True  xx 26).Parcel, 'Test exists T{*}';
    #?niezca 3 todo "adverbial pairs only used as True"
    is_deeply %h<c d e>:!exists, (False,False,False),  "Test non-exists FFF";
    is_deeply %h<c d X>:!exists, (False,False,True),   "Test non-exists FFT";
    is_deeply %h{}:!exists,      (False xx 26).Parcel, "Test non-exists F{}";
    is_deeply %h{*}:!exists,     (False xx 26).Parcel, 'Test non-exists F{*}';

    #?niezca 6 todo "no combined adverbial pairs"
    is_deeply %h<c d e>:exists:kv,
      ("c",True,"d",True,"e",True),                     "Test exists:kv TTT";
    is_deeply %h<c d X>:exists:kv,
      ("c",True,"d",True),                              "Test exists:kv TT.";
    is_deeply %h<c d X>:exists:!kv,
      ("c",True,"d",True,"X",False),                    "Test exists:kv TTF";
    is_deeply %h<c d e>:!exists:kv,
      ("c",False,"d",False,"e",False),                  "Test exists:kv FFF";
    is_deeply %h<c d X>:!exists:kv,
      ("c",False,"d",False),                            "Test exists:kv FF.";
    is_deeply %h<c d X>:!exists:!kv,
      ("c",False,"d",False,"X",True),                   "Test exists:kv FFT";

    #?niezca 6 todo "no combined adverbial pairs"
    is_deeply %h<c d e>:exists:p,
      (c=>True,d=>True,e=>True),                     "Test exists:p TTT";
    is_deeply %h<c d X>:exists:p,
      (c=>True,d=>True),                             "Test exists:p TT.";
    is_deeply %h<c d X>:exists:!p,
      (c=>True,d=>True,X=>False),                    "Test exists:p TTF";
    is_deeply %h<c d e>:!exists:p,
      (c=>False,d=>False,e=>False),                  "Test exists:p FFF";
    is_deeply %h<c d X>:!exists:p,
      (c=>False,d=>False),                           "Test exists:p FF.";
    is_deeply %h<c d X>:!exists:!p,
      (c=>False,d=>False,X=>True),                   "Test exists:p FFT";

    #?niezca 6 todo "no combined adverbial pairs"
    dies_ok { %h<c>:exists:k },    "Test exists:k,   invalid combo";
    dies_ok { %h<c>:exists:!k },   "Test exists:!k,  invalid combo";
    dies_ok { %h<c>:!exists:k },   "Test !exists:k,  invalid combo";
    dies_ok { %h<c>:!exists:!k },  "Test !exists:!k, invalid combo";

    #?niezca 6 todo "no combined adverbial pairs"
    dies_ok { %h<c>:exists:v },    "Test exists:v,   invalid combo";
    dies_ok { %h<c>:exists:!v },   "Test exists:!v,  invalid combo";
    dies_ok { %h<c>:!exists:v },   "Test !exists:v,  invalid combo";
    dies_ok { %h<c>:!exists:!v },  "Test !exists:!v, invalid combo";

    is %h.elems, 26, "should not have changed hash";
} #46

# vim: ft=perl6
�����������������������������rakudo-2013.12/t/spec/S32-hash/exists.t�������������������������������������������������������������0000664�0001750�0001750�00000006016�12224265625�017005� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 21;

=begin description

Basic C<exists> tests on hashes, see S32::Containers.

=end description

# L<S32::Containers/"Hash"/=item exists>

sub gen_hash {
    my %h;
    %h = (
        a => 1,
        b => 2,
        c => 3,
        d => 4,

        x => 24,
        y => 25,
        Z => 26,
    );
    return %h;
};

{
    my %h1 = gen_hash;
    my %h2 = gen_hash;

    my $b = %h1<b>;
    #?rakudo skip 'unspecced'
    #?niecza skip 'Invocant handling is NYI'
    is (exists %h1: 'a'), True, "Test existence for single key. (Indirect notation)";
    is (%h1.exists_key('a')), True, "Test existence for single key. (method)";
    is (%h1{'a'}:exists), True, "Test existence for single key. (adverb)";
    is (%h1<a>:exists), True, "Test existence for single key. (adverb 2)";
};

{
    my %h;
    %h<none> = 0;
    %h<one> = 1;
    %h<nothing> = Mu;
    ok %h.exists_key('none'),    "Existence of single key with 0 as value: none";
    ok %h.exists_key('one'),     "Existence of single key: one";
    ok %h.exists_key('nothing'), "Existence of single key with undefined as value: nothing";
    ok defined(%h<none>),     "Defined 0 value for key: none";
    ok defined(%h<one>),      "Defined 1 value for key: one";
    ok !defined(%h<nothing>), "NOT Defined value for key: nothing";
}

my %hash = (a => 1, b => 2, c => 3, d => 4);
ok %hash.exists_key("a"),   "exists_key on hashes (1)";
ok !%hash.exists_key("42"), "exists_key on hashes (2)";

# This next group added by Darren Duncan following discovery while debugging ext/Locale-KeyedText:
# Not an exists() test per se, but asserts that elements shouldn't be added to
# (exist in) a hash just because there was an attempt to read nonexistent elements.
{
  sub foo( $any ) {}   #OK not used
  sub bar( $any is copy ) {}   #OK not used

  my $empty_hash = hash();
  is( $empty_hash.pairs.sort.join( ',' ), '', "empty hash stays same when read from (1)" );
  $empty_hash{'z'};
  is( $empty_hash.pairs.sort.join( ',' ), '', "empty hash stays same when read from (2)" );
  bar( $empty_hash{'y'} );
  is( $empty_hash.pairs.sort.join( ',' ), '', "empty hash stays same when read from (3)" );
  my $ref = \( $empty_hash{'z'} );
  is( $empty_hash.pairs.sort.join( ',' ), '', "taking a reference to a hash element does not auto-vivify the element");
  foo( $empty_hash{'x'} );
  #?pugs todo 'bug'
  is( $empty_hash.pairs.sort.join( ',' ), '', "empty hash stays same when read from (4)" );

  my $popul_hash = hash(('a'=>'b'),('c'=>'d'));
  my sub popul_hash_contents () {
    $popul_hash.pairs.sort.map({ $_.key ~ ":" ~ $_.value }).join( ',' );
  }

  is( popul_hash_contents, "a:b,c:d", "populated hash stays same when read from (1)" );
  $popul_hash{'z'};
  is( popul_hash_contents, "a:b,c:d", "populated hash stays same when read from (2)" );
  bar( $popul_hash{'y'} );
  is( popul_hash_contents, "a:b,c:d", "populated hash stays same when read from (3)" );
  foo( $popul_hash{'x'} );
  #?pugs todo 'bug'
  is( popul_hash_contents, "a:b,c:d", "populated hash stays same when read from (4)" );
}

# vim: syn=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/invert.t�������������������������������������������������������������0000664�0001750�0001750�00000001316�12224265625�016773� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/Hash/invert>

plan 5;

{
    my %h = a => 'b', c => 'd';
    isa_ok %h.invert, List, 'Hash.invert returns a List';
    #?niecza todo 'Cannot use value like Pair as a number'
    is_deeply %h.invert.sort, (b => 'a', d => 'c'), 'simple Hash.invert works';
    is_deeply %h, { a => 'b', c => 'd' }, 'original remains unchanged';
}

{
    # with lists
    my %h = a => <b c>, d => 'e';
    #?rakudo todo 'nom regression'
    #?niecza todo 'Cannot use value like Pair as a number'
    is_deeply %h.invert.sort, (b => 'a', c => 'a', e => 'd'),
              'Hash.invert flattens list values';
    is_deeply %h, {a => <b c>, d => 'e'}, 'original remains unchanged';
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/keys_values.t��������������������������������������������������������0000664�0001750�0001750�00000002366�12224265625�020024� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 14;

=begin pod

#Basic C<keys> and C<values> tests for hashes and pairs, see S32::Containers.

=end pod

my %hash = (a => 1, b => 2, c => 3, d => 4);

# L<S32::Containers/"Hash"/=item keys>
is(~%hash.keys.sort, "a b c d", '%hash.keys works');
is(~sort(keys(%hash)), "a b c d", 'keys(%hash) on hashes');
is(+%hash.keys, +%hash, 'we have the same number of keys as elements in the hash');

# L<S32::Containers/"Hash"/=item values>
#?pugs todo
is(~%hash.values.sort, "1 2 3 4", '%hash.values works');
#?pugs todo
is(~sort(values(%hash)), "1 2 3 4", 'values(%hash) works');
is(+%hash.values, +%hash, 'we have the same number of keys as elements in the hash');

# keys and values on Pairs
my $pair = (a => 42);
#?niecza todo
is(~$pair.keys,     "a", '$pair.keys works');
#?niecza todo
is(~keys($pair),    "a", 'keys($pair) works');
is($pair.keys.elems, 1, 'we have one key');

#?niecza todo
is(~$pair.values,       42, '$pair.values works');
#?niecza todo
is(~values($pair),      42, 'values($pair) works');
is($pair.values.elems,  1,  'we have one value');

# test that .keys and .values work on Any values as well;

{
    my $x;
    lives_ok { $x.values }, 'Can call Any.values';
    lives_ok { $x.keys },   'Can call Any.keys';

}
#vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/kv.t�����������������������������������������������������������������0000664�0001750�0001750�00000007504�12224265625�016111� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 27;

=begin pod

Basic C<kv> tests, see S32::Containers.

=end pod

# L<S32::Containers/"Hash"/=item kv>
{ # check the invocant form
    my %hash = (a => "x", b => "xx", c => "xxx", d => "xxxx");
    my @kv = %hash.kv;
    is(+@kv, 8, '%hash.kv returns the correct number of elems');
    is(~@kv.sort, "a b c d x xx xxx xxxx",  '%hash.kv has no inner list');
}

{ # check the non-invocant form
    my %hash = (a => "x", b => "xx", c => "xxx", d => "xxxx");
    my @kv = kv(%hash);
    is(+@kv, 8, 'kv(%hash) returns the correct number of elems');
    is(~@kv.sort, "a b c d x xx xxx xxxx",  'kv(%hash) has no inner list');
}

# See "Questions about $pair.kv" thread on perl-6 lang
{
    my $pair  = (a => 1);
    my @kv = $pair.kv;
    is(+@kv, 2, '$pair.kv returned one elem');
    is(+@kv, 2, '$pair.kv inner list has two elems');
    is(~@kv, "a 1", '$pair.kv inner list matched expectation');
}

{
    my $sub  = sub (Hash $hash) { $hash.kv };
    my %hash = (a => "x", b => "y");
    is ~kv(%hash).sort,   "a b x y", ".kv works with normal hashes (sanity check)";
    is ~$sub(%hash).sort, "a b x y", ".kv works with constant hash references";
}

{
    # "%$hash" is not idiomatic Perl, but should work nevertheless.
    my $sub  = sub (Hash $hash) { %$hash.kv };
    my %hash = (a => "x", b => "y");
    is ~kv(%hash).sort,   "a b x y", ".kv works with normal hashes (sanity check)";
    is ~$sub(%hash).sort, "a b x y", ".kv works with dereferenced constant hash references";
}

# test3 and test4 illustrate a bug 

#?DOES 2
sub test1{
    my $pair = boo=>'baz'; 
    my $type = $pair.WHAT.gist;
    for $pair.kv -> $key, $value {
        is($key, 'boo', "test1: $type \$pair got the right \$key");
        is($value, 'baz', "test1: $type \$pair got the right \$value");
    }
}
test1;

#?DOES 2
sub test2{
    my %pair = boo=>'baz'; 
    my $type = %pair.WHAT.gist;
    my $elems= +%pair;
    for %pair.kv -> $key, $value {
        is($key, 'boo', "test2: $elems elem $type \%pair got the right \$key");
        is($value, 'baz', "test2: $elems elem $type \%pair got the right \$value");
    }
}
test2;

my %hash  = ('foo' => 'baz');
#?DOES 2
sub test3 (%h){
  for %h.kv -> $key, $value {
        is($key, 'foo', "test3:  from {+%h}-elem {%h.WHAT.gist} \%h got the right \$key");
        is($value, 'baz', "test3: from {+%h}-elem {%h.WHAT.gist} \%h got the right \$value");
  }
}
test3 %hash;

sub test4 (%h){
    for 0..%h.kv.end -> $idx {
        is(%h.kv[$idx], %hash.kv[$idx], "test4: elem $idx of {%h.kv.elems}-elem {%h.kv.WHAT.gist} \%hash.kv correctly accessed");
    }
}
#?DOES 2
test4 %hash;

# sanity
for %hash.kv -> $key, $value {
    is($key, 'foo', "for(): from {+%hash}-elem {%hash.WHAT.gist} \%hash got the right \$key");
    is($value, 'baz', "for(): from {+%hash}-elem {%hash.WHAT.gist} \%hash got the right \$value");
}

# The things returned by .kv should be aliases
{
    my %hash = (:a(1), :b(2), :c(3));

    #?pugs todo 'feature'
    lives_ok { for %hash.kv -> $key, $value is rw {
        $value += 100;
    } }, 'aliases returned by %hash.kv should be rw (1)';

    #?pugs todo 'feature'
    is %hash<b>, 102, 'aliases returned by %hash.kv should be rw (2)';
}

{
    my @array = (17, 23, 42);

    #?pugs todo 'feature'
    lives_ok { for @array.kv -> $key, $value is rw {
        $value += 100;
    } }, 'aliases returned by @array.kv should be rw (1)';

    #?pugs todo 'feature'
    is @array[1], 123, 'aliases returned by @array.kv should be rw (2)';
}

{
    my $pair = (a => 42);

    #?pugs todo 'feature'
    #?niecza todo 'aliases should be rw'
    lives_ok { for $pair.kv -> $key, $value is rw {
        $value += 100;
    } }, 'aliases returned by $pair.kv should be rw (1)';

    #?pugs todo 'feature'
    #?niecza todo 'aliases should be rw'
    is $pair.value, 142, 'aliases returned by $pair.kv should be rw (2)';
}


# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/pairs.t��������������������������������������������������������������0000664�0001750�0001750�00000005312�12224265625�016602� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 21;

=begin description

Basic C<pairs> tests, see S32::Containers.

=end description

# L<S32::Containers/"Hash"/=item pairs>

{
  my %hash = (a => 1, b => 2, c => 3);
  my @pairs;
  ok((@pairs = %hash.pairs),    "pairs on hashes");
  ok((@pairs = @pairs.sort),    'Can sort list of pairs');
  is +@pairs, 3,                "pairs on hashes returned the correct number of elems";
  if +@pairs != 3 {
    skip "skipped tests which depend on a test which failed", 6;
  } else {
    is @pairs[0].key,   "a",      "value of pair returned by hash.pairs was correct (1)";
    is @pairs[1].key,   "b",      "value of pair returned by hash.pairs was correct (2)";
    is @pairs[2].key,   "c",      "value of pair returned by hash.pairs was correct (3)";
    is @pairs[0].value,   1,      "key of pair returned by hash.pairs was correct (1)";
    is @pairs[1].value,   2,      "key of pair returned by hash.pairs was correct (2)";
    is @pairs[2].value,   3,      "key of pair returned by hash.pairs was correct (3)";
  }
}

# Following stated by Larry on p6l
{
  my $pair  = (a => 1);
  my @pairs;
  ok((@pairs = $pair.pairs), "pairs on a pair");
  is +@pairs, 1,           "pairs on a pair returned one elem";
  if +@pairs != 1 {
    skip "skipped tests which depend on a test which failed", 2;
  } else {
    is @pairs[0].key,   "a", "key of pair returned by pair.pairs";
    is @pairs[0].value,   1, "value of pair returned by pair.pairs";
  }
}

# This next group added by Darren Duncan following discovery while debugging ext/Locale-KeyedText:
{
  my $hash_of_2_pairs = {'a'=>'b','c'=>'d'};
  my $hash_of_1_pair = {'a'=>'b'};
  #?pugs 2 todo 'feature'
  is( $hash_of_2_pairs.pairs.sort.join( ',' ), "a\tb,c\td",
    "pairs() on 2-elem hash, 1-depth joined");
  is( $hash_of_1_pair.pairs.sort.join( ',' ), "a\tb",
    "pairs() on 1-elem hash, 1-depth joined");
  is( $hash_of_2_pairs.pairs.sort.map({ .key~'='~.value }).join( ',' ), 'a=b,c=d', 
    "pairs() on 2-elem hash, 2-depth joined" );
  is( try { $hash_of_1_pair.pairs.sort.map({ .key~'='~.value }).join( ',' ) }, 'a=b', 
    "pairs() on 1-elem hash, 2-depth joined" );
}

{
    my %hash = (:a(1), :b(2), :c(3));

    lives_ok { for %hash.pairs -> $pair {
        $pair.value += 100;
    } }, 'aliases returned by %hash.pairs should be rw (1)';

    #?rakudo todo "Rakudo seems to make a copy rather than a reference"
    is %hash<b>, 102, 'aliases returned by %hash.pairs should be rw (2)';
}

#?pugs todo 'bug'
{
    my $var = 42;
    my $pair = (a => $var);

    lives_ok { for $pair.pairs -> $p {
        $p.value += 100;
    } }, 'aliases returned by $pair.value should be rw (1)';

    is $pair.value, 142, 'aliases returned by $pair.kv should be rw (2)';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/perl.t���������������������������������������������������������������0000664�0001750�0001750�00000003215�12224265625�016426� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

#?pugs   todo "cannot roundtrip hashes"
#?niecza todo "cannot roundtrip hashes"
# simple hash
{
    my %h = a => 1, b => 2;
    is %h.perl,'("a" => 1, "b" => 2).hash'|'("b" => 2, "a" => 1).hash', 
      'can we serialize a simple hash';
    my $rh = eval(%h.perl);
    is_deeply $rh, %h, 'can we roundtrip simple hash';
    ok $rh.of    =:= Mu,  'make sure any value can be stored';
    ok $rh.keyof =:= Any, 'make sure keys are Any';
} #4

#?pugs   skip "cannot roundtrip hashes with constrained values"
#?niecza skip "cannot roundtrip hashes with constrained values"
# hash with constrained values
{
    my Int %h = a => 1, b => 2;
    is %h.perl, 'Hash[Int].new("a" => 1, "b" => 2)'|'Hash[Int].new("b" => 2, "a" => 1)',
      'can we serialize a hash with constrained values';
    my $rh = eval(%h.perl);
    is_deeply $rh, %h, 'can we roundtrip hash constrained values';
    ok $rh.of    =:= Int, 'make sure roundtripped values are Int';
    ok $rh.keyof =:= Any, 'make sure roundtripped keys are Any';
} #4

#?pugs   skip "cannot roundtrip hashes with constrained keys & values"
#?niecza skip "cannot roundtrip hashes with constrained keys & values"
# hash with constrained keys & values
{
    my Int %h{Str} = a => 1, b => 2;
    is %h.perl, 'Hash[Int,Str].new("a" => 1, "b" => 2)'|'Hash[Int,Str].new("b" => 2, "a" => 1)',
      'can we serialize a hash with constrained keys & values';
    my $rh = eval(%h.perl);
    is_deeply $rh, %h, 'can we roundtrip hash constrained keys & values';
    ok $rh.of    =:= Int, 'make sure roundtripped values are Int';
    ok $rh.keyof =:= Str, 'make sure roundtripped keys are Str';
} #4

#vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/push.t���������������������������������������������������������������0000664�0001750�0001750�00000001703�12224265625�016443� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 7;

# L<S32::Containers/Hash/"Like hash assignment insofar">

my %ref1 = (a => 1, b => 2, c => 3);
my %ref2 = (a => [1, 4, 5], b => 2, c => 3);

{

    my ($r, %x);
    $r = %x.push: 'a' => 1;
    is $r.WHAT.gist, Hash.gist, 'Hash.push returns hash';

    my %h;
    %h.push: 'b', 2, 'a', 1, 'c', 3;
    is_deeply %h, %ref1, 'basic Hash.push with alternating items';
    %h.push: (:a(4), :a(5));
    is_deeply %h, %ref2, 'stacking push works with pairs';

    my %g;
    %g.push: (a => 1), (c => 3), (b => 2);
    is_deeply %g, %ref1, 'basic Hash.push with pairs ';
    %g.push: 'a', 4, 'a', 5;
    is_deeply %g, %ref2, 'stacking push worsk with alternating items';

    my %hh;
    %hh.push: 5, 'bar';
    is_deeply %hh, { 5 => 'bar' }, 'Hash.push works pushing a non-Str-keyed alternating items';

    my %gg;
    %gg.push: 5 => 'bar';
    is_deeply %gg, { 5 => 'bar' }, 'Hash.push works pushing a non-Str-keyed Pair';
}

# vim: ft=perl6
�������������������������������������������������������������rakudo-2013.12/t/spec/S32-hash/slice.t��������������������������������������������������������������0000664�0001750�0001750�00000010017�12224265625�016561� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"Hash">

=begin pod

Testing hash slices.

=end pod

plan 29;

{   my %hash = (1=>2,3=>4,5=>6);
    my @s=(2,4,6);

    is(@s, %hash{1,3,5},               "basic slice");
    is(@s, %hash{(1,3,5)},             "basic slice, explicit list");
    is(@s, %hash<1 3 5>,               "basic slice, <> syntax");

    is(%hash{1,1,5,1,3}, "2 2 6 2 4",   "basic slice, duplicate keys");
    is(%hash<1 1 5 1 3>, "2 2 6 2 4",   "basic slice, duplicate keys, <> syntax");


    my @slice = (3,5);

    is(%hash{@slice}, "4 6",      "slice from array, part 1");
    is(%hash{@slice}, (4,6),      "slice from array, part 2");
    is(%hash{@slice[1]}, (6),     "slice from array slice, part 1");
    is(%hash{@slice[0,1]}, (4,6), "slice from array slice, part 2");
}

#?niecza skip 'Excess arguments to CORE List.new, used 1 of 3 positionals'
#?pugs skip 'Must only use named arguments to new() constructor'
{   my %hash;

    %hash{(1,2)} = "one", "two";
    is %hash, {"1" => "one", "2" => "two"},
        "assigning a slice using keys from Parcel";

    %hash{Array.new(1,2)} = "one", "two";
    is %hash, {"1" => "one", "2" => "two"},
        "assigning a slice using keys from Array";

    %hash{"12".comb(/(\d)/)} = "one", "two";
    is %hash, {"1" => "one", "2" => "two"},
        "assigning a slice using keys from GatherIterator";
}

#?pugs todo 'feature'
#?rakudo todo 'binding on hash elements unimplemented'
#?niecza todo 'Writing to readonly scalar'
#?pugs skip "Can't modify constant item: VNum Infinity"
{
    my %hash = :a(1), :b(2), :c(3), :d(4);
    my @slice := %hash<b c>;
    is ~((@slice,*) = <A B C D>), "A B",
	"assigning a slice too many items yields a correct return value";
}

# Slices on hash literals
{   is ~({:a(1), :b(2), :c(3), :d(4)}<b c>), "2 3", "slice on hashref literal";

=begin pod

# not-yet

    is ~((:a(1), :b(2), :c(3), :d(4))<b c>), "2 3", "slice on hash literal";
See thread "Accessing a list literal by key?" on p6l started by Ingo
Blechschmidt: L<"http://www.nntp.perl.org/group/perl.perl6.language/23076">
Quoting Larry:
  Well, conservatively, we don't have to make it work yet.

=end pod

}

# Binding on hash slices
#?rakudo todo 'binding on hash elements unimplemented'
{   my %hash = (:a<foo>, :b<bar>, :c<baz>);

    try { %hash<a b> := <FOO BAR> };
    #?pugs 2 todo 'bug'
    #?niecza 2 todo
    is %hash<a>, "FOO", "binding hash slices works (1-1)";
    is %hash<b>, "BAR", "binding hash slices works (1-2)";
}

#?rakudo todo 'binding on hash elements unimplemented'
{   my %hash = (:a<foo>, :b<bar>, :c<baz>);

    try { %hash<a b> := <FOO> };
    #?pugs 2 todo 'bug'
    #?niecza 2 todo
    is %hash<a>, "FOO",    "binding hash slices works (2-1)";
    ok !defined(%hash<b>), "binding hash slices works (2-2)";
}

{   my %hash = (:a<foo>, :b<bar>, :c<baz>);
    my $foo  = "FOO";
    my $bar  = "BAR";

    try { %hash<a b> := ($foo, $bar) };
    #?rakudo 2 todo 'binding on hash elements unimplemented'
    #?pugs 2 todo 'bug'
    #?niecza 2 todo
    is %hash<a>, "FOO", "binding hash slices works (3-1)";
    is %hash<b>, "BAR", "binding hash slices works (3-2)";

    $foo = "BB";
    $bar = "CC";
    #?rakudo 2 todo 'binding on hash elements unimplemented'
    #?niecza 2 todo
    #?pugs 2 todo 'bug'
    is %hash<a>, "BB", "binding hash slices works (3-3)";
    is %hash<b>, "CC", "binding hash slices works (3-4)";

    %hash<a> = "BBB";
    %hash<b> = "CCC";
    is %hash<a>, "BBB", "binding hash slices works (3-5)";
    is %hash<b>, "CCC", "binding hash slices works (3-6)";

    #?rakudo 2 todo 'binding on hash elements unimplemented'
    #?pugs 2 todo 'bug'
    #?niecza 2 todo
    is $foo,     "BBB", "binding hash slices works (3-7)";
    is $bar,     "CCC", "binding hash slices works (3-8)";
}

# Calculated slices
{   my %hash = (1=>2,3=>4,5=>6);
    my @s=(2,4,6);

    is(@s, [%hash{%hash.keys}.sort],     "values from hash keys, part 1");
    is(@s, [%hash{%hash.keys.sort}],     "values from hash keys, part 2");
    is(@s, [%hash{(1,2,3)>>+<<(0,1,2)}], "calculated slice: hyperop");
}
#vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/chdir.t����������������������������������������������������������������0000664�0001750�0001750�00000002633�12224265625�016244� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::IO/Functions/chdir>

plan 10;

eval_dies_ok ' chdir() ', 'Cannot call chdir without an argument';

### Although you can use Unix style folder separator / to set folders, what's returned
### is in the native style, such as \ for windows
my $sep = '/';
if $*OS eq "MSWin32" {
    $sep = '\\';
}

# change to t subfolder and see if cwd is updated
my $subdir = 't';
if $subdir.IO !~~ :d {
    skip "Directory, '$subdir', does not exist", 7;
}
else {
    my $cwd = $*CWD;
    ok chdir("$*CWD/$subdir"), 'chdir gave a true value';
    isnt $*CWD, $cwd, 'Directory has changed';
    is $*CWD, "$cwd$sep$subdir",
       "Current directory is '$subdir' subfolder (absolute)";

    # relative change back up.
    ok chdir( ".." ), 'chdir gave a true value';
    is $*CWD, $cwd, 'Change back up to .. worked';

    # relative change to t
    ok chdir( "$subdir" ), 'chdir gave a true value';
    is $*CWD, "$cwd$sep$subdir",
       "Current directory is '$subdir' subfolder (relative)";
}

my $no_subdir = 'lol does not exist';
if $no_subdir.IO ~~ :d {
    skip "subdir '$no_subdir' does exist, actually.", 2;
}
else {
    #?rakudo 2 skip 'spec non-conformance due to missing sink context'
    lives_ok { chdir("$no_subdir") },
             'chdir to a non-existent does not by default throw an exception';
    ok !chdir("$no_subdir"),
       'change to non-existent directory gives a false value';
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/copy.t�����������������������������������������������������������������0000664�0001750�0001750�00000005356�12224265625�016132� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 29;

my $existing-file     = "tempfile-copy";
my $non-existent-file = "non-existent-copy";
my $zero-length-file  = "tempfile-zero-length-copy";

{ # write the file first
    my $fh = open($existing-file, :w);
    $fh.print: "0123456789A";
    $fh.close();
}

{ # write the file first
    my $fh = open($zero-length-file, :w);
    $fh.close();
}

# sanity check
ok $existing-file.IO.e, 'It exists';
ok $zero-length-file.IO.e, 'It exists';
nok $non-existent-file.IO.e, "It doesn't";

# method .IO.copy
#?niecza skip 'Unable to resolve method s in class IO'
{
    my $existing-file-mtgt     = "tempfile-copy-mtgt";
    my $non-existent-file-mtgt = "non-existent-copy-mtgt";
    my $zero-length-file-mtgt  = "tempfile-zero-length-copy-mtgt";
    
    ok $existing-file.IO.copy( $existing-file-mtgt ), '.IO.copy normal file';
    ok $existing-file-mtgt.IO.e, 'It exists';
    ok $existing-file-mtgt.IO.s, 'It has a size';
    is $existing-file-mtgt.IO.s, $existing-file.IO.s, 'The size is equal to source file';

    dies_ok { $non-existent-file.IO.copy( $non-existent-file-mtgt ) }, '.IO.copy missing file';
    nok $non-existent-file-mtgt.IO.e, "It doesn't";

    ok $zero-length-file.IO.copy( $zero-length-file-mtgt ), '.IO.copy empty file';
    ok $zero-length-file-mtgt.IO.e, 'It exists';
    nok $zero-length-file-mtgt.IO.s, 'It has no size';
    is $zero-length-file-mtgt.IO.s, $zero-length-file.IO.s, 'The size is equal to source file';

    ok unlink($existing-file-mtgt), 'file has been removed';
    ok unlink($zero-length-file-mtgt), 'file has been removed';
}

# sub copy()
#?niecza skip 'Unable to resolve method s in class IO'
{
    my $existing-file-stgt     = "tempfile-copy-stgt";
    my $non-existent-file-stgt = "non-existent-copy-stgt";
    my $zero-length-file-stgt  = "tempfile-zero-length-copy-stgt";
    
    ok copy( $existing-file, $existing-file-stgt ), 'copy() normal file';
    ok $existing-file-stgt.IO.e, 'It exists';
    ok $existing-file-stgt.IO.s, 'It has a size';
    is $existing-file-stgt.IO.s, $existing-file.IO.s, 'The size is equal to source file';

    dies_ok { copy( $non-existent-file, $non-existent-file-stgt ) }, 'copy() missing file';
    nok $non-existent-file-stgt.IO.e, "It doesn't";

    ok copy( $zero-length-file, $zero-length-file-stgt ), 'copy() empty file';
    ok $zero-length-file-stgt.IO.e, 'It exists';
    nok $zero-length-file-stgt.IO.s, 'It has no size';
    is $zero-length-file-stgt.IO.s, $zero-length-file.IO.s, 'The size is equal to source file';

    ok unlink($existing-file-stgt), 'file has been removed';
    ok unlink($zero-length-file-stgt), 'file has been removed';
}

# clean up
ok unlink($existing-file), 'file has been removed';
ok unlink($zero-length-file), 'file has been removed';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/dir.t������������������������������������������������������������������0000664�0001750�0001750�00000002327�12224265625�015731� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

# L<S32::IO/Functions/"=item dir">

my @files;
ok (@files = dir()), "dir() runs in cwd()";

# see roast's README as for why there is always a t/ available
#?niecza skip "Grepping Str against a list of IO::Path does not work"
ok @files.grep('t'), 'current directory contains a t/ dir';
ok @files.grep(*.basename eq 't'), 'current directory contains a t/ dir';
isa_ok @files[0], IO::Path, 'dir() returns IO::Path objects';
is @files[0].directory, '.', 'dir() returns IO::Path object in the current directory';

#?niecza 3 skip "Grepping Str against a list of IO::Path does not work"
nok @files.grep('.'|'..'), '"." and ".." are not returned';
is +dir(:test).grep('.'|'..'), 2, "... unless you override :test";
nok dir( test=> none('.', '..', 't') ).grep('t'), "can exclude t/ dir";

# previous tests rewritten to not smartmatch against IO::Path.
# Niecza also seems to need the ~, alas.
nok @files.grep(*.basename eq '.'|'..'), '"." and ".." are not returned';
is +dir(:test).grep(*.basename eq '.'|'..'), 2, "... unless you override :test";
nok dir( test=> none('.', '..', 't') ).grep(*.basename eq 't'), "can exclude t/ dir";

is dir('t').[0].directory, 't', 'dir("t") returns paths with .directory of "t"';


���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/empty.txt��������������������������������������������������������������0000664�0001750�0001750�00000000000�12224265625�016647� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/file-tests.t�����������������������������������������������������������0000664�0001750�0001750�00000004233�12224265625�017230� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::IO/IO::FileTests>

plan 30;

my $existing-file = "tempfile-file-tests";
my $non-existent-file = "non-existent-file-tests";
my $zero-length-file = "tempfile-zero-length-file-tests";

{ # write the file first
    my $fh = open($existing-file, :w);
    $fh.print: "0123456789A";
    $fh.close();
}

{ # write the file first
    my $fh = open($zero-length-file, :w);
    $fh.close();
}

#Str methods
##existence
ok $existing-file.IO.e, 'It exists';
isa_ok $existing-file.IO.e, Bool, '.e returns Bool';
ok $existing-file.IO ~~ :e, 'It exists';
isa_ok $existing-file.IO ~~ :e, Bool, '~~ :e returns Bool';
nok $non-existent-file.IO.e, "It doesn't";
isa_ok $non-existent-file.IO.e, Bool, '.e returns Bool';
nok $non-existent-file.IO ~~ :e, "It doesn't";
isa_ok $non-existent-file.IO ~~ :e, Bool, '~~ :e returns Bool';

##is normal file
ok $existing-file.IO.f, 'Is normal file';
isa_ok $existing-file.IO.f, Bool, '.f returns Bool';
ok $existing-file.IO ~~ :f, 'Is normal file';
isa_ok $existing-file.IO ~~ :f, Bool, '~~ :f returns Bool';
# what should happen when this is called on a non-existent file?
nok $non-existent-file.IO.f, 'Is not a normal file';
isa_ok $non-existent-file.IO.f, Bool, '.f returns Bool';
ok $non-existent-file.IO ~~ :!f, 'Is not a normal file';
isa_ok $non-existent-file.IO ~~ :!f, Bool, '~~ :!f returns Bool';

##is empty
#?niecza skip 'Unable to resolve method s in class IO'
{
    nok $zero-length-file.IO.s, 'Is empty';
    isa_ok $zero-length-file.IO.s, Int, '.s returns Int';
    ok $zero-length-file.IO ~~ :!s, 'Is empty';
    isa_ok $zero-length-file.IO ~~ :!s, Bool, '~~ :!s returns Bool';
    ok $existing-file.IO.s, 'Is not';
    isa_ok $existing-file.IO.s, Int, '.s returns Int';
    ok $existing-file.IO ~~ :s, 'Is not';
    isa_ok $existing-file.IO ~~ :s, Bool, '~~ :s returns Bool';

    ##file size
    is $zero-length-file.IO.s, 0, 'No size';
    isa_ok $zero-length-file.IO.s, Int, '.s returns Int';
    is $existing-file.IO.s, 11, 'size of file';
    isa_ok $existing-file.IO.s, Int, '.s returns Int';
}

# clean up
ok unlink($existing-file), 'file has been removed';
ok unlink($zero-length-file), 'file has been removed';

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-handle.t������������������������������������������������������������0000664�0001750�0001750�00000001270�12224265625�017007� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 2;

my $path = "io-handle-testfile";

##
# Test that we flush when we go out of scope
#?niecza skip "Unable to resolve method open in type IO"
{
    {
        my $fh = $path.IO.open(:w);
        $fh.print("42");
    }
    #?rakudo todo "doesn't flush"
    is slurp($path), "42", "buffer is flushed when IO goes out of scope";
}

#?rakudo todo "doesn't flush"
#?niecza skip "Unable to resolve method open in type IO"
{
    $path.IO.open(:w).print("24");
    is slurp($path), "24", "buffer is flushed when IO goes out of scope";
}

try { unlink $path }

CATCH {
    try { unlink $path; }
}

if $path.IO.e {
    say "Warn: '$path shouldn't exist";
    unlink $path;
}

done;
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-path-cygwin.t�������������������������������������������������������0000664�0001750�0001750�00000010226�12224265625�020007� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
# L<S32::IO/IO::Path>

plan 52;

my $relpath = IO::Path::Cygwin.new('foo/bar' );
my $abspath = IO::Path::Cygwin.new('/foo/bar');

isa_ok $abspath, IO::Path::Cygwin, "Can create IO::Path::Cygwin";
is $abspath.volume,	"",		'volume "/foo/bar" -> ""';
is $abspath.directory, 	"/foo",		'directory "/foo/bar" -> "/foo"';
is $abspath.basename, 	"bar",		'basename "/foo/bar" -> "bar"';

my $path = IO::Path::Cygwin.new('C:foo\\\\bar\\');
is $path.volume,	"C:",	'volume "C:foo\\\\bar//" -> "C:"';
is $path.directory, 	"foo",	'directory "C:foo\\\\bar\\" -> "foo"';
is $path.basename, 	"bar",	'basename "C:foo\\\\bar\\" -> "bar"';
isa_ok $path.path, IO::Path::Cygwin, ".path returns itself";
is $path.perl.eval, $path, ".perl loopback";

my $uncpath = IO::Path::Cygwin.new("\\\\server\\share\\");
is $uncpath.volume,	"//server/share",	'volume "//server/share/" -> ""/server/share"';
is $uncpath.directory, 	"/",	'directory "\\\\server\\share\\" -> "\\"';
is $uncpath.basename, 	"/",	'basename "\\\\server\\share\\" -> "\\"';
is $uncpath.Str, "\\\\server\\share\\", '"\\\\server\\share" restringifies to itself';

my $uncpath2 = IO::Path::Cygwin.new("//server/share/a");
is $uncpath2.volume,	"//server/share",	'volume "//server/share/a" -> ""//server/share"';
is $uncpath2.directory, "/",	'directory "//server/share/a" -> "/"';
is $uncpath2.basename, 	"a",	'basename "//server/share/a" -> "a"';
is $uncpath2.Str, "//server/share/a", '"//server/share/a" restringifies to itself';

is IO::Path::Cygwin.new(".").Str,		".",		"current directory";
is IO::Path::Cygwin.new("..").Str,		"..",		"parent directory";
is IO::Path::Cygwin.new('').Str,		"",		"empty is empty";

is IO::Path::Cygwin.new("/usr/////local/./bin/.\\./perl/").cleanup, "/usr/local/bin/perl",
	"cleanup '/usr/////local/./bin/.\\./perl/' -> '/usr/local/bin/perl'";

ok $relpath.is-relative,	"relative path is-relative";
nok $relpath.is-absolute,	"relative path ! is-absolute";
nok $abspath.is-relative,	"absolute path ! is-relative";
ok $abspath.is-absolute,	"absolute path is-absolute";
ok $uncpath.is-absolute,	"UNC path is-absolute";
ok $uncpath2.is-absolute,	"UNC path with forward slash is-absolute";
ok IO::Path::Cygwin.new("\\foo").is-absolute,	"path beginning with backslash is absolute";
ok IO::Path::Cygwin.new("A:\\").is-absolute,	'"A:\\" is absolute';
ok IO::Path::Cygwin.new("A:b").is-relative,	'"A:b" is relative';


is $relpath.absolute,	IO::Spec::Cygwin.canonpath("$*CWD/foo/bar"),	"absolute path from \$*CWD";
is $relpath.absolute("/usr"),	"/usr/foo/bar",		"absolute path specified";
is IO::Path::Cygwin.new("/usr/bin").relative("/usr"),	"bin",			"relative path specified";
is $relpath.absolute.relative,  "foo/bar",		"relative inverts absolute";
is $relpath.absolute("/foo").relative("\\foo"), "foo/bar", "absolute inverts relative";
#?rakudo 1 todo 'resolve NYI, needs nqp::readlink'
is $abspath.relative.absolute.resolve, "\\foo\\bar",	"absolute inverts relative with resolve";

is IO::Path::Cygwin.new("foo/bar").parent,		"foo",			"parent of 'foo/bar' is 'foo'";
is IO::Path::Cygwin.new("foo").parent,			".",			"parent of 'foo' is '.'";
is IO::Path::Cygwin.new(".").parent,			"..",			"parent of '.' is '..'";
is IO::Path::Cygwin.new("..").parent,			"../..",		"parent of '..' is '../..'";
is IO::Path::Cygwin.new("/foo").parent,			"/",			"parent at top level is '/'";
is IO::Path::Cygwin.new("/").parent,			"/",			"parent of root is '/'";
is IO::Path::Cygwin.new("\\").parent,			"/",			"parent of root ('\\') is '/'";

is IO::Path::Cygwin.new("/").child('foo'),	"/foo",		"append to root";
is IO::Path::Cygwin.new(".").child('foo'),	"foo",		"append to cwd";

my $numfile = IO::Path::Unix.new("foo/file01.txt");
is $numfile.succ,	"foo/file02.txt", "succ basic";
is $numfile.succ.succ,	"foo/file03.txt", "succ x 2";
is $numfile.pred,	"foo/file00.txt", "pred basic";
is IO::Path::Unix.new("foo/()").succ, "foo/()", "succ only effects basename";
is IO::Path::Unix.new("foo/()").succ, "foo/()", "pred only effects basename";

if IO::Spec.FSTYPE eq 'Win32' {
	ok IO::Path::Cygwin.new(~$*CWD).e,		"cwd exists, filetest inheritance ok";
	ok IO::Path::Cygwin.new(~$*CWD).d,		"cwd is a directory";
}
else {
	skip "On-system tests for filetest inheritance", 2;
}


done;

��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-path.t��������������������������������������������������������������0000664�0001750�0001750�00000002723�12224265625�016514� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 13;

# L<S32::IO/IO::Path>

my $path = '/foo/bar.txt'.path;
isa_ok $path, IO::Path, "Str.path returns an IO::Path";
is IO::Path.new('/foo/bar.txt'), $path,
   "Constructor works without named arguments";

# This assumes slash-separated paths, so it will break on, say, VMS

is $path.volume,    '',        'volume';
is $path.directory, '/foo',    'directory';
is $path.basename,  'bar.txt', 'basename';
#?niecza 2 skip '.parent NYI'
is $path.parent,    '/foo',    'parent';
is $path.parent.parent, '/',   'parent of parent';
#?niecza 2 skip '.is-absolute, .is-relative NYI'
is $path.is-absolute, True,    'is-absolute';
is $path.is-relative, False,   'is-relative';

isa_ok $path.path, IO::Path, 'IO::Path.path returns IO::Path';
#?niecza skip 'IO::Handle still called IO'
isa_ok $path.IO,   IO::Handle, 'IO::Path.IO returns IO::Handle';

# Try to guess from context that the correct backend is loaded:
#?niecza skip 'is-absolute NYI'
#?DOES 2
{
  if $*OS eq any <Win32 MSWin32 os2 dos symbian NetWare> {
      ok "c:\\".path.is-absolute, "Win32ish OS loaded (volume)";
      is "/".path.cleanup, "\\", "Win32ish OS loaded (back slash)"
  }
  elsif $*OS eq 'cygwin' {
      ok "c:\\".path.is-absolute, "Cygwin OS loaded (volume)";
      is "/".path.cleanup, "/", "Cygwin OS loaded (forward slash)"
  }
  else { # assume POSIX
      nok "c:\\".path.is-absolute, "POSIX OS loaded (no volume)";
      is "/".path.cleanup, "/", "POSIX OS loaded (forward slash)"
  }
}




���������������������������������������������rakudo-2013.12/t/spec/S32-io/io-path-unix.t���������������������������������������������������������0000664�0001750�0001750�00000005623�12224265625�017477� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
# L<S32::IO/IO::Path>

plan 37;

my $relpath = IO::Path::Unix.new('foo/bar' );
my $abspath = IO::Path::Unix.new('/foo/bar');
isa_ok $abspath, IO::Path::Unix, "Can create IO::Path::Unix";
is $abspath.volume,	"",	"volume is empty on POSIX";
is $abspath.directory, 	"/foo",	'directory "/foo/bar" -> "/foo"';
is $abspath.basename, 	"bar",	'basename "/foo/bar" -> "bar"';

my $path = IO::Path::Unix.new('foo//bar//');
is $path.directory, 	"foo",	'directory "foo//bar//" -> "foo"';
is $path.basename, 	"bar",	'basename "foo//bar//" -> "bar"';
isa_ok $path.path, IO::Path::Unix, ".path returns itself";
is $path.perl.eval, $path, ".perl loopback";

is IO::Path::Unix.new(".").Str,			".",		"current directory";
is IO::Path::Unix.new("..").Str,		"..",		"parent directory";
is IO::Path::Unix.new('').Str,			"",		"empty is empty";

is IO::Path::Unix.new("/usr/////local/./bin/././perl/").cleanup, "/usr/local/bin/perl",
	"cleanup '/usr/////local/./bin/././perl/' -> '/usr/local/bin/perl'";

ok $relpath.is-relative,	"relative path is-relative";
nok $relpath.is-absolute,	"relative path ! is-absolute";
nok $abspath.is-relative,	"absolute path ! is-relative";
ok $abspath.is-absolute,	"absolute path is-absolute";

is $relpath.absolute,		IO::Spec::Unix.canonpath("$*CWD/foo/bar"),	"absolute path from \$*CWD";
is $relpath.absolute("/usr"),	"/usr/foo/bar",		"absolute path specified";
is IO::Path::Unix.new("/usr/bin").relative("/usr"),	"bin",			"relative path specified";
is $relpath.absolute.relative,  "foo/bar",		"relative inverts absolute";
is $relpath.absolute("/foo").relative("/foo"), "foo/bar","absolute inverts relative";
#?rakudo 1 todo 'resolve NYI, needs nqp::readlink'
is $abspath.relative.absolute.resolve, "/foo/bar",	"absolute inverts relative with resolve";

is IO::Path::Unix.new("foo/bar").parent,		"foo",			"parent of 'foo/bar' is 'foo'";
is IO::Path::Unix.new("foo").parent,			".",			"parent of 'foo' is '.'";
is IO::Path::Unix.new(".").parent,			"..",			"parent of '.' is '..'";
is IO::Path::Unix.new("..").parent,			"../..",		"parent of '..' is '../..'";
is IO::Path::Unix.new("/foo").parent,			"/",			"parent at top level is '/'";
is IO::Path::Unix.new("/").parent,			"/",			"parent of root is '/'";

is IO::Path::Unix.new("/").child('foo'),	"/foo",		"append to root";
is IO::Path::Unix.new(".").child('foo'),	"foo",		"append to cwd";

my $numfile = IO::Path::Unix.new("foo/file01.txt");
is $numfile.succ,	"foo/file02.txt", "succ basic";
is $numfile.succ.succ,	"foo/file03.txt", "succ x 2";
is $numfile.pred,	"foo/file00.txt", "pred basic";
is IO::Path::Unix.new("foo/()").succ, "foo/()", "succ only effects basename";
is IO::Path::Unix.new("foo/()").succ, "foo/()", "pred only effects basename";

if IO::Spec.FSTYPE eq 'Unix' {
	ok IO::Path::Unix.new(~$*CWD).e,		"cwd exists, filetest inheritance ok";
	ok IO::Path::Unix.new(~$*CWD).d,		"cwd is a directory";
}
else {
	skip "On-system tests for filetest inheritance", 2;
}


done;

�������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-path-win.t����������������������������������������������������������0000664�0001750�0001750�00000010143�12224265625�017302� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
# L<S32::IO/IO::Path>

plan 51;

my $relpath = IO::Path::Win32.new('foo\\bar' );
my $abspath = IO::Path::Win32.new('\\foo\\bar');

isa_ok $abspath, IO::Path::Win32, "Can create IO::Path::Win32";
is $abspath.volume,	"",		'volume "\\foo\\bar" -> ""';
is $abspath.directory, 	"\\foo",	'directory "\\foo\\bar" -> "\\foo"';
is $abspath.basename, 	"bar",		'basename "\\foo\\bar" -> "bar"';

my $path = IO::Path::Win32.new('C:foo//bar//');
is $path.volume,	"C:",	'volume "C:foo//bar//" -> "C:"';
is $path.directory, 	"foo",	'directory "C:foo//bar//" -> "foo"';
is $path.basename, 	"bar",	'basename "C:foo//bar//" -> "bar"';
isa_ok $path.path, IO::Path::Win32, ".path returns itself";
is $path.perl.eval, $path, ".perl loopback";

my $uncpath = IO::Path::Win32.new("\\\\server\\share\\");
is $uncpath.volume,	"\\\\server\\share",	'volume "\\\\server\\share\\" -> ""\\\\server\\share"';
is $uncpath.directory, 	"\\",	'directory "\\\\server\\share\\" -> "\\"';
is $uncpath.basename, 	"\\",	'basename "\\\\server\\share\\" -> "\\"';
is $uncpath.Str, "\\\\server\\share\\", '"\\\\server\\share\\" restringifies to itself';

my $uncpath2 = IO::Path::Win32.new("//server/share/a");
is $uncpath2.volume,	"//server/share",	'volume "//server/share/a" -> ""//server/share"';
is $uncpath2.directory, "/",	'directory "//server/share/a" -> "/"';
is $uncpath2.basename, 	"a",	'basename "//server/share/a" -> "a"';
is $uncpath2.Str, "//server/share/a", '"//server/share/a" restringifies to itself';

is IO::Path::Win32.new(".").Str,		".",		"current directory";
is IO::Path::Win32.new("..").Str,		"..",		"parent directory";
is IO::Path::Win32.new('').Str,			"",		"empty is empty";

is IO::Path::Win32.new("/usr/////local/./bin/././perl/").cleanup, "\\usr\\local\\bin\\perl",
	"cleanup '/usr/////local/./bin/././perl/' -> '\\usr\\local\\bin\\perl'";

ok $relpath.is-relative,	"relative path is-relative";
nok $relpath.is-absolute,	"relative path ! is-absolute";
nok $abspath.is-relative,	"absolute path ! is-relative";
ok $abspath.is-absolute,	"absolute path is-absolute";
ok $uncpath.is-absolute,	"UNC path is-absolute";
ok $uncpath2.is-absolute,	"UNC path with forward slash is-absolute";
ok IO::Path::Win32.new("/foo").is-absolute,	"path beginning with forward slash is absolute";
ok IO::Path::Win32.new("A:\\").is-absolute,	'"A:\\" is absolute';
ok IO::Path::Win32.new("A:b").is-relative,	'"A:b" is relative';

is $relpath.absolute,		IO::Spec::Win32.canonpath("$*CWD\\foo\\bar"),	"absolute path from \$*CWD";
is $relpath.absolute("\\usr"),	"\\usr\\foo\\bar",		"absolute path specified";
is IO::Path::Win32.new("\\usr\\bin").relative("/usr"),	"bin",			"relative path specified";
is $relpath.absolute.relative,  "foo\\bar",		"relative inverts absolute";
is $relpath.absolute("/foo").relative("\\foo"), "foo\\bar","absolute inverts relative";
#?rakudo 1 todo 'resolve NYI, needs nqp::readlink'
is $abspath.relative.absolute.resolve, "\\foo\\bar",	"absolute inverts relative with resolve";

is IO::Path::Win32.new("foo/bar").parent,		"foo",			"parent of 'foo/bar' is 'foo'";
is IO::Path::Win32.new("foo").parent,			".",			"parent of 'foo' is '.'";
is IO::Path::Win32.new(".").parent,			"..",			"parent of '.' is '..'";
is IO::Path::Win32.new("..").parent,			"..\\..",		"parent of '..' is '../..'";
is IO::Path::Win32.new("\\foo").parent,			"\\",			"parent at top level is '/'";
is IO::Path::Win32.new("\\").parent,			"\\",			"parent of root is '/'";

is IO::Path::Win32.new("\\").child('foo'),	"\\foo",		"append to root";
is IO::Path::Win32.new(".").child('foo'),	"foo",		"append to cwd";

my $numfile = IO::Path::Win32.new("foo\\file01.txt");
is $numfile.succ,	"foo\\file02.txt", "succ basic";
is $numfile.succ.succ,	"foo\\file03.txt", "succ x 2";
is $numfile.pred,	"foo\\file00.txt", "pred basic";
is IO::Path::Win32.new("foo\\()").succ, "foo\\()", "succ only effects basename";
is IO::Path::Win32.new("foo\\()").succ, "foo\\()", "pred only effects basename";

if IO::Spec.FSTYPE eq 'Win32' {
	ok IO::Path::Win32.new(~$*CWD).e,		"cwd exists, filetest inheritance ok";
	ok IO::Path::Win32.new(~$*CWD).d,		"cwd is a directory";
}
else {
	skip "On-system tests for filetest inheritance", 2;
}



done;

�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/IO-Socket-INET.bat�����������������������������������������������������0000664�0001750�0001750�00000001065�12224265625�017746� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������@ECHO OFF
:: script for Windows to supply fork() to rakudo
:: based on IO-Socket-INET.sh
SET TEST=%1
SET PORT=%2

:: clear the status message flag but don't whinge about the file not being there
DEL t\spec\S32-io\server-ready-flag 2> NUL

:: Use START to fork the server and set the window title so we can kill it later
START "P6IOSOCKETtest" /MIN perl6 t\spec\S32-io\IO-Socket-INET.pl %TEST% %PORT% server

perl6 t\spec\S32-io\IO-Socket-INET.pl %TEST% %PORT% client

:: Clean up any stray processes
TASKKILL /FI "WINDOWTITLE eq P6IOSOCKETtest" > NUL���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/IO-Socket-INET.pl������������������������������������������������������0000664�0001750�0001750�00000021732�12224265625�017616� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# t/spec/S32-io/IO-Socket-INET.pl
# run by IO-Socket-INET.sh, which is run by IO-Socket-INET.t

# May 2009: script laden with commented out warnings that
# can be removed after stability of tests has been confirmed
# on multiple operating systems.

use v6;

# use Perl 5 style subs for constants until 'constant' works again
sub PF_INET     { 2 } # constant PF_INET     = 2; # these should move into a file,
sub SOCK_STREAM { 1 } # constant SOCK_STREAM = 1; # but what name and directory?
sub TCP         { 6 } # constant TCP         = 6;
my ( $test, $port, $server_or_client ) = @*ARGS;
$port = $port.Int;
my $host = '127.0.0.1';
my $server_ready_flag_fn = 't/spec/S32-io/server-ready-flag';

given $test {

    when 2 { # test number 2 - echo protocol, RFC 862
        if $server_or_client eq 'server' {
            # warn "SERVER TEST=$test PORT=$port";
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            # warn "SERVER LISTENING";
            my $fd = open( $server_ready_flag_fn, :w );
            $fd.close();
            while my $client = $server.accept() {
                # warn "SERVER ACCEPTED";
                my $received = $client.recv();
                # warn "SERVER RECEIVED '$received'";
                $client.send( $received );
                # warn "SERVER REPLIED";
                $client.close();
            }
        }
        else { # $server_or_client eq 'client'
            # warn "CLIENT TEST=$test PORT=$port";
            # avoid a race condition, where the client tries to
            # open() before the server gets to accept().
            until $server_ready_flag_fn.IO ~~ :e { sleep(0.1) }
            unlink $server_ready_flag_fn;
            my $client = IO::Socket::INET.new(:$host, :$port);
            # warn "CLIENT OPENED";
            $client.send( [~] '0'..'9', 'a'..'z' );
            # warn "CLIENT SENT";
            my $received = $client.recv();
            # warn "CLIENT RECEIVED '$received'";
            # let IO-Socket-INET.t judge the pass/fail
            say "echo '$received' received";
            $client.close();
        }
    }

    when 3 { # test number 3 - discard protocol, RFC 863
        if $server_or_client eq 'server' {
            # warn "SERVER TEST=$test PORT=$port";
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            # warn "SERVER LISTENING";
            while my $client = $server.accept() {
                # warn "SERVER ACCEPTED";
                my $received = $client.recv();
                # warn "SERVER RECEIVED '$received'";
                $client.close(); # without sending anything back
            }
        }
        else { # $server_or_client eq 'client'
            # warn "CLIENT TEST=$test PORT=$port";
            # avoid a race condition, where the client tries to
            # open() before the server gets to accept().
            sleep 1; # crude, sorry
            my $client = IO::Socket::INET.new(:$host, :$port);
            # warn "CLIENT OPENED";
            $client.send( [~] '0'..'9', 'a'..'z' );
            # warn "CLIENT SENT";
            my $received = $client.recv();
            # warn "CLIENT RECEIVED '$received'";
            # let IO-Socket-INET.t judge the pass/fail
            say "discard '$received' received";
            $client.close();
        }
    }

    when 4 { # test number 4 - recv with parameter
        if $server_or_client eq 'server' {
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            my $fd = open( $server_ready_flag_fn, :w );
            $fd.close();
            while my $client = $server.accept() {
                # Also sends two 3 byte unicode characters
                $client.send(join '',  '0'..'9', 'a'..'z',
                        chr(0xbeef),  chr(0xbabe) );
                $client.close();
            }
        }
        else {
            until $server_ready_flag_fn.IO ~~ :e { sleep(0.1) }
            unlink $server_ready_flag_fn;
            my $sock = IO::Socket::INET.new(:$host, :$port);
            # Tests that if we do not receive all the data available
            # it is buffered correctly for when we do request it
            say $sock.recv(7); # 0123456
            say $sock.recv(3); # 789
            say $sock.recv(26); # a-z
            # All is left are the two 3 byte characters 
            my $beef = $sock.recv(1);
            say $beef;
            say $beef.chars;
            # get second character
            my $babe = $sock.recv(1);
            say $babe.chars;
            # join it together
            say $babe;
            $sock.close();
        }
    }

    when 5 { # test number 5 - get()
        if $server_or_client eq 'server' {
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            my $fd = open($server_ready_flag_fn, :w);
            $fd.close();
            while my $client = $server.accept() {
                # default line separator
                $client.send("'Twas brillig, and the slithy toves\n");
                $client.send("Did gyre and gimble in the wabe;\n");
                # custom line separator: \r\n
                $client.send("All mimsy were the borogoves,\r\n");
                # another custom separator: .
                $client.send("And the mome raths outgrabe.");
                # separator not at the end of the sent data: !
                $client.send("O frabjous day! Callooh! Callay!");
                $client.close();
            }
        } else { # client
            until $server_ready_flag_fn.IO ~~ :e { sleep(0.1) }
            unlink $server_ready_flag_fn;
            my $sock = IO::Socket::INET.new(:$host, :$port);
            say $sock.get();
            say $sock.get();
            $sock.input-line-separator = "\r\n";
            say $sock.get();
            $sock.input-line-separator = '.';
            say $sock.get();
            $sock.input-line-separator = '!';
            say $sock.get();
            say $sock.get(); # will begin
            say $sock.get(); # with a space
            $sock.close();
        }
    }

    when 6 { # RT #116288, test number 6 - read with parameter
        if $server_or_client eq 'server' {
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            my $fd = open( $server_ready_flag_fn, :w );
            $fd.close();
            while my $client = $server.accept() {
                # send 4 packets á 4096 bytes
                for ^4 {
                    $client.send( $_ x 4096 );
                    sleep 1;
                }
                $client.close();
            }
        }
        else {
            until $server_ready_flag_fn.IO ~~ :e { sleep(0.1) }
            unlink $server_ready_flag_fn;
            my $sock = IO::Socket::INET.new(:$host, :$port);
            # .read will give us 16kB of data even it recvs several chunks of smaller size
            my $collected = $sock.read( 4096 * 4 );
            say $collected.at_pos( 0 ).chr;
            say $collected.at_pos( 4096 * 4 - 1 ).chr;
            say $collected.bytes;
            $sock.close();
        }
    }

    # for test 7 and 8
    my Buf $binary = slurp( 't/spec/S32-io/socket-test.bin', bin => True );

    when 7 { # test number 7 - write/read binary data
        if $server_or_client eq 'server' {
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            my $fd = open( $server_ready_flag_fn, :w );
            $fd.close();
            if my $client = $server.accept() {
                # send binary data á 4096 bytes
                $client.write( $binary );
                $client.close();
            }
        }
        else {
            until $server_ready_flag_fn.IO ~~ :e { sleep(0.1) }
            unlink $server_ready_flag_fn;
            my $sock = IO::Socket::INET.new(:$host, :$port);
            my $recv = $sock.read( $binary.elems() );
            say $binary eqv $recv ?? 'OK-7' !! 'NOK-7';
            $sock.close();
        }
    }

    when 8 { # test number 8 - write/recv binary data
        if $server_or_client eq 'server' {
            my $server = IO::Socket::INET.new(:localhost($host), :localport($port), :listen);
            my $fd = open( $server_ready_flag_fn, :w );
            $fd.close();
            if my $client = $server.accept() {
                # send binary data á 4096 bytes
                $client.write( $binary );
                $client.close();
            }
        }
        else {
            until $server_ready_flag_fn.IO ~~ :e { sleep(0.1) }
            unlink $server_ready_flag_fn;
            my $sock = IO::Socket::INET.new(:$host, :$port);
            my Buf $recv = Buf.new;
            my Buf $chunk;
            # in binary mode it will return a Buf, not Str
            while $chunk = $sock.recv( 4096, bin => True ) {
                $recv ~= $chunk;
            }
            say $binary eqv $recv ?? 'OK-8' !! 'NOK-8';
            $sock.close();
        }
    }
}

=begin pod

=end pod
��������������������������������������rakudo-2013.12/t/spec/S32-io/IO-Socket-INET.sh������������������������������������������������������0000664�0001750�0001750�00000002511�12224265625�017607� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# shell script (unix style) to supply a fork() for Rakudo
TEST="$1"
PORT="$2"
# commented out echo lines are diagnostics used during development.
# echo IO-Socket-INET.sh TEST=$TEST PORT=$PORT

# clear a file that acts as a status message from server to client
rm t/spec/S32-io/server-ready-flag 2>/dev/null

# use & to run the server as a background process
./perl6 t/spec/S32-io/IO-Socket-INET.pl $TEST $PORT server & SERVER=$!

# use & to run the client as a background process
./perl6 t/spec/S32-io/IO-Socket-INET.pl $TEST $PORT client & CLIENT=$!

# make a watchdog to kill a hanging client (occurs only if a test fails)
#( sleep 20; kill $CLIENT 2>/dev/null && echo '(timeout)' ) &

# watchdog
# the client should exit after about 3 seconds. The watchdog would kill
# it after 20 sec. Hang around here until the client ends, either way.
I=0
while true; do
    # client finished
    kill -0 $CLIENT 2>/dev/null || break
    I=$(expr $I + 1)

    # killing client if we already waiting 20 seconds
    if [ $I -ge 45 ]; then
       echo '(timeout)'
       kill $CLIENT 2>/dev/null
       break
    fi
    sleep 1
done

# the client should exit after about 3 seconds. The watchdog would kill
# it after 10 sec. Hang around here until the client ends, either way.

# now that the client is finished either way, stop the server
kill $SERVER 2>/dev/null
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/IO-Socket-INET.t�������������������������������������������������������0000664�0001750�0001750�00000020614�12224265625�017444� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 41;

{
    #?rakudo.jvm emit 
    skip_rest('rakudo.jvm systemic failures/OOM error');
    #?rakudo.jvm emit 
    exit 0;
}

diag "{elapsed} starting tests";
my $elapsed;
sub elapsed {
    state $last = time;
    LEAVE $last = time;
    return "[{ $elapsed = time - $last }s]";
}
my $toolong = 60;

# L<S32::IO/IO::Socket::INET>

# Testing socket must solve 2 problems: find an unused port to bind to,
# and fork a client process before the server is blocked in accept().

my $host = '127.0.0.1';   # or 'localhost' may be friendlier

# To find an free port, list the ports currently in use.
my ( @ports, $netstat_cmd, $netstat_pat, $received, $expected );
given $*OS {
    when any 'linux', 'Linux' {
        $netstat_cmd = "netstat --tcp --all --numeric";
        $netstat_pat = rx{ State .+? [ ^^ .+? ':' (\d+) .+? ]+ $ };
    }
    when any 'darwin', 'Mac OS X' {
        $netstat_cmd = "netstat -f inet -p tcp -a -n";
        $netstat_pat = rx{ [ ^^  .+? '.' (\d+) ' ' .+? ]+ $ };
    }
    when 'solaris' {
        $netstat_cmd = "netstat -an -P tcp -f inet";
        $netstat_pat = rx{ [ ^^  .+? '.' (\d+) ' ' .+? ]+ $ }; # same as darwin
    }
    when 'MSWin32' {
        $netstat_cmd = "netstat -n";
        $netstat_pat = rx{ State .+? [ ^^ .+? ':' (\d+) .+? ]+ $ }; # same as linux
    }
    default {
        skip_rest('Operating system not yet supported');
        exit 0;
    }
    # TODO: other operating systems; *BSD etc.	 
}
$received = qqx{$netstat_cmd};                    # refactor into 1 line after
if $received ~~ $netstat_pat { @ports = $/.list; }  # development complete
                         # was @ports = $/[]      in Rakudo/alpha
                         #     @ports = $/[0] also now in master
#warn @ports.elems ~ " PORTS=" ~ @ports;

# sequentially search for the first unused port
my $port = 1024;
while $port < 65535 && $port==any(@ports) { $port++; }
if $port >= 65535 {
    diag "no free port; aborting";
    skip_rest 'No port free - cannot test';
    exit 0;
}
diag "{elapsed} Testing on port $port";


if $*OS eq any <linux Linux darwin solaris MSWin32>, 'Mac OS X' { # please add more valid OS names

    my $is-win;
    $is-win = True if $*OS eq 'MSWin32';

    # test 2 does echo protocol - Internet RFC 862
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 2 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 2 $port};
    }
    #warn "TEST 2 $received";
    $expected = "echo '0123456789abcdefghijklmnopqrstuvwxyz' received\n";
    is $received, $expected, "{elapsed} echo server and client";
    nok $elapsed > $toolong, "finished in time #1";

    # test 3 does discard protocol - Internet RFC 863
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 3 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 3 $port};
    }
    #warn "TEST 3 $received";
    $expected = "discard '' received\n";
    is $received, $expected, "{elapsed} discard server and client";
    nok $elapsed > $toolong, "finished in time #2";

    # test 4 tests recv with a parameter
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 4 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 4 $port};
    }
    $expected = $received.split("\n");
    my $i = 0;
    is $expected[$i++], '0123456', "{elapsed} received first 7 characters";
    nok $elapsed > $toolong, "finished in time #3";
    is $expected[$i++], '789', "{elapsed} received next 3 characters";
    nok $elapsed > $toolong, "finished in time #4";
    is $expected[$i++], 'abcdefghijklmnopqrstuvwxyz', "{elapsed} remaining 26 were buffered";
    nok $elapsed > $toolong, "finished in time #5";
    # Multibyte characters
    # RT #115862
    is $expected[$i], chr(0xbeef), "{elapsed} received {chr 0xbeef}";
    nok $elapsed > $toolong, "finished in time #6";
    $i++;
    is $expected[$i++], 1, "{elapsed} ... which is 1 character";
    nok $elapsed > $toolong, "finished in time #7";
    is $expected[$i++], 1, "{elapsed} received another character";
    nok $elapsed > $toolong, "finished in time #8";
    # RT #115862
    is $expected[$i], chr(0xbabe), "{elapsed} combined the bytes form {chr 0xbabe}";
    nok $elapsed > $toolong, "finished in time #9";
    $i++;

    # test 5 tests get()
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 5 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 5 $port};
    }
    $expected = $received.split("\n");
    $i = 0;
    is $expected[$i++], "'Twas brillig, and the slithy toves",
      "{elapsed} get() with default separator";
    nok $elapsed > $toolong, "finished in time #10";
    is $expected[$i++], 'Did gyre and gimble in the wabe;',
      "{elapsed} default separator";
    nok $elapsed > $toolong, "finished in time #11";
    is $expected[$i++], 'All mimsy were the borogoves,',
      "{elapsed} \\r\\n separator";
    nok $elapsed > $toolong, "finished in time #12";
    is $expected[$i++], 'And the mome raths outgrabe',
      "{elapsed} . as a separator";
    nok $elapsed > $toolong, "finished in time #13";
    is $expected[$i++], 'O frabjous day',
      "{elapsed} ! separator not at end of string";
    nok $elapsed > $toolong, "finished in time #14";
    is $expected[$i++], ' Callooh',
      "{elapsed} Multiple separators not at end of string";
    nok $elapsed > $toolong, "finished in time #15";
    is $expected[$i++], ' Callay',
      "{elapsed} ! separator at end of string";

    # RT #116288, test 6 tests read with a parameter
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 6 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 6 $port};
    }
    $expected = $received.split("\n");
    $i = 0;
    is $expected[$i++], '0', "{elapsed} received first character";
    nok $elapsed > $toolong, "finished in time #16";
    is $expected[$i++], '3', "{elapsed} received last character";
    nok $elapsed > $toolong, "finished in time #17";
    is $expected[$i++], 4096 * 4, "{elapsed} total amount ";
    nok $elapsed > $toolong, "finished in time #18";

    # test 7 tests recv with binary data
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 7 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 7 $port};
    }
    $expected = $received.split("\n");
    is $expected[0], 'OK-7', "{elapsed} successful read binary data";
    nok $elapsed > $toolong, "finished in time #19";

    # test 8 tests recv with binary data.
    if $is-win {
        $received = qqx{t\\spec\\S32-io\\IO-Socket-INET.bat 8 $port};
    } else {
        $received = qqx{sh t/spec/S32-io/IO-Socket-INET.sh 8 $port};
    }
    $expected = $received.split("\n");
    is $expected[0], 'OK-8', "{elapsed} successful received binary data";
    nok $elapsed > $toolong, "finished in time #20";
}
else {
    skip "OS '$*OS' shell support not confirmed", 1;
}


=begin pod

=head1 Perl 6 Internet Sockets Testing
The initial use of the BSD Sockets library by Parrot and Rakudo happened
without a formal test suite, slowing development and causing occasional
random errors. This set of tests aims to ensure the future stability of
of the Sockets library integration, and to help enhance Rakudo's
IO::Socket::INET class in the 'setting'.

The BSD Sockets functions provide server and client functions that run
synchronously, blocking and waiting indefinitely for communication from
a remote process. Sockets testing therefore requires separate server and
client processes or threads. Rakudo does not currently fork or thread,
so these tests employ a unix shell script that uses the & symbol to fork
background processes. When Rakudo starts forking or threading, this
testing solution should be refactored down to just the main script.

=head1 Scope of tests
To date, only single TCP sessions have been tested, and only on Linux.
The Internet standard protocols are used, except that a dynamic port
number above the first 1024 is used so that superuser (root) privileges
are not required. Execution time is 5 to 10 seconds.

=head1 TODO
UDP. Unix sockets. Concurrent connections (needs threads).

=head1 SEE ALSO

 echo    L<http://www.ietf.org/rfc/rfc862.txt> port  7
 discard L<http://www.ietf.org/rfc/rfc863.txt> port  9
 chargen L<http://www.ietf.org/rfc/rfc864.txt> port 19
 daytime L<http://www.ietf.org/rfc/rfc867.txt> port 13
 time    L<http://www.ietf.org/rfc/rfc868.txt> port 37

=end pod

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-spec-cygwin.t�������������������������������������������������������0000664�0001750�0001750�00000013017�12224265625�020006� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
# L<S32::IO/IO::Spec>

plan 102;
my $cygwin = IO::Spec::Cygwin;

my @canonpath =
	'///../../..//./././a//b/.././c/././',   '/a/b/../c',
	'',                       '',
	'a/../../b/c',            'a/../../b/c',
	'/.',                     '/',
	'/./',                    '/',
	'/a/./',                  '/a',
	'/a/.',                   '/a',
	'/../../',                '/',
	'/../..',                 '/',
        'a:\\b\\c',               'a:/b/c',
	'c:a\\.\\b',              'c:a/b';
for @canonpath -> $in, $out {
	is $cygwin.canonpath($in), $out, "canonpath: '$in' -> '$out'";
}

my @splitdir =
	'',           '',
	'/d1/d2/d3/', ',d1,d2,d3,',
	'd1/d2/d3/',  'd1,d2,d3,',
	'/d1/d2/d3',  ',d1,d2,d3',
	'd1/d2/d3',   'd1,d2,d3';

for @splitdir -> $in, $out {
	is $cygwin.splitdir(|$in).join(','), $out, "splitdir: '$in' -> '$out'"
}

is $cygwin.catdir(),                        '', "No argument returns empty string";
my @catdir =
	$( ),                    '',
	$('/'),                  '/',
	$('','d1','d2','d3',''), '/d1/d2/d3',
	$('d1','d2','d3',''),    'd1/d2/d3',
	$('','d1','d2','d3'),    '/d1/d2/d3',
	$('d1','d2','d3'),       'd1/d2/d3',
	$('/','d2/d3'),          '/d2/d3',
        $('/','/d1/d2'),         '/d1/d2',
        $('//notreally','/UNC'), '/notreally/UNC';
for @catdir -> $in, $out {
	is $cygwin.catdir(|$in), $out, "catdir: {$in.perl} -> '$out'";
}

my @split = 
	'/',               ',/,/',
	'.',               ',.,.',
	'file',            ',.,file',
	'/dir',            ',/,dir',
	'/d1/d2/d3/',      ',/d1/d2,d3',
	'd1/d2/d3/',       ',d1/d2,d3',
	'/d1/d2/d3/.',     ',/d1/d2/d3,.',
	'/d1/d2/d3/..',    ',/d1/d2/d3,..',
	'/d1/d2/d3/.file', ',/d1/d2/d3,.file',
	'd1/d2/d3/file',   ',d1/d2/d3,file',
	'/../../d1/',      ',/../..,d1',
	'/././d1/',        ',/./.,d1',
	'c:/d1\\d2\\',    'c:,/d1,d2',
        '//unc/share',     '//unc/share,/,/';
for @split -> $in, $out {
	is $cygwin.split(|$in).hash.<volume directory basename>.join(','),
            $out, "split: {$in.perl} -> '$out'"
}

my @join = 
	$('','','file'),            'file',
	$('','/d1/d2/d3/',''),      '/d1/d2/d3/',
	$('','d1/d2/d3/',''),       'd1/d2/d3/',
	$('','/d1/d2/d3/.',''),     '/d1/d2/d3/.',
	$('','/d1/d2/d3/..',''),    '/d1/d2/d3/..',
	$('','/d1/d2/d3/','.file'), '/d1/d2/d3/.file',
	$('','d1/d2/d3/','file'),   'd1/d2/d3/file',
	$('','/../../d1/',''),      '/../../d1/',
	$('','/././d1/',''),        '/././d1/',
	$('d:','d2/d3/',''),        'd:d2/d3/',
	$('d:/','d2','d3/'),        'd:/d2/d3/';
for @join -> $in, $out {
	is $cygwin.join(|$in), $out, "join: {$in.perl} -> '$out'"
}


my @splitpath = 
	'file',            ',,file',
	'/d1/d2/d3/',      ',/d1/d2/d3/,',
	'd1/d2/d3/',       ',d1/d2/d3/,',
	'/d1/d2/d3/.',     ',/d1/d2/d3/.,',
	'/d1/d2/d3/..',    ',/d1/d2/d3/..,',
	'/d1/d2/d3/.file', ',/d1/d2/d3/,.file',
	'd1/d2/d3/file',   ',d1/d2/d3/,file',
	'/../../d1/',      ',/../../d1/,',
	'/././d1/',        ',/././d1/,';
for @splitpath -> $in, $out {
	is $cygwin.splitpath(|$in).join(','), $out, "splitpath: {$in.perl} -> '$out'"
}

my @catpath = 
	$('','','file'),            'file',
	$('','/d1/d2/d3/',''),      '/d1/d2/d3/',
	$('','d1/d2/d3/',''),       'd1/d2/d3/',
	$('','/d1/d2/d3/.',''),     '/d1/d2/d3/.',
	$('','/d1/d2/d3/..',''),    '/d1/d2/d3/..',
	$('','/d1/d2/d3/','.file'), '/d1/d2/d3/.file',
	$('','d1/d2/d3/','file'),   'd1/d2/d3/file',
	$('','/../../d1/',''),      '/../../d1/',
	$('','/././d1/',''),        '/././d1/',
	$('d:','d2/d3/',''),        'd:d2/d3/',
	$('d:/','d2','d3/'),        'd:/d2/d3/';
for @catpath -> $in, $out {
	is $cygwin.catpath(|$in), $out, "catpath: {$in.perl} -> '$out'"
}

my @catfile = 
	$('a','b','c'),         'a/b/c',
	$('a','b','./c'),       'a/b/c',
	$('./a','b','c'),       'a/b/c',
	$('c'),                 'c',
	$('./c'),               'c';
for @catfile -> $in, $out {
	is $cygwin.catfile(|$in), $out, "catfile: {$in.perl} -> '$out'"
}


my @abs2rel = 
	$('/t1/t2/t3','/t1/t2/t3'),          '.',
	$('/t1/t2/t4','/t1/t2/t3'),          '../t4',
	$('/t1/t2','/t1/t2/t3'),             '..',
	$('/t1/t2/t3/t4','/t1/t2/t3'),       't4',
	$('/t4/t5/t6','/t1/t2/t3'),          '../../../t4/t5/t6',
#	$('../t4','/t1/t2/t3'),              '../t4',
	$('/','/t1/t2/t3'),                  '../../..',
	$('///','/t1/t2/t3'),                '../../..',
	$('/.','/t1/t2/t3'),                 '../../..',
	$('/./','/t1/t2/t3'),                '../../..',
	$('/t1/t2/t3', '/'),                 't1/t2/t3',
	$('/t1/t2/t3', '/t1'),               't2/t3',
	$('t1/t2/t3', 't1'),                 't2/t3',
	$('t1/t2/t3', 't4'),                 '../t1/t2/t3';
for @abs2rel -> $in, $out {
	is $cygwin.abs2rel(|$in), $out, "abs2rel: {$in.perl} -> '$out'"
}

my @rel2abs = 
	$('t4','/t1/t2/t3'),             '/t1/t2/t3/t4',
	$('t4/t5','/t1/t2/t3'),          '/t1/t2/t3/t4/t5',
	$('.','/t1/t2/t3'),              '/t1/t2/t3',
	$('..','/t1/t2/t3'),             '/t1/t2/t3/..',
	$('../t4','/t1/t2/t3'),          '/t1/t2/t3/../t4',
	$('/t1','/t1/t2/t3'),            '/t1',
	$('//t1/t2/t3','/foo'),          '//t1/t2/t3';
for @rel2abs -> $in, $out {
	is $cygwin.rel2abs(|$in), $out, "rel2abs: {$in.perl} -> '$out'"
}


is $cygwin.curdir,  '.',   'curdir is "."';
is $cygwin.devnull, '/dev/null', 'devnull is /dev/null';
is $cygwin.rootdir, '/',  'rootdir is "\\"';
is $cygwin.updir,   '..',  'updir is ".."';


if $*OS !~~ any(<cygwin>) {
	skip_rest 'cygwin on-platform tests'
}
else {
	# double check a couple of things to see if IO::Spec loaded correctly
	is IO::Spec.rootdir, '\\',  'IO::Spec loads Cygwin';
	ok {.IO.d && .IO.w}.(IO::Spec.tmpdir), "tmpdir: {IO::Spec.tmpdir} is a writable directory";
}

done;
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-spec-unix.t���������������������������������������������������������0000664�0001750�0001750�00000023231�12224265625�017470� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
# L<S32::IO/IO::Spec>

plan 129;

my $Unix := IO::Spec::Unix;

my %canonpath = (
        'a/b/c'              => 'a/b/c',
        '//a//b//'           => '/a/b',
	'a/../../b/c'        => 'a/../../b/c',
	'/.'                 => '/',
	'/./'                => '/',
	'/a/./'              => '/a',
	'/a/.'               => '/a',
	'/../../'            => '/',
	'/../..'             => '/',
	'/..'                => '/',
        'a\\\\b'             => 'a\\\\b',
	''                   => '',
        '0'                  => '0',
	'///../../..//./././a//b/.././c/././' => '/a/b/../c',
);
for %canonpath.kv -> $get, $want {
	is $Unix.canonpath( $get ), $want, "canonpath: '$get' -> '$want'";
}
my %canonpath-parent = (
	"foo/bar/.."         => "foo",
	"foo/bar/baz/../.."  => "foo",
	"/foo/.."            => "/",
	"foo/.."             => '.',
	"foo/../bar/../baz"  => "baz",
	"foo/../../bar"      => "../bar",
	"foo/bar/baz/../.."  => "foo",
	"../../.."           => "../../..",
	"/../../.."          => "/",
	"/foo/../.."         => "/",
	"0"                  => "0",
        ''                   => '',
	"//../..usr/bin/../foo/.///ef"   => "/..usr/foo/ef",
	'///../../..//./././a//b/.././c/././' => '/a/c',
);
for %canonpath-parent.kv -> $get, $want {
	is $Unix.canonpath( $get , :parent ), $want, "canonpath(:parent): '$get' -> '$want'";
}
say "# warning expected here:";
is $Unix.canonpath( Any , :parent ), '', "canonpath(:parent): Any -> ''";

is $Unix.catdir( ),                      '',          "catdir: no arg -> ''";
is $Unix.catdir( '' ),                   '/',         "catdir: '' -> '/'";
is $Unix.catdir( '/' ),                  '/',         "catdir: '/' -> '/'";
is $Unix.catdir( '','d1','d2','d3','' ), '/d1/d2/d3', "catdir: ('','d1','d2','d3','') -> '/d1/d2/d3'";
is $Unix.catdir( 'd1','d2','d3','' ),    'd1/d2/d3',  "catdir: ('d1','d2','d3','') -> 'd1/d2/d3'";
is $Unix.catdir( '','d1','d2','d3' ),    '/d1/d2/d3', "catdir: ('','d1','d2','d3') -> '/d1/d2/d3'";
is $Unix.catdir( 'd1','d2','d3' ),       'd1/d2/d3',  "catdir: ('d1','d2','d3') -> 'd1/d2/d3'";
is $Unix.catdir( '/','d2/d3' ),          '/d2/d3',    "catdir: ('/','d2/d3') -> '/d2/d3'";

is $Unix.catfile('a','b','c'),   'a/b/c', "catfile: ('a','b','c') -> 'a/b/c'";
is $Unix.catfile('a','b','./c'), 'a/b/c', "catfile: ('a','b','./c') -> 'a/b/c'";
is $Unix.catfile('./a','b','c'), 'a/b/c', "catfile: ('./a','b','c') -> 'a/b/c'";
is $Unix.catfile('c'),           'c',     "catfile: 'c' -> 'c'";
is $Unix.catfile('./c'),         'c',     "catfile: './c' -> 'c'";

is $Unix.curdir,  '.',         'curdir is "."';
is $Unix.devnull, '/dev/null', 'devnull is /dev/null';
is $Unix.rootdir, '/',         'rootdir is "/"';

is $Unix.updir,   '..',        'updir is ".."';

isnt '.',    $Unix.no-parent-or-current-test,   "no-parent-or-current-test: '.'";
isnt '..',   $Unix.no-parent-or-current-test,   "no-parent-or-current-test: '..'";
is   '.git', $Unix.no-parent-or-current-test,   "no-parent-or-current-test: '.git'";
is   'file', $Unix.no-parent-or-current-test,   "no-parent-or-current-test: 'file'";

ok  $Unix.is-absolute( '/abcd/ef' ), 'is-absolute: ok "/abcd/ef"';
ok  $Unix.is-absolute( '/'    ),  'is-absolute: ok "/"';
nok $Unix.is-absolute( 'abcd/ef' ),  'is-absolute: nok "abcd"';
nok $Unix.is-absolute( '..' ),  'is-absolute: nok ".."';

my $path = %*ENV<PATH>;
%*ENV<PATH> = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games:';
my @want         = </usr/local/sbin /usr/local/bin /usr/sbin /usr/bin /sbin /bin /usr/games .>;
is_deeply $Unix.path, @want, 'path';
%*ENV<PATH> = $path;

my %splitpath = (
	'file'            => ('', '',             'file'),
	'/d1/d2/d3/'      => ('', '/d1/d2/d3/',   ''),
	'd1/d2/d3/'       => ('', 'd1/d2/d3/',    ''),
	'/d1/d2/d3/.'     => ('', '/d1/d2/d3/.',  ''),
	'/d1/d2/d3/..'    => ('', '/d1/d2/d3/..', ''),
	'/d1/d2/d3/.file' => ('', '/d1/d2/d3/',   '.file'),
	'd1/d2/d3/file'   => ('', 'd1/d2/d3/',    'file'),
	'/../../d1/'      => ('', '/../../d1/',   ''),
	'/././d1/'        => ('', '/././d1/',     ''),
);
for %splitpath.kv -> $get, $want {
	is $Unix.splitpath( $get ), $want, "splitpath: '$get' -> '$want'";
}

my %split = (
	'/'               => ('', '/',             '/'),
	'.'               => ('', '.',             '.'),
	'file'            => ('', '.',          'file'),
        'dir/'            => ('', '.',           'dir'),
        '/dir/'           => ('', '/',           'dir'),
	'/d1/d2/d3/'      => ('', '/d1/d2',       'd3'),
	'd1/d2/d3/'       => ('', 'd1/d2',        'd3'),
	'/d1/d2/d3/.'     => ('', '/d1/d2/d3',     '.'),
	'/d1/d2/d3/..'    => ('', '/d1/d2/d3',    '..'),
	'/d1/d2/d3/.file' => ('', '/d1/d2/d3', '.file'),
	'd1/d2/d3/file'   => ('', 'd1/d2/d3',   'file'),
	'/../../d1/'      => ('', '/../..',       'd1'),
	'/././d1/'        => ('', '/./.',         'd1'),
);
for %split.kv -> $get, $want {
	is $Unix.split( $get ).hash.<volume directory basename>, $want, "split: '$get' -> '$want'";
}

my @join = (
	$('','.','.'),              '.',
	$('','/','/'),              '/',
        $('','.','file'),           'file',
	$('','','file'),            'file',
        $('','dir','.'),            'dir/.',
	$('','/d1/d2/d3/',''),      '/d1/d2/d3/',
	$('','d1/d2/d3/',''),       'd1/d2/d3/',
	$('','/d1/d2/d3/.',''),     '/d1/d2/d3/.',
	$('','/d1/d2/d3/..',''),    '/d1/d2/d3/..',
	$('','/d1/d2/d3/','.file'), '/d1/d2/d3/.file',
	$('','d1/d2/d3/','file'),   'd1/d2/d3/file',
	$('','/../../d1/',''),      '/../../d1/',
	$('','/././d1/',''),        '/././d1/',
	$('d1','d2/d3/',''),        'd2/d3/',
	$('d1','d2','d3/'),         'd2/d3/'
);
for @join -> $get, $want {
	is $Unix.join( |$get ), $want, "join: '$get' -> '$want'";
}


my %splitdir = (
	''           => '',
	'/d1/d2/d3/' => ('', 'd1', 'd2', 'd3', ''),
	'd1/d2/d3/'  => ('d1', 'd2', 'd3', ''),
	'/d1/d2/d3'  => ('', 'd1', 'd2', 'd3'),
	'd1/d2/d3'   => ('d1', 'd2', 'd3'),
);
for %splitdir.kv -> $get, $want {
	is $Unix.splitdir( $get ), $want, "splitdir: '$get' -> '$want'";
}

is $Unix.catpath('','','file'),            'file',            "catpath: ('','','file') -> 'file'";
is $Unix.catpath('','/d1/d2/d3/',''),      '/d1/d2/d3/',      "catpath: ('','/d1/d2/d3/','') -> '/d1/d2/d3/'";
is $Unix.catpath('','d1/d2/d3/',''),       'd1/d2/d3/',       "catpath: ('','d1/d2/d3/','') -> 'd1/d2/d3/'";
is $Unix.catpath('','/d1/d2/d3/.',''),     '/d1/d2/d3/.',     "catpath: ('','/d1/d2/d3/.','') -> '/d1/d2/d3/.'";
is $Unix.catpath('','/d1/d2/d3/..',''),    '/d1/d2/d3/..',    "catpath: ('','/d1/d2/d3/..','') -> '/d1/d2/d3/..'";
is $Unix.catpath('','/d1/d2/d3/','.file'), '/d1/d2/d3/.file', "catpath: ('','/d1/d2/d3/','.file') -> '/d1/d2/d3/.file'";
is $Unix.catpath('','d1/d2/d3/','file'),   'd1/d2/d3/file',   "catpath: ('','d1/d2/d3/','file') -> 'd1/d2/d3/file'";
is $Unix.catpath('','/../../d1/',''),      '/../../d1/',      "catpath: ('','/../../d1/','') -> '/../../d1/'";
is $Unix.catpath('','/././d1/',''),        '/././d1/',        "catpath: ('','/././d1/','') -> '/././d1/'";
is $Unix.catpath('d1','d2/d3/',''),        'd2/d3/',          "catpath: ('d1','d2/d3/','') -> 'd2/d3/'";
is $Unix.catpath('d1','d2','d3/'),         'd2/d3/',          "catpath: ('d1','d2','d3/') -> 'd2/d3/'";

is $Unix.abs2rel('/t1/t2/t3','/t1/t2/t3'),    '.',                  "abs2rel: ('/t1/t2/t3','/t1/t2/t3') -> '.'";
is $Unix.abs2rel('/t1/t2/t4','/t1/t2/t3'),    '../t4',              "abs2rel: ('/t1/t2/t4','/t1/t2/t3') -> '../t4'";
is $Unix.abs2rel('/t1/t2','/t1/t2/t3'),       '..',                 "abs2rel: ('/t1/t2','/t1/t2/t3') -> '..'";
is $Unix.abs2rel('/t1/t2/t3/t4','/t1/t2/t3'), 't4',                 "abs2rel: ('/t1/t2/t3/t4','/t1/t2/t3') -> 't4'";
is $Unix.abs2rel('/t4/t5/t6','/t1/t2/t3'),    '../../../t4/t5/t6',  "abs2rel: ('/t4/t5/t6','/t1/t2/t3') -> '../../../t4/t5/t6'";
is $Unix.abs2rel('/','/t1/t2/t3'),            '../../..',           "abs2rel: ('/','/t1/t2/t3') -> '../../..'";
is $Unix.abs2rel('///','/t1/t2/t3'),          '../../..',           "abs2rel: ('///','/t1/t2/t3') -> '../../..'";
is $Unix.abs2rel('/.','/t1/t2/t3'),           '../../..',           "abs2rel: ('/.','/t1/t2/t3') -> '../../..'";
is $Unix.abs2rel('/./','/t1/t2/t3'),          '../../..',           "abs2rel: ('/./','/t1/t2/t3') -> '../../..'";
# "Unix->abs2rel('../t4','/t1/t2/t3'),             '../t4',              "abs2rel: ('../t4','/t1/t2/t3') -> '../t4'";
is $Unix.abs2rel('/t1/t2/t3', '/'),           't1/t2/t3',           "abs2rel: ('/t1/t2/t3', '/') -> 't1/t2/t3'";
is $Unix.abs2rel('/t1/t2/t3', '/t1'),         't2/t3',              "abs2rel: ('/t1/t2/t3', '/t1') -> 't2/t3'";
is $Unix.abs2rel('t1/t2/t3', 't1'),           't2/t3',              "abs2rel: ('t1/t2/t3', 't1') -> 't2/t3'";
is $Unix.abs2rel('t1/t2/t3', 't4'),           '../t1/t2/t3',        "abs2rel: ('t1/t2/t3', 't4') -> '../t1/t2/t3'";

is $Unix.rel2abs('t4','/t1/t2/t3'),           '/t1/t2/t3/t4',    "rel2abs: ('t4','/t1/t2/t3') -> '/t1/t2/t3/t4'";
is $Unix.rel2abs('t4/t5','/t1/t2/t3'),        '/t1/t2/t3/t4/t5', "rel2abs: ('t4/t5','/t1/t2/t3') -> '/t1/t2/t3/t4/t5'";
is $Unix.rel2abs('.','/t1/t2/t3'),            '/t1/t2/t3',       "rel2abs: ('.','/t1/t2/t3') -> '/t1/t2/t3'";
is $Unix.rel2abs('..','/t1/t2/t3'),           '/t1/t2/t3/..',    "rel2abs: ('..','/t1/t2/t3') -> '/t1/t2/t3/..'";
is $Unix.rel2abs('../t4','/t1/t2/t3'),        '/t1/t2/t3/../t4', "rel2abs: ('../t4','/t1/t2/t3') -> '/t1/t2/t3/../t4'";
is $Unix.rel2abs('/t1','/t1/t2/t3'),          '/t1',             "rel2abs: ('/t1','/t1/t2/t3') -> '/t1'";

if $*OS ~~ any(<MSWin32 os2 NetWare symbian dos cygwin>) {
	skip_rest 'Unix on-platform tests'
}
else {
	isa_ok IO::Spec.MODULE, IO::Spec::Unix, "unix: loads correct module";
	is IO::Spec.rel2abs( IO::Spec.curdir ), $*CWD, "rel2abs: \$*CWD test";
	ok {.IO.d && .IO.w}.( IO::Spec.tmpdir ), "tmpdir: {IO::Spec.tmpdir} is a writable directory";
}

done;
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/io-spec-win.t����������������������������������������������������������0000664�0001750�0001750�00000031270�12224265625�017304� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
# L<S32::IO/IO::Spec>

plan 209;
my $win32 = IO::Spec::Win32;

my @canonpath = 
	'',               '',
	'a:',             'A:',
	'A:f',            'A:f',
	'A:/',            'A:\\',
	'a\\..\\..\\b\\c','a\\..\\..\\b\\c',
	'//a\\b//c',      '\\\\a\\b\\c',
	'/a/..../c',      '\\a\\....\\c',
	'//a/b\\c',       '\\\\a\\b\\c',
	'////',           '\\',
	'//',             '\\',
	'/.',             '\\',
	'//a/b/../../c',  '\\\\a\\b\\c',
	'\\../temp\\',    '\\temp',
	'\\../',          '\\',
	'\\..\\',         '\\',
	'/../',           '\\',
	'/..\\',          '\\',
	'd1/../foo',      'd1\\..\\foo';
for @canonpath -> $in, $out {
	is $win32.canonpath($in), $out, "canonpath: '$in' -> '$out'";
}
my @canonpath-parent = 
	"foo\\bar\\..",          "foo",
	"foo/bar/baz/../..",     "foo",
	"/foo/..",               "\\",
	"foo/..",                '.',
	"foo/../bar/../baz",     "baz",
	"foo/../../bar",         "..\\bar",
	"foo/bar/baz/../..",     "foo",
	"../../..",              "..\\..\\..",
	"\\..\\..\\..",          "\\",
	"/foo/../..",            "\\",
	"C:\\..\\foo",           "C:\\foo",
	"C:..",                  "C:..",
	"\\\\server\\share\\..", "\\\\server\\share", 
	"0",                     "0",
	"/..//..usr/bin/../foo/.///ef", "\\..usr\\foo\\ef",
;
for @canonpath-parent -> $in, $out {
	is $win32.canonpath($in, :parent), $out,
           "canonpath(:parent): '$in' -> '$out'";
}
say "# Warning expected here:";
is $win32.canonpath( Any, :parent ), '', "canonpath: Any -> ''";

my @splitdir = 
	'',              '',
	'\\d1/d2\\d3/',  ',d1,d2,d3,',
	'd1/d2\\d3/',    'd1,d2,d3,',
	'\\d1/d2\\d3',   ',d1,d2,d3',
	'd1/d2\\d3',     'd1,d2,d3';

for @splitdir -> $in, $out {
	is $win32.splitdir(|$in).join(','), $out, "splitdir: '$in' -> '$out'"
}

is $win32.catdir(),                        '', "No argument returns empty string";
my @catdir = 
	('/').item,                     '\\',
	('/', '../').item,              '\\',
	('/', '..\\').item,             '\\',
	('\\', '../').item,             '\\',
	('\\', '..\\').item,            '\\',
	('//d1','d2').item,             '\\\\d1\\d2',
	('\\d1\\','d2').item,           '\\d1\\d2',
	('\\d1','d2').item,             '\\d1\\d2',
	('\\d1','\\d2').item,           '\\d1\\d2',
	('\\d1','\\d2\\').item,         '\\d1\\d2',
	('','/d1','d2').item,           '\\d1\\d2',
	('','','/d1','d2').item,        '\\d1\\d2',
	('','//d1','d2').item,          '\\d1\\d2',
	('','','//d1','d2').item,       '\\d1\\d2',
	('','d1','','d2','').item,      '\\d1\\d2',
	('','d1','d2','d3','').item,    '\\d1\\d2\\d3',
	('d1','d2','d3','').item,       'd1\\d2\\d3',
	('','d1','d2','d3').item,       '\\d1\\d2\\d3',
	('d1','d2','d3').item,          'd1\\d2\\d3',
	('A:/d1','d2','d3').item,       'A:\\d1\\d2\\d3',
	('A:/d1','d2','d3','').item,    'A:\\d1\\d2\\d3',
	('A:/d1','B:/d2','d3','').item, 'A:\\d1\\B:\\d2\\d3',
	('A:/').item,                   'A:\\',
	('\\', 'foo').item,             '\\foo',
	('','','..').item,              '\\',
	('A:', 'foo').item,             'A:foo';
for @catdir -> $in, $out {
	is $win32.catdir(|$in), $out, "catdir: {$in.perl} -> '$out'";
}

my @splitpath = 
	'file',                            ',,file',
	'\\d1/d2\\d3/',                    ',\\d1/d2\\d3/,',
	'd1/d2\\d3/',                      ',d1/d2\\d3/,',
	'\\d1/d2\\d3/.',                   ',\\d1/d2\\d3/.,',
	'\\d1/d2\\d3/..',                  ',\\d1/d2\\d3/..,',
	'\\d1/d2\\d3/.file',               ',\\d1/d2\\d3/,.file',
	'\\d1/d2\\d3/file',                ',\\d1/d2\\d3/,file',
	'd1/d2\\d3/file',                  ',d1/d2\\d3/,file',
	'C:\\d1/d2\\d3/',                  'C:,\\d1/d2\\d3/,',
	'C:d1/d2\\d3/',                    'C:,d1/d2\\d3/,',
	'C:\\d1/d2\\d3/file',              'C:,\\d1/d2\\d3/,file',
	'C:d1/d2\\d3/file',                'C:,d1/d2\\d3/,file',
	'C:\\../d2\\d3/file',              'C:,\\../d2\\d3/,file',
	'C:../d2\\d3/file',                'C:,../d2\\d3/,file',
	'\\../..\\d1/',                    ',\\../..\\d1/,',
	'\\./.\\d1/',                      ',\\./.\\d1/,',
	'\\\\node\\share\\d1/d2\\d3/',     '\\\\node\\share,\\d1/d2\\d3/,',
	'\\\\node\\share\\d1/d2\\d3/file', '\\\\node\\share,\\d1/d2\\d3/,file',
	'\\\\node\\share\\d1/d2\\file',    '\\\\node\\share,\\d1/d2\\,file',
	\('file', :nofile),                ',file,',
	\('\\d1/d2\\d3/', :nofile),           ',\\d1/d2\\d3/,',
	\('d1/d2\\d3/', :nofile),             ',d1/d2\\d3/,',
	\('\\\\node\\share\\d1/d2\\d3/', :nofile),   '\\\\node\\share,\\d1/d2\\d3/,';

for @splitpath -> $in, $out {
	is $win32.splitpath(|$in).join(','), $out, "splitpath: {$in.perl} -> '$out'"
}

my @catpath = 
	('','','file').item,                            'file',
	('','\\d1/d2\\d3/','').item,                    '\\d1/d2\\d3/',
	('','d1/d2\\d3/','').item,                      'd1/d2\\d3/',
	('','\\d1/d2\\d3/.','').item,                   '\\d1/d2\\d3/.',
	('','\\d1/d2\\d3/..','').item,                  '\\d1/d2\\d3/..',
	('','\\d1/d2\\d3/','.file').item,               '\\d1/d2\\d3/.file',
	('','\\d1/d2\\d3/','file').item,                '\\d1/d2\\d3/file',
	('','d1/d2\\d3/','file').item,                  'd1/d2\\d3/file',
	('C:','\\d1/d2\\d3/','').item,                  'C:\\d1/d2\\d3/',
	('C:','d1/d2\\d3/','').item,                    'C:d1/d2\\d3/',
	('C:','\\d1/d2\\d3/','file').item,              'C:\\d1/d2\\d3/file',
	('C:','d1/d2\\d3/','file').item,                'C:d1/d2\\d3/file',
	('C:','\\../d2\\d3/','file').item,              'C:\\../d2\\d3/file',
	('C:','../d2\\d3/','file').item,                'C:../d2\\d3/file',
	('','\\../..\\d1/','').item,                    '\\../..\\d1/',
	('','\\./.\\d1/','').item,                      '\\./.\\d1/',
	('C:','foo','bar').item,                        'C:foo\\bar',
	('\\\\node\\share','\\d1/d2\\d3/','').item,     '\\\\node\\share\\d1/d2\\d3/',
	('\\\\node\\share','\\d1/d2\\d3/','file').item, '\\\\node\\share\\d1/d2\\d3/file',
	('\\\\node\\share','\\d1/d2\\','file').item,    '\\\\node\\share\\d1/d2\\file';

for @catpath -> $in, $out {
	is $win32.catpath(|$in), $out, "catpath: {$in.perl} -> '$out'"
}

say "# split tests";
my @split = 
        '\\',                               ',\\,\\',
        '.',                               ',.,.',
	'file',                            ',.,file',
	'\\d1/d2\\d3/',                    ',\\d1/d2,d3',
	'd1/d2\\d3/',                      ',d1/d2,d3',
	'\\d1/d2\\d3/.',                   ',\\d1/d2\\d3,.',
	'\\d1/d2\\d3/..',                  ',\\d1/d2\\d3,..',
	'\\d1/d2\\d3/.file',               ',\\d1/d2\\d3,.file',
	'\\d1/d2\\d3/file',                ',\\d1/d2\\d3,file',
	'd1/d2\\d3/file',                  ',d1/d2\\d3,file',
	'C:\\d1/d2\\d3/',                  'C:,\\d1/d2,d3',
	'C:d1/d2\\d3/',                    'C:,d1/d2,d3',
	'C:\\d1/d2\\d3/file',              'C:,\\d1/d2\\d3,file',
	'C:d1/d2\\d3/file',                'C:,d1/d2\\d3,file',
	'C:\\../d2\\d3/file',              'C:,\\../d2\\d3,file',
	'C:../d2\\d3/file',                'C:,../d2\\d3,file',
	'\\../..\\d1/',                    ',\\../..,d1',
	'\\./.\\d1/',                      ',\\./.,d1',
	'//unc/share',                     '//unc/share,\\,\\',
	'\\\\node\\share\\d1/d2\\d3/',     '\\\\node\\share,\\d1/d2,d3',
	'\\\\node\\share\\d1/d2\\d3/file', '\\\\node\\share,\\d1/d2\\d3,file',
	'\\\\node\\share\\d1/d2\\file',    '\\\\node\\share,\\d1/d2,file',
;
for @split -> $in, $out {
	is $win32.split(|$in).hash.<volume directory basename>.join(','),
          $out, "split: {$in.perl} -> '$out'"
}

say "# join tests";
my @join = 
	('','\\','\\').item,                            '\\',
	('','/','\\').item,                             '/',
	('','\\','/').item,                             '\\',
	('','.','.').item,                              '.',
	('','','file').item,                            'file',
	('','.','file').item,                           'file',
	('','\\d1/d2\\d3/','').item,                    '\\d1/d2\\d3/',
	('','d1/d2\\d3/','').item,                      'd1/d2\\d3/',
	('','\\d1/d2\\d3/.','').item,                   '\\d1/d2\\d3/.',
	('','\\d1/d2\\d3/..','').item,                  '\\d1/d2\\d3/..',
	('','\\d1/d2\\d3/','.file').item,               '\\d1/d2\\d3/.file',
	('','\\d1/d2\\d3/','file').item,                '\\d1/d2\\d3/file',
	('','d1/d2\\d3/','file').item,                  'd1/d2\\d3/file',
	('C:','\\d1/d2\\d3/','').item,                  'C:\\d1/d2\\d3/',
	('C:','d1/d2\\d3/','').item,                    'C:d1/d2\\d3/',
	('C:','\\d1/d2\\d3/','file').item,              'C:\\d1/d2\\d3/file',
	('C:','d1/d2\\d3/','file').item,                'C:d1/d2\\d3/file',
	('C:','\\../d2\\d3/','file').item,              'C:\\../d2\\d3/file',
	('C:','../d2\\d3/','file').item,                'C:../d2\\d3/file',
	('','\\../..\\d1/','').item,                    '\\../..\\d1/',
	('','\\./.\\d1/','').item,                      '\\./.\\d1/',
	('C:','foo','bar').item,                        'C:foo\\bar',
        ('\\\\server\\share', '\\', '\\').item,		'\\\\server\\share',
	('\\\\node\\share','\\d1/d2\\d3/','').item,     '\\\\node\\share\\d1/d2\\d3/',
	('\\\\node\\share','\\d1/d2\\d3/','file').item, '\\\\node\\share\\d1/d2\\d3/file',
	('\\\\node\\share','\\d1/d2\\','file').item,    '\\\\node\\share\\d1/d2\\file';

for @join -> $in, $out {
	is $win32.join(|$in), $out, "join: {$in.perl} -> '$out'"
}

ok $win32.is-absolute( "/" ), 'is-absolute: ok "/"';
ok $win32.is-absolute( "\\" ), 'is-absolute: ok "\\"';
ok $win32.is-absolute( "C:\\" ), 'is-absolute: ok "C:\\"';
ok $win32.is-absolute( "C:\\foo/bar" ), 'is-absolute: ok "C:\\foo/bar"';
ok $win32.is-absolute( "\\\\server\\share" ), 'is-absolute: ok "\\\\server\\share"';

nok $win32.is-absolute( "foo/bar" ), 'is-absolute: nok "foo/bar"';
nok $win32.is-absolute( "." ), 'is-absolute: nok "."';
nok $win32.is-absolute( "C:" ), 'is-absolute: nok "C:"';
nok $win32.is-absolute( "C:dir\\file.txt" ), 'is-absolute: nok "C:dir\\file.txt"';

my @catfile = 
	('a','b','c').item,        'a\\b\\c',
	('a','b','.\\c').item,      'a\\b\\c' ,
	('.\\a','b','c').item,      'a\\b\\c' ,
	('c').item,                'c',
	('.\\c').item,              'c',
	('a/..','../b').item,       'a\\..\\..\\b',
	('A:', 'foo').item,         'A:foo';

for @catfile -> $in, $out {
	is $win32.catfile(|$in), $out, "catfile: {$in.perl} -> '$out'"
}

my @abs2rel = 
	('/t1/t2/t3','/t1/t2/t3').item,     '.',
	('/t1/t2/t4','/t1/t2/t3').item,     '..\\t4',
	('/t1/t2','/t1/t2/t3').item,        '..',
	('/t1/t2/t3/t4','/t1/t2/t3').item,  't4',
	('/t4/t5/t6','/t1/t2/t3').item,     '..\\..\\..\\t4\\t5\\t6',
	('/','/t1/t2/t3').item,             '..\\..\\..',
	('///','/t1/t2/t3').item,           '..\\..\\..',
	('/.','/t1/t2/t3').item,            '..\\..\\..',
	('/./','/t1/t2/t3').item,           '..\\..\\..',
	('\\\\a/t1/t2/t4','/t2/t3').item,   '\\\\a\\t1\\t2\\t4',
	('//a/t1/t2/t4','/t2/t3').item,     '\\\\a\\t1\\t2\\t4',
	('A:/t1/t2/t3','A:/t1/t2/t3').item,     '.',
	('A:/t1/t2/t3/t4','A:/t1/t2/t3').item,  't4',
	('A:/t1/t2/t3','A:/t1/t2/t3/t4').item,  '..',
	('A:/t1/t2/t3','B:/t1/t2/t3').item,     'A:\\t1\\t2\\t3',
	('A:/t1/t2/t3/t4','B:/t1/t2/t3').item,  'A:\\t1\\t2\\t3\\t4',
	('E:/foo/bar/baz').item,            'E:\\foo\\bar\\baz',
	('C:\\Windows\\System32', 'C:\\').item,  'Windows\System32',
	('\\\\computer2\\share3\\foo.txt', '\\\\computer2\\share3').item,  'foo.txt';
	#('C:/one/two/three').item,          'three',
	#('../t4','/t1/t2/t3').item,         '..\\..\\..\\one\\t4',  # Uses _cwd()
	#('C:\\one\\two\\t\\asd1\\', 't\\asd\\').item, '..\\asd1',
	#('\\one\\two', 'A:\\foo').item,     'C:\\one\\two';

{
    for @abs2rel -> $in, $out {
	    is $win32.abs2rel(|$in), $out, "abs2rel: {$in.perl} -> '$out'"
    }
}

my @rel2abs = 
	$('temp','C:/'),                       'C:\\temp',
	$('temp','C:/a'),                      'C:\\a\\temp',
	$('temp','C:/a/'),                     'C:\\a\\temp',
	$('../','C:/'),                        'C:\\',
	$('../','C:/a'),                       'C:\\a\\..',
	$('\\foo','C:/a'),                     'C:\\foo',
	$('temp','//prague_main/work/'),       '\\\\prague_main\\work\\temp',
	$('../temp','//prague_main/work/'),    '\\\\prague_main\\work\\temp',
	$('temp','//prague_main/work'),        '\\\\prague_main\\work\\temp',
	$('../','//prague_main/work'),         '\\\\prague_main\\work';
	#$('D:foo.txt'),                        'D:\\alpha\\beta\\foo.txt';

for @rel2abs -> $in, $out {
	is $win32.rel2abs(|$in), $out, "rel2abs: {$in.perl} -> '$out'"
}


is $win32.curdir,  '.',   'curdir is "."';
is $win32.devnull, 'nul', 'devnull is nul';
is $win32.rootdir, '\\',  'rootdir is "\\"';
is $win32.updir,   '..',  'updir is ".."';


if $*OS !~~ any(<MSWin32 NetWare symbian os2 dos>) {
	skip_rest 'Win32ish on-platform tests'
}
else {
	# double check a couple of things to see if IO::Spec loaded correctly
	is IO::Spec.devnull, 'nul', 'devnull is nul';
	is IO::Spec.rootdir, '\\',  'rootdir is "\\"';
	ok {.IO.d && .IO.w}.(IO::Spec.tmpdir), "tmpdir: {IO::Spec.tmpdir} is a writable directory";
}

done;
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/mkdir_rmdir.t����������������������������������������������������������0000664�0001750�0001750�00000003252�12224265625�017454� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 7;

# Tests for IO::Path.mkdir and IO::Path.rmdir
#
# See also S16-filehandles/mkdir_rmdir.t
# L<S32::IO/IO::Path>

#?niecza skip "mkdir rmdir NYI"
#?rakudo skip "mkdir rmdir NYI"
{
    my $d = testdir();
    $d.mkdir;
    ok $d.e, "$d exists";
    ok $d.d, "$d is a directory";

    $d.rmdir;
    ok !$d.e, "$d was removed";
}

# rmdir soft-fails when dir doesn't exist.
#?niecza skip "rmdir NYI"
#?rakudo skip "rmdir NYI"
#?DOES 1
{
    my $err = testdir().path.rmdir;
    isa_fatal_ok $err, X::IO::Rmdir;
}

# rmdir soft-fail when dir contains files.
#?niecza skip "mkdir rmdir NYI"
#?rakudo skip "mkdir rmdir NYI"
{
    my $dir = testdir();
    $dir.mkdir;
    spurt "$dir/file", "hello world";
    my $err = $dir.rmdir;
    isa_fatal_ok $err, X::IO::Rmdir;

    unlink "$dir/file";
    $dir.rmdir;
}

# mkdir in a dir that doesn't exist
#?niecza skip "mkdir NYI"
#?rakudo skip "mkdir NYI"
{
    my $dir = testdir().child(testdir());
    my $err = $dir.mkdir;
    isa_fatal_ok $err, X::IO::Mkdir;
}

# mkdir a dir that already exists
#?niecza skip "mkdir NYI"
#?rakudo skip "mkdir NYI"
{
    my $dir = testdir();
    $dir.mkdir;
    my $err = $dir.mkdir;
    isa_fatal_ok $err, X::IO::Mkdir;
}

sub testdir {
    my $testdir = "testdir-" ~ 1000000.rand.floor;
    die if $testdir.path.e;
    END try { $testdir.path.rmdir; 1; }
    $testdir.path;
}

sub isa_fatal_ok($e, $wanted) {
    $e ~~ "blow up";
    CATCH { 
        when $wanted {
            ok True, "Got expected " ~ $wanted.perl;
            return;
        }
        default { 
            ok False, "Got wrong error";
            return;
        }
    };
    ok False, "No exception, expected " ~ $wanted.perl;
}

������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/note.t�����������������������������������������������������������������0000664�0001750�0001750�00000002510�12224265625�016112� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;
plan 6;

# L<S32::IO/Functions/note>

is_run( 'note "basic form"',
        {
            status => 0,
            out    => '',
            err    => "basic form\n",
        },
        'basic form of note' );

is_run( 'note "multiple", " ", "params"',
        {
            status => 0,
            out    => '',
            err    => "multiple params\n",
        },
        'note multiple parameters' );

is_run( 'my @a = ("array", "of", "params"); note @a',
        {
            status => 0,
            out    => '',
            err    => "array of params\n",
        },
        'note array' );

is_run( 'my $a = <stringify args>; note $a',
        {
            status => 0,
            out    => '',
            err    => "stringify args\n",
        },
        'note an array reference' );

#?rakudo todo 'nom regression'
#?niecza todo 'Str.note NYI'
is_run( '"method form".note',
        {
            status => 0,
            out    => '',
            err    => "method form\n",
        },
        'method form of note' );

is_run( 'try { note "with try" }',
        {
            status => 0,
            out    => '',
            err    => "with try\n",
        },
        'try { } block does not prevent note() from outputting something' );

done;

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/other.t����������������������������������������������������������������0000664�0001750�0001750�00000000403�12224265625�016265� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
BEGIN { @*INC.push('t/spec/packages/') };
use Test::Util;
plan 60;

# RT #117841
for 1..12 -> $x {
    for map { 2**$x - 1 }, ^5 {
        ok( get_out("say 1 x $_,q|—|", '')<out> ~~ /^1+\—\s*$/, "Test for $_ bytes + utf8 char");
    }
}
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/path.t�����������������������������������������������������������������0000664�0001750�0001750�00000000501�12224265625�016077� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 4;

isa_ok qp{foo}, IO::Path, 'qp{foo} creates a IO::Path object.';
isa_ok qp{/foo}, IO::Path, 'qp{/foo} creates a IO::Path object.';
isa_ok qp{foo/bar}, IO::Path, 'qp{foo/bar} creates a IO::Path object.';
isa_ok qp{/foo/bar}, IO::Path, 'qp{/foo/bar} creates a IO::Path object.';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/pi.txt�����������������������������������������������������������������0000664�0001750�0001750�00000000013�12224265625�016125� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������1234567890
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/slurp.t����������������������������������������������������������������0000664�0001750�0001750�00000004377�12224265625�016327� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 16;

# older: L<S16/"Unfiled"/"=item IO.slurp">
# old: L<S32::IO/IO::FileNode/slurp>
# L<S32::IO/Functions/slurp>

{
  dies_ok { slurp "does-not-exist" }, "slurp() on non-existent files fails";
}

{
  dies_ok { slurp "t/" }, "slurp() on directories fails";
}

my $test-path = "tempfile-slurp-test";
my $test-contents = "0123456789\nABCDEFG\n風, 薔薇, バズ\n";
my $empty-path = "tempfile-slurp-empty";

{ # write the temp files
    my $fh = open($test-path, :w);
    $fh.print: $test-contents;
    $fh.close();
    $fh = open($empty-path, :w);
    $fh.print: "";
    $fh.close();
}

ok (my $contents = slurp($test-path)), "test file slurp with path call ok";
isa_ok $contents, Str, "slurp returns a string";
is $contents, $test-contents, "slurp with path loads entire file";
is slurp($empty-path), '', "empty files yield empty string";

{
    my $fh = open $test-path, :r;
    is $fh.slurp, $test-contents, "method form .slurp works";
    $fh.close;
}
#?niecza skip "slurp(filehandle) doesn't work"
{
    my $fh = open $test-path, :r;
    is slurp($fh), $test-contents, "function passed a filehandle works";
    $fh.close;
}

# RT #112276
# 0-argument slurp set to $*ARGFILES
{
    my $*ARGFILES = open $test-path, :r;
    is slurp(), $test-contents, "slurp with no parameters loads \$*ARGFILES";
    $*ARGFILES.close;
}

#?niecza skip ":bin option for slurp fails"
{
    my $binary-slurp;
    ok ($binary-slurp = slurp $test-path, :bin), ":bin option runs";
    ok $binary-slurp ~~ Buf, ":bin returns a Buf";
    is $binary-slurp, $test-contents.encode, "binary slurp returns correct content";
}

#?niecza skip ":enc option for slurp fails"
#?pugs skip ":enc option for slurp fails"
{
    lives_ok { slurp($test-path, :enc('utf8')) }, "slurp :enc - encoding functions";
    is slurp($test-path, :enc('utf8')), $test-contents, "utf8 looks normal";
    #mojibake time
    is slurp($test-path, enc=>'iso-8859-1'),
     "0123456789\nABCDEFG\n風, 薔薇, バズ\n", "iso-8859-1 makes mojibake correctly";
    
}


# slurp in list context

my @slurped_lines = lines(open($test-path));
is +@slurped_lines, 3, "lines() - exactly 3 lines in this file";

unlink $test-path;
unlink $empty-path;
CATCH {
    unlink $test-path;
    unlink $empty-path;
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-io/socket-test.bin��������������������������������������������������������0000664�0001750�0001750�00000010000�12224265625�017710� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ELF����������>����@�����@����������������@�8�	�@�%�"�������@�������@�@�����@�@������������������������������8������8@�����8@������������������������������������������@�������@�����\������\�������� �����������������`�����`�������������������� �����������������`�����`������������������������������T������T@�����T@�����D�������D��������������Ptd���X������X@�����X@�����d�������d��������������Qtd��������������������������������������������������Rtd���������`�����`������������������������/lib64/ld-linux-x86-64.so.2����������GNU�����������������������GNU�@{,8[4:������������!
D@���"���+���j	Cֺ|Vv1CE:8y2bKqX8j|W^*�������������������������������������������������������������������������������������������n���������������������������������������������� �������������������$��� ����������������������������������������8����������������������������������������������������������������8��� �������������������"�������������������������������������������O���������������������T��� �����������������������������������������W������������������������������������������v������������������������������������������;���������������������������������������������������������������n����������������������������������������������������������������������������������������������������������Y����`������������������`�������������v���
�@����������������`�������������[�� ��`�������������,����@������������_���
�@�������������J����@������������f���
�@@����������������`�����������������`���������������
�@�����������p����@�������������:���
�@������������D����@�������������z����@�����1p�������libparrot.so.4.10.0�__gmon_start__�_Jv_RegisterClasses�_ITM_deregisterTMCloneTable�_ITM_registerTMCloneTable�Parrot_api_run_bytecode�Parrot_api_pmc_deserialize_bytes�Parrot_api_pmc_box_string�Parrot_api_load_bytecode_bytes�Parrot_api_get_exception_backtrace�Parrot_api_string_import_ascii�Parrot_api_pmc_get_class�Parrot_api_make_interpreter�Parrot_api_string_export_ascii�Parrot_api_string_free_exported_ascii�Parrot_api_set_compiler�Parrot_api_pmc_wrap_string_array�Parrot_api_pmc_null�Parrot_api_pmc_new_from_class�Parrot_api_get_result�Parrot_api_pmc_box_integer�Parrot_api_set_runcore�Parrot_api_destroy_interpreter�Parrot_api_set_executable_name�Parrot_api_set_configuration_hash�libc.so.6�exit�calloc�__fprintf_chk�stderr�fwrite�__libc_start_main�_edata�__bss_start�_end�/home/froggs/dev/nqp/install/lib�bytecode_size�__libc_csu_fini�_IO_stdin_used�__data_start�__libc_csu_init�get_program_code�GLIBC_2.2.5�GLIBC_2.3.4����������������������������������������������������������������������������������������ui	��������ti	���������`�������������������`��������(�����������`������������������� `�������������������(`�������������������0`�������������������8`�������������������@`�������������������H`��������	�����������P`��������
�����������X`�������������������``��������
�����������h`�������������������p`�������������������x`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������`�������������������H��H��5 �% �@�% �h����% �h���% �h���% �h���% �h���% �h���% �h���% �h���p% �h���`% �h	���P% �h
���@% �h���0% �h��� %z �h
���%r �h����%j �h���%b �h���%Z �h���%R �h���%J �h���%B �h���%: �h���%2 �h���%* �h���p%" �h���`AVAUATA���UH0���SH H\$j11HH@����HH@rakudo-2013.12/t/spec/S32-io/spurt.t����������������������������������������������������������������0000664�0001750�0001750�00000007446�12224265625�016337� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
#plan 22;
#plan *;

# L<S32::IO/Functions/spurt>

my $path = "tempfile-spurt-test";

# filename as str tests
all-basic({ $path });

# filename as IO tests
all-basic({ $path.IO });


sub all-basic(Callable $handle) {
    my Blob $buf = "hello world".encode("utf-8");
    my $txt = "42";

    #?niecza 2 skip ":bin option for slurp fails"
    spurt $handle(), $buf; 
    is slurp($path, :bin), $buf, "spurting Buf ok";

    spurt $handle(), $txt;
    is slurp($path), $txt, "spurting txt ok";

    #?niecza 2 skip "Excess arguments to spurt, unused named enc"
    spurt $handle(), $txt, :enc("ASCII");
    is slurp($path), $txt, "spurt with enc";

    #?niecza 3 skip "Excess arguments to spurt, unused named append"
    spurt $handle(), $buf;
    spurt $handle(), $buf, :append;
    is slurp($path, :bin), ($buf ~ $buf), "spurting Buf with append";

    #?niecza 3 skip "Excess arguments to spurt, unused named append"
    spurt $handle(), $txt;
    spurt $handle(), $txt, :append;
    is slurp($path), ($txt ~ $txt), "spurting txt with append";
    
    unlink $path;

    #?niecza skip "Excess arguments to spurt, unused named createonly" 
    lives_ok { spurt $handle(), $buf, :createonly }, "createonly creates file with Buf";
    #?niecza todo ""
    ok $path.IO.e, "file was created";
    dies_ok { spurt $handle(), $buf, :createonly }, "createonly with Buf fails if file exists";
    unlink $path;

    #?niecza skip "Excess arguments to spurt, unused named createonly" 
    lives_ok { spurt $handle(), $txt, :createonly }, "createonly with text creates file";
    #?niecza todo ""
    ok $path.IO.e, "file was created";
    dies_ok { spurt $handle(), $txt, :createonly }, "createonly with text fails if file exists";
    unlink $path;
}

# Corner cases
#?niecza skip "Unable to resolve method open in type IO"
{
    # Spurt on open handle
    {
        my $io = $path.IO.open(:w);
        spurt $io, "42";
        is slurp($path), "42"; # Can spurt into an open handle.
    }

    # Buf into an open non binary handle
    {
        my $io = $path.IO.open(:w);
        my Buf $buf = Buf.new(0xC0, 0x01, 0xF0, 0x0D);
        spurt $io, $buf;
        is slurp($path, :bin), $buf;
    }

    # Text into a open binary handle
    {
        my $io = $path.IO.open(:bin, :w);
        my Str $txt = "Bli itj nå trønder-rock uten tennis-sokk";
        spurt $io, $txt;
        is slurp($path), $txt;
    }

    unlink $path;
}


# IO::Handle spurt
{
    $path.IO.spurt("42");
    is slurp($path), "42", "IO::Handle slurp";

    my Blob $buf = "meow".encode("ASCII");
    $path.IO.spurt($buf);
    #?niecza skip "Excess arguments to slurp, unused named bin"
    is slurp($path, :bin), $buf, "IO::Handle binary slurp";
    
    dies_ok { $path.IO.spurt("nope", :createonly) }, "IO::Handle :createonly dies";
    unlink $path;
    #?niecza 2 todo "Excess arguments to IO.spurt, unused named createonly"
    lives_ok { $path.IO.spurt("yes", :createonly) }, "IO::Handle :createonly lives";
    ok $path.IO.e, "IO::Handle :createonly created a file";
    
    # Append
    {
        #?niecza 4 skip "Excess arguments to IO.spurt, unused named append"
        my $io = $path.IO;
        $io.spurt("hello ");
        $io.spurt("world", :append);
        is slurp($path), "hello world", "IO::Handle spurt :append";
    }

    # Not append!
    {
        my $io = $path.IO;
        $io.spurt("hello ");
        $io.spurt("world");
        is slurp($path), "world", "IO::Handle not :append";
    }

    # encoding
    {
        #?niecza 3 skip "Excess arguments to IO.spurt, unused named enc"
        my $t = "Bli itj nå fin uten mokkasin";
        $path.IO.spurt($t, :enc("utf8"));
        is slurp($path), $t, "IO::Handle :enc";
    }
    unlink $path;
}

done;

CATCH {
    unlink $path;
}

if $path.IO.e {
    say "Warn: '$path shouldn't exist";
    unlink $path;
}
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/categorize.t���������������������������������������������������������0000664�0001750�0001750�00000005511�12224265625�017651� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"List"/"=item categorize">

plan 12;

{ # basic categorize with all possible mappers
    my @list      = 29, 7, 12, 9, 18, 23, 3, 7;
    my %expected1 =
      ('0'=>[7,9,3,7],         '10'=>[12,18],       '20'=>[29,23]);
    my %expected2 =
      ('0'=>[7,9,3,7,7,9,3,7], '10'=>[12,18,12,18], '20'=>[29,23,29,23]);
    my sub subber ($a) { $a - ($a % 10) };
    my $blocker = { $_ - ($_ % 10) };
    my $hasher  = { 3=>0, 7=>0, 9=>0, 12=>10, 18=>10, 23=>20, 29=>20 };
    my $arrayer = [ 0 xx 10, 10 xx 10, 20 xx 10 ];

    for &subber, $blocker, $hasher, $arrayer -> $mapper {
        is_deeply categorize( $mapper, @list ), %expected1,
          "simple sub call with {$mapper.^name}";
        is_deeply @list.categorize( $mapper ), %expected1,
          "method call on list with {$mapper.^name}";
    }
} #4*2

{ # basic categorize
    my %got = categorize { .comb }, <A♣ 10♣ 6♥ 3♦ A♠ 3♣ K♠ J♥ 6♦ Q♠ K♥ 8♦ 5♠>;
    my %expected = (
      'A' => ['A♣', 'A♠'],
      '♣' => ['A♣', '10♣', '3♣'],
      '1' => ['10♣'],
      '0' => ['10♣'],
      '6' => ['6♥', '6♦'],
      '♥' => ['6♥', 'J♥', 'K♥'],
      '3' => ['3♦', '3♣'],
      '♦' => ['3♦', '6♦', '8♦'],
      '♠' => ['A♠', 'K♠', 'Q♠', '5♠'],
      'K' => ['K♠', 'K♥'],
      'J' => ['J♥'],
      'Q' => ['Q♠'],
      '8' => ['8♦'],
      '5' => ['5♠'],
    );
    is_deeply(%got, %expected, 'sub with named sub mapper');
} #1

{
    # Method form, code block mapper
    my %got = (1...6).categorize: {
        my @categories = ( $_ % 2 ?? 'odd' !! 'even');
        unless $_ % 3 { push @categories, 'triple'}
        @categories;
    };
    my %expected = ('odd'=>[1,3,5], 'even'=>[2,4,6], 'triple'=>[3,6]);
    is_deeply(%got, %expected, 'method with code block mapper');
} #1

{
    # Method form, named sub mapper
    sub charmapper($c) {
        my @categories;
        push @categories, 'perlish' if $c.lc ~~ /<[perl]>/;
        push @categories, 'vowel'   if $c.lc eq any <a e i o u>;
        push @categories, ($c ~~ .uc) ?? 'uppercase' !! 'lowercase';
        @categories;
    }
    my %got      = 'Padre'.comb.categorize(&charmapper);
    my %expected = ( 'perlish'   => ['P', 'r', 'e'],
                     'vowel'     => ['a', 'e'],
                     'uppercase' => ['P'],
                     'lowercase' => ['a', 'd', 'r', 'e'] );
    is_deeply(%got, %expected, 'method with named sub mapper');
}

#?pugs   todo 'feature'
#?niecza todo 'feature'
{
    is_deeply( categorize( { map { [$_, $_+10] }, .comb }, 100,104,112,119 ),
      ("1" => { "11" => [100, 104, 112, 112, 119, 119] },
       "0" => { "10" => [100, 100, 104] },
       "4" => { "14" => [104] },
       "2" => { "12" => [112] },
       "9" => { "19" => [119] },
      ).hash, 'multi-level categorize' );
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/classify.t�����������������������������������������������������������0000664�0001750�0001750�00000004412�12224265625�017331� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"List"/"=item classify">

plan 15;

{
    my @list = 1, 2, 3, 4;
    my $classified1 = { even => [2,4],     odd => [1,3]     };
    my $classified2 = { even => [2,4,2,4], odd => [1,3,1,3] };
    my sub subber ($a) { $a % 2 ?? 'odd' !! 'even' };
    my $blocker = { $_ % 2 ?? 'odd' !! 'even' };
    my $hasher  = { 1 => 'odd', 2 => 'even', 3 => 'odd', 4 => 'even' };
    my $arrayer = <huh odd even odd even>.list;

    for &subber, $blocker, $hasher, $arrayer -> $classifier {
        is_deeply @list.classify( $classifier ), $classified1,
          "basic classify from list with {$classifier.^name}";
        is_deeply classify( $classifier, @list ), $classified1,
          "basic classify as subroutine with {$classifier.^name}";
    }
} #4*2

#?pugs todo 'feature'
#?rakudo skip 'Cannot use bind operator with this LHS'
#?niecza skip 'Cannot use bind operator with this LHS'
{ 
    my @list = (1, 2, 3, 4);
    my (@even,@odd);
    lives_ok { (:@even, :@odd) := classify { $_ % 2 ?? 'odd' !! 'even' }, 1,2,3,4}, 'Can bind result list of classify';
    is_deeply(@even, [2,4], "got expected evens");
    is_deeply(@odd,  [1,3], "got expected odds");
} #3

#?pugs todo 'feature'
{
    my %by_five;
    is_deeply
      classify( { $_ * 5 }, 1, 2, 3, 4 ),
      { 5 => [1], 10 => [2], 15 => [3], 20 => [4] },
      'can classify by numbers';
} #1

# .classify should work on non-arrays
{
    is_deeply 42.classify(  {$_} ), { 42 => [42] }, "classify single num";
    is_deeply "A".classify( {$_} ), { A => ["A"] }, "classify single string";
} #2

#?pugs   todo 'feature'
#?niecza todo 'feature'
{
    is_deeply( classify( {.comb}, 100 .. 119, 104, 119 ),
      ("1" => {
        "0" => {
          "0" => [100],
          "1" => [101],
          "2" => [102],
          "3" => [103],
          "4" => [104,104],
          "5" => [105],
          "6" => [106],
          "7" => [107],
          "8" => [108],
          "9" => [109],
        },
        "1" => {
          "0" => [110],
          "1" => [111],
          "2" => [112],
          "3" => [113],
          "4" => [114],
          "5" => [115],
          "6" => [116],
          "7" => [117],
          "8" => [118],
          "9" => [119,119],
        }
      }).hash, 'multi-level classify' );
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/combinations.t�������������������������������������������������������0000664�0001750�0001750�00000001373�12241704255�020200� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test;

plan 6;

sub canon($t) {
    $t.tree.map(*.sort).tree
}

# L<S32::Containers/List/=item combinations>

ok(((1,), (2,), (3,)).list     eqv     [1, 2, 3].combinations(1).&canon, "single-item combinations");
ok(all([1, 2], [2, 3], [1, 3]) eqv one([1, 2, 3].combinations(2).&canon), "two item combinations");
ok(([1, 2, 3],).list           eqv     [1, 2, 3].combinations(3).&canon, "three items of a three-item list");

ok(all(1, 2, 3, [1, 2], [2, 3], [1, 3])            eqv one([1, 2, 3].combinations(1..2).&canon), "1..2 items");
ok(all(1, 2, 3, [1, 2], [2, 3], [1, 3], [1, 2, 3]) eqv one([1, 2, 3].combinations(1..3).&canon), "1..3 items");
ok(all([1, 2], [2, 3], [1, 3], [1, 2, 3])          eqv one([1, 2, 3].combinations(2..3).&canon), "2..3 items");
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/create.t�������������������������������������������������������������0000664�0001750�0001750�00000001362�12224265625�016760� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"List"/"=item ">

=begin pod

built-in "list" tests

=end pod

plan 6;

my $list_sub = list(1, 2, 3);
isa_ok($list_sub, List, '&list() creates a list assignable to a scalar.');
is($list_sub, (1, 2, 3), 'The &list() function created a list.');
is(+$list_sub, 3, 'Finding the length of the list works as expected.');

#?niecza skip 'Excess arguments to List.new, used 1 of 4 positionals'
#?pugs skip 'Must only use named arguments to new() constructor'
{
my $list_obj = List.new(4, 5, 6);
isa_ok($list_obj, List, 'Creating a new list object with new works.');
is($list_obj, list(4, 5, 6), 'The list object contains the right values.');
is(+$list_obj, 3, 'Finding the length functions properly.');
}

# vim: ft=perl6

������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/end.t����������������������������������������������������������������0000664�0001750�0001750�00000002654�12224265625�016270� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::Containers/Array/=item end>

=begin docs

Array .end tests
=end docs

plan 14;

# basic array .end tests

{ # invocant style
    my @array;
    is(@array.end, -1, 'we have an empty array');

    @array = 1...43;
    is(@array.end, 42, 'index of last element is 42 after assignment');

    @array.pop;
    is(@array.end, 41, 'index of last element is 41 after pop');

    @array.shift;
    is(@array.end, 40, 'index of last element is 40 after shift');

    @array.unshift('foo');
    is(@array.end, 41, 'index of last element is 41 after unshift');

    @array.push('bar');
    is(@array.end, 42, 'index of last element is 42 after push');
}

{ # non-invocant style
    my @array;
    is(end(@array), -1, 'we have an empty array');

    @array = (1...43);
    is(end(@array), 42, 'index of last element is 42 after assignment');

    @array.pop;
    is((end @array), 41, 'index of last element is 41 after pop');

    shift @array;
    is((end @array), 40, 'index of last element is 40 after shift');

    unshift @array, 'foo';
    is(end(@array), 41, 'index of last element is 41 after unshift');

    push @array, 'bar';
    is(end(@array), 42, 'index of last element is 42 after push');
}

#?niecza skip 'Unable to resolve method end in class Int'
is  3.end, 0,  'Scalars look like wrapped in a single-item list';

# test some errors
{
    eval_dies_ok ' end() ', '... end() dies without an argument';
}
#vim: ft=perl6
������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/first.t��������������������������������������������������������������0000664�0001750�0001750�00000004637�12224265625�016654� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"List"/"=item first">

plan 23;

my @list = (1 ... 10);

{
    my $result = first { ($^a % 2) }, |@list;
    ok($result ~~ Int, "first() returns an Int");
    is($result, 1, "returned value by first() is correct");
}

{
    my $result = first { ($^a % 2) }, 1, 2, 3, 4, 5, 6, 7, 8;
    ok($result ~~ Int, "first() returns an Int");
    is($result, 1, "returned value by first() is correct");
}


{
    my $result = @list.first( { ($^a == 4)});
    ok($result ~~ Int, "method form of first returns an Int");
    is($result, 4, "method form of first returns the expected item");
}

#?rakudo skip "adverbial block"
#?niecza skip 'No value for parameter Mu $filter in CORE Any.first'
{
    my $result = @list.first():{ ($^a == 4) };
    ok($result ~~ Int, "first():<block> returns an Int");
    is($result, 4, "first() returned the expected value");
}

{
    nok(@list.first( { ($^a == 11) }).defined, 'first returns undefined unsuccessful match');
}

{
    my $count = 0;
    my $matcher = sub (Int $x) { $count++; $x % 2 };
    is(@list.first($matcher), 1, 'first() search for odd elements successful');
    is($count, 1, 'Matching closure in first() is only executed once');
}

{
    is(@list.first(4..6), 4, "method form of first with range returns the expected item");
    is(@list.first(4^..6), 5, "method form of first with range returns the expected item");
}

{
    my @fancy_list = (1, 2, "Hello", 3/4, 4.Num);
    is(@fancy_list.first(Str), "Hello", "Looking up first by type Str works");
    is(@fancy_list.first(Int), 1, "Looking up first by type Int works");
    is(@fancy_list.first(Rat), 3/4, "Looking up first by type Rat works");
}

{
    my @fancy_list = <Philosopher Goblet Prince>;
    is(@fancy_list.first(/o/), "Philosopher", "Looking up first by regex /o/");
    is(@fancy_list.first(/ob/), "Goblet", "Looking up first by regex /ob/");
    is(@fancy_list.first(/l.*o/), "Philosopher", "Looking up first by regex /l.*o/");
}

{
    is <a b c b a>.first('c' | 'b').join('|'),
        'b', '.first also takes a junction as matcher';

    is (first 'c'| 'b', <a b c b a>).join('|'),
        'b', '.first also takes a junction as matcher (sub form)';
}

# RT #118141
#?niecza skip 'https://github.com/sorear/niecza/issues/183'
{
    isa_ok (first * > 20, @list), Nil, "first() returns Nil when no values match";
    isa_ok @list.first(* < 0 ), Nil, ".first returns Nil when no values match"
}

#vim: ft=perl6
�������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/grep.t���������������������������������������������������������������0000664�0001750�0001750�00000010076�12224265625�016454� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/"List"/"=item grep">

=begin pod

built-in grep tests

=end pod

plan 38;

my @list = (1 .. 10);

{
    my @result = grep { ($_ % 2) }, @list;
    is(+@result, 5, 'we got a list back');
    is(@result[0], 1, 'got the value we expected');
    is(@result[1], 3, 'got the value we expected');
    is(@result[2], 5, 'got the value we expected');
    is(@result[3], 7, 'got the value we expected');
    is(@result[4], 9, 'got the value we expected');
}

#?rakudo skip "adverbial block"
#?niecza skip 'No value for parameter Mu $sm in Any.grep'
{
    my @result = @list.grep():{ ($_ % 2) };
    is(+@result, 5, 'we got a list back');
    is(@result[0], 1, 'got the value we expected');
    is(@result[1], 3, 'got the value we expected');
    is(@result[2], 5, 'got the value we expected');
    is(@result[3], 7, 'got the value we expected');
    is(@result[4], 9, 'got the value we expected');
}

#?rakudo skip "adverbial block"
#?pugs   skip "adverbial block"
#?niecza skip 'No value for parameter Mu $sm in Any.grep'
{
    my @result = @list.grep :{ ($_ % 2) };
    is(+@result, 5, 'we got a list back');
    is(@result[0], 1, 'got the value we expected');
    is(@result[1], 3, 'got the value we expected');
    is(@result[2], 5, 'got the value we expected');
    is(@result[3], 7, 'got the value we expected');
    is(@result[4], 9, 'got the value we expected');
}

#?rakudo skip "closure as non-final argument"
#?niecza skip 'Invocant handling is NYI'
{
    my @result = grep { ($_ % 2) }: @list;
    is(+@result, 5, 'we got a list back');
    is(@result[0], 1, 'got the value we expected');
    is(@result[1], 3, 'got the value we expected');
    is(@result[2], 5, 'got the value we expected');
    is(@result[3], 7, 'got the value we expected');
    is(@result[4], 9, 'got the value we expected');
}

{
  is(42.grep({ 1 }), "42",     "method form of grep works on numbers");
  is('str'.grep({ 1 }), 'str', "method form of grep works on strings");
}

#
# Grep with mutating block
#
# L<S02/Names/"$_, $!, and $/ are context<rw> by default">
#?pugs skip "Can't modify constant item: VStr 'a'"
{
  my @array = <a b c d>;
  #?rakudo 2 skip 'test error -- is $_ rw here?'
  is ~(@array.grep({ $_ ~= "c"; 1 })), "ac bc cc dc",
    'mutating $_ in grep works (1)';
  is ~@array, "ac bc cc dc",
    'mutating $_ in grep works (2)';
}

# grep with last, next etc.
#?pugs skip "last/next in grep"
{
    is (1..16).grep({last if $_ % 5 == 0; $_ % 2 == 0}).join('|'),
       '2|4', 'last works in grep';
    is (1..12).grep({next if $_ % 5 == 0; $_ % 2 == 0}).join('|'),
       '2|4|6|8|12', 'next works in grep';
}

# since the test argument to .grep is a Matcher, we can also
# check type constraints:
#?pugs skip "Int"
{
    is (2, [], 4, [], 5).grep(Int).join(','),
       '2,4,5', ".grep with non-Code matcher";

    is grep(Int, 2, [], 4, [], 5).join(','),
       '2,4,5', "grep() with non-Code matcher";
}

# RT 71544
#?niecza skip 'No value for parameter $b in ANON'
{
    my @in = ( 1, 1, 2, 3, 4, 4 );

# This test passes, but it's disabled because it doesn't belong here.
# It just kind of clarifies the test that follows.
#    is (map { $^a == $^b }, @in), (?1, ?0, ?1), 'map takes two at a time';

    #?rakudo skip 'RT 71544: grep arity sensitivity different from map'
    #?pugs todo
    is (grep { $^a == $^b }, @in), (1, 1, 4, 4), 'grep takes two at a time';
}

#?pugs skip 'Cannot cast from VList to VCode'
{
    my @a = <a b c>;
    my @b = <b c d>;
    is @a.grep(any(@b)).join('|'), 'b|c', 'Junction matcher';

}

# sensible boolification
# RT #74056
# since rakudo returns an iterator (and not a list) and some internals leaked,
# a zero item list/iterator would return True, which is obviously wrong
#?pugs skip 'Cannot cast from VList to VCode'
{
    ok <0 1 2>.grep(1), 'Non-empty return value from grep is true (1)';
    ok <0 1 2>.grep(0), 'Non-empty return value from grep is true (2)';
    nok <0 1 2>.grep(3), 'Empty return value from grep is false';
}

# chained greps
#?pugs skip "..."
{
    is ~(1...100).grep(* %% 2).grep(* %% 3), ~(6, 12 ... 96), "chained greps work";
}

done;

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/join.t���������������������������������������������������������������0000664�0001750�0001750�00000011474�12224265625�016461� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 34;

# L<S32::Containers/"List"/"=item join">

# test all variants of join()

#?pugs skip 'empty join NYI'
is join(),  '', 'empty join is empty string (sub)';
is ().join, '', 'empty join is empty string (method)';

is(["a", "b", "c"].join("|"), "a|b|c", '[].join("|") works');

my @list = ("a", "b", "c");

is(@list.join("|"), "a|b|c", '@list.join("|") works');

my $joined2 = join("|", @list);
#?pugs todo
is($joined2, "a|b|c", 'join("|", @list) works');

my $joined3 = join("|", "a", "b", "c");
#?pugs todo
is($joined3, "a|b|c", 'join("|", 1, 2, 3) works');

my $joined4 = join("|", [ "a", "b", "c" ]);
#?pugs todo
is($joined4, "a b c", 'join("|", []) should not join anything');

# join() without a separator (defaults to '', per S32)
is(<a b c>.join, 'abc', 'join() separator defaults to "".');

# join() with $sep as a variable

my $sep = ", ";

is(["a", "b", "c"].join($sep), "a, b, c", '[].join($sep) works');

is(@list.join($sep), "a, b, c", '@list.join($sep) works');

my $joined2a = join($sep, @list);
#?pugs todo
is($joined2a, "a, b, c", 'join($sep, @list) works');

my $joined3a = join($sep, "a", "b", "c");
#?pugs todo
is($joined3a, "a, b, c", 'join($sep, "a", "b", "c") works');

my $joined4a = join($sep, [ "a", "b", "c" ]);
#?pugs todo
is($joined4a, "a b c", 'join($sep, []) works');

# join ... without parens

my $joined2b = join $sep, @list;
#?pugs todo
is($joined2b, "a, b, c", 'join $sep, @list works');

my $joined2c = join ":", @list;
#?pugs todo
is($joined2c, "a:b:c", 'join ":", @list works');

my $joined3b = join $sep, "a", "b", "c";
#?pugs todo
is($joined3b, "a, b, c", 'join $sep, "a", "b", "c" works');

my $joined3c = join ":", "a", "b", "c";
#?pugs todo
is($joined3c, "a:b:c", 'join(":", "a", "b", "c") works');

my $joined4b = join $sep, [ "a", "b", "c" ];
#?pugs todo
is($joined4b, "a b c", 'join $sep, [] should not join anything');

my $joined4c = join ":", [ "a", "b", "c" ];
#?pugs todo
is($joined4c, "a b c", 'join ":", [] should not join anything');

# join() with empty string as separator

is(["a", "b", "c"].join(''), "abc", '[].join("") works');

@list = ("a", "b", "c");

is(@list.join(''), "abc", '@list.join("") works');

my $joined2d = join('', @list);
#?pugs todo
is($joined2d, "abc", 'join("", @list) works');

my $joined3d = join('', "a", "b", "c");
#?pugs todo
is($joined3d, "abc", 'join("", 1, 2, 3) works');

my $joined4d = join("", [ "a", "b", "c" ]);
#?pugs todo
is($joined4d, "a b c", 'join("", []) works');

# some odd edge cases

my $undefined;
my @odd_list1 = (1, $undefined, 2, $undefined, 3);

my $joined2e = join(':', @odd_list1);
#?pugs todo
is($joined2e, "1::2::3", 'join(":", @odd_list1) works');

my @odd_list2 = (1, Mu, 2, Mu, 3);

my $joined2f = join(':', @odd_list2);
#?pugs todo
is($joined2f, "1::2::3", 'join(":", @odd_list2) works');

# should these even be tests ???

my $joined1d = ("a", "b", "c").join('');
is($joined1d, "abc", '().join("") should dwim');

my $joined1 = ("a", "b", "c").join("|");
is($joined1, "a|b|c", '().join("|") should dwim');

my $joined1a = ("a", "b", "c").join($sep);
is($joined1a, "a, b, c", '().join($sep) should dwim');

#?pugs todo
is(join("!", "hi"),   "hi", "&join works with one-element lists (1)");
#?pugs todo
is(join("!", <hi>),   "hi", "&join works with one-element lists (2)");
is(("hi",).join("!"), "hi", "&join works with one-element lists (3)");


# Similar as with .kv: (42).kv should die, but (42,).kv should work.

   ## <pmichaud>:  I think the following two tests are likely incorrect.
   ##   Prior to r20722 S32::Containers gave the following definitions for C<join>:
   ##     our Str multi method join ( $separator: @values )
   ##     our Str multi join ( Str $separator = ' ', *@values )
   ##   Neither of these allows C< @list.join('sep') > to work.
   ##   In r20722 I changed S32::Containers to read
   ##     our Str multi method join ( @values: $separator = ' ' )
   ##     our Str multi join ( Str $separator = ' ', *@values )
   ##   This enables C< @list.join('sep') > to work, but now
   ##   C< 'foo'.join(':') > through method fallback is equivalent
   ##   to C< join('foo', ':') >, which results in ':' and not 'foo'.
   ##   Same is true for C< ('foo').join(':') >.
#
## from http://www.nntp.perl.org/group/perl.perl6.language/2008/06/msg29283.html
#
# Larry Wall writes:
#
## On Sat, Jun 14, 2008 at 01:46:10PM +0200, Moritz Lenz wrote:
## : Fallback semantics in S12 suggest that since no matching multi method is
## : found, subs are tried - that is, the expression is interpreted as
## :    join('str', 'other_str')
## : yielding 'other_str'. t/spec/S32::Containers-list/join.t disagrees, and wants the
## : result to be 'str'.
##
## I want the result to be 'str'.

is('hi'.join(':'), 'hi', '"foo".join(":") should be the same as join(":", "foo")');
is(('hi').join(':'), 'hi', '("foo").join(":") should be the same as join(":", "foo")');

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/map_function_return_values.t�����������������������������������������0000664�0001750�0001750�00000000646�12224265625�023161� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 2;

# L<S32::Containers/"List"/"=item map">

my $text  = "abc";
my %ret;

# XXX depends on the Pair stringification which is likely going to change

{
    %ret = map { $_ => uc $_; }, $text.comb;
    is ~%ret.sort, "a\tA b\tB c\tC", "=> works in a map block";
}

%ret = map { $_, uc $_ }, $text.comb;
is ~%ret.sort, "a\tA b\tB c\tC", "map called with function return values works";

# vim: ft=perl6
������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/map.t����������������������������������������������������������������0000664�0001750�0001750�00000015321�12224265625�016272� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 53;

# L<S32::Containers/"List"/"=item map">

=begin pod

 built-in map tests

=end pod


my @list = (1 .. 5);

{
    my @result = map { $_ * 2 }, @list;
    is(+@result, 5, 'sub form: we got a list back');
    is @result.join(', '), '2, 4, 6, 8, 10', 'got the values we expected';
}

#?rakudo skip "adverbial block"
#?niecza skip 'No value for parameter $func in Any.map'
{
    my @result = @list.map():{ $_ * 2 };
    is(+@result, 5, 'adverbial block: we got a list back');
    is @result.join(', '), '2, 4, 6, 8, 10', 'got the values we expected';
}

{
    my @result = @list.map: { $_ * 2 };
    is(+@result, 5, 'invcant colon method form: we got a list back');
    is @result.join(', '), '2, 4, 6, 8, 10', 'got the values we expected';
}

#?rakudo skip "closure as non-final argument"
#?niecza skip "Invocant handling is NYI"
{
    my @result = map { $_ * 2 }: @list;
    is(+@result, 5, 'we got a list back');
    is @result.join(', '), '2, 4, 6, 8, 10', 'got the values we expected';
}

# Testing map that returns an array
{
    my @result = map { ($_, $_ * 2) }, @list;
    is(+@result, 10, 'Parcel returned from closure: we got a list back');
    is @result.join(', '),
        '1, 2, 2, 4, 3, 6, 4, 8, 5, 10',
        'got the values we expected';
}

# Testing multiple statements in the closure
{
    my @result = map {
         my $fullpath = "fish/$_";
         $fullpath;
    }, @list;
    is(+@result, 5, 'multiple statements in block: we got a list back');
    is @result.join('|'), 'fish/1|fish/2|fish/3|fish/4|fish/5',
        'got the values we expect';
}

{
    my @list = 1 .. 5;
    is +(map {;$_ => 1 }, @list), 5,
            'heuristic for block - looks like a closure';

    my %result = map {; $_ => ($_*2) }, @list;
    isa_ok(%result, Hash);
    is %result<1 2 3 4 5>.join(', '), '2, 4, 6, 8, 10',
        ' got the hash we expect';
}

# map with n-ary functions
#?rakudo skip "adverbial block; RT #53804"
{
  is ~(1,2,3,4).map({ $^a + $^b             }), "3 7", "map() works with 2-ary functions";
  #?niecza skip 'No value for parameter $b in ANON'
  is ~(1,2,3,4).map({ $^a + $^b + $^c       }), "6 4", "map() works with 3-ary functions";
  is ~(1,2,3,4).map({ $^a + $^b + $^c + $^d }), "10",  "map() works with 4-ary functions";
  #?niecza skip 'No value for parameter $e in ANON'
  is ~(1,2,3,4).map({ $^a+$^b+$^c+$^d+$^e   }), "10",  "map() works with 5-ary functions";
}

{
  is(42.map({$_}),    42,       "method form of map works on numbers");
  is('str'.map({$_}), 'str',    "method form of map works on strings");
}

=begin pod

Test that a constant list can have C<map> applied to it.

  ("foo","bar").map: { $_.substr(1,1) }

should be equivalent to

  my @val = ("foo","bar");
  @val = map { substr($_,1,1) }, @val;

=end pod

{
  my @expected = ("foo","bar");
  @expected = map { substr($_,1,1) }, @expected;

  is((("foo","bar").map: { $_.substr(1,1) }), @expected, "map of constant list works");
}


{
  my @a = (1, 2, 3);
  my @b = map { hash("v"=>$_, "d" => $_*2) }, @a;
  is(+@b, 6, "should be 6 elements (list context)");

  my @c = map { {"v"=>$_, "d" => $_*2} }, @a;
  #?niecza todo
  is(+@c, 6, "should be 6 elements (bare block)");
}

# Map with mutating block
# L<S02/Names/"$_, $!, and $/ are context<rw> by default">

#?pugs todo
{
  my @array = <a b c d>;
  is ~(try { @array.map: { $_ ~= "c"; $_ ~ "d" } }), "acd bcd ccd dcd",
    'mutating $_ in map works (1)';
  is ~@array, "ac bc cc dc",
    'mutating $_ in map works (2)';
}

sub dbl ( Int  $val ) { 2*$val };
is( ~((1..3).map: { 2*$_ }),'2 4 6','intern method in map');
is( ~((1..3).map: { dbl( $_ ) }),'2 4 6','extern method in map');


# map with empty lists in the block
# Test was primarily aimed at PIL2JS, which did not pass this test (fixed now).
{
  my @array  = <a b c d>;
  my @result = map { (), }, @array;

  is +@result, 0, "map works with the map body returning an empty list";
}

{
  my @array  = <a b c d>;
  my @empty  = ();
  my @result = map { @empty }, @array;

  is +@result, 0, "map works with the map body returning an empty array";
}

{
  my @array  = <a b c d>;
  my @result = map { [] }, @array;

  is +@result, 4, "map works with the map body returning an empty arrayref";
}

#?pugs todo
{
  my @array  = <a b c d>;
  my $empty  = [];
  my @result = map { $empty }, @array;

  is +@result, 4, "map works with the map body returning an empty arrayref variable";
}

{
  my @array  = <a b c d>;
  my @result = map { Mu }, @array;

  is +@result, 4, "map works with the map body returning undefined";
}

{
  my @array  = <a b c d>;
  my $undef  = Mu;
  my @result = map { $undef }, @array;

  is +@result, 4, "map works with the map body returning an undefined variable";
}

{
  my @array  = <a b c d>;
  my @result = map { () }, @array;

  is +@result, 0, "map works with the map body returning ()";
}

# test map with a block that takes more than one parameter
{
    my @a=(1,4,2,5,3,6);
    my @ret=map -> $a,$b {$a+$b}, @a;

    is(@ret.elems,3,'map took 2 elements at a time');
    is(@ret[0],5,'first element ok');
    is(@ret[1],7,'second element ok');
    is(@ret[2],9,'third element ok');

}

# map shouldn't flatten array objects
# used to be a pugs regression
{
    my @foo = [1, 2, 3].map: { [100+$_, 200+$_] };
    is +@foo,    3,         "map should't flatten our arrayref (1)";
    is +@foo[0], 2,         "map should't flatten our arrayref (2)";
    is ~@foo[0], "101 201", "map should't flatten our arrayref (3)";
}

# .thing inside map blocks should still default to $_
# used to be a pugs regression
#?DOES 6
{
    is ~((1,2,3).map: { $_.Int }), "1 2 3", "dependency for following test (1)";
    $_ = 4; is .Int, 4,                   "dependency for following test (2)";
    is ~((1,2,3).map: { .Int }),    "1 2 3", 'int() should default to $_ inside map, too';

    is ~(({1},{2},{3}).map: { $_; $_() }), "1 2 3", 'lone $_ in map should work (1)';
    is ~(({1},{2},{3}).map: { $_() }),     "1 2 3", 'lone $_ in map should work (2)';
    is ~(({1},{2},{3}).map: { .() }),     "1 2 3", 'lone .() in map should work (2)';
}

#?pugs skip "Cannot use this control structure outside a 'loop' structure"
#?DOES 2
{
    is (1..4).map({ next if $_ % 2; 2 * $_ }).join('|'), 
       '4|8', 'next in map works';
    is (1..10).map({ last if $_ % 5 == 0; 2 * $_}).join(' '),
       '2 4 6 8', 'last in map works';
}

# RT #62332
#?pugs skip 'No such method in class Str: "&key"'
#?DOES 2
{
    my $x = :a<5>;
    is $x.map({ .key, .value + 1}), ('a', 6), 'map on pair works (comma)';
    is $x.map({ ; .key => .value + 1}), ('a' => 6), 'map on pair works (=>)';
}

# RT #112596
#?pugs skip 'hangs'
#?niecza todo "https://github.com/sorear/niecza/issues/182"
#?DOES 1
{
    my @a = map &sprintf.assuming("%x"), 9..12;
    is(@a, <9 a b c>, "map over a callable with a slurpy");
}
# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/minmax.t�������������������������������������������������������������0000775�0001750�0001750�00000014107�12224265625�017012� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 55;

# L<S32::Containers/List/=item min>
# L<S32::Containers/List/=item max>

=begin description

As per S32, the sub form requires a comparison function. The form without
comparison function is spelled [min]

=end description

my @array = (5,-3,7,0,1,-9); #NOTICE! The <> don't work like they should, rakudo devels! That's why we use this :/ --lue

# Tests for C<min>:
is @array.min,  -9, "basic method form of min works";
is min(@array), -9, 'min(list)'; 

is (@array.min: { $^a <=> $^b }), -9,
  "method form of min with identity comparison block works";

is (@array.min:{ $^a <=> $^b }), -9,
  "adverbial block form of min with identity comparison block works (RT #53804)";

is min(:by({ $^a <=> $^b }), @array), -9,
  "subroutine form of min with identity comparison block works";

is (@array.min: { abs($^a) <=> abs($^b) }), 0,
  "method form of min taking a comparison block works";
is min(:by({ abs($^a) <=> abs($^b) }), @array), 0,
  "subroutine form of min taking a comparison block works";

is (@array.min: { abs $^a }), 0,
  "method form of min taking a comparison block works";
is min(:by({ $^a.abs }), @array), 0,
  "subroutine form of min taking a comparison block works";

# Tests for C<max>:
is (@array.max),  7, "basic method form of max works";
is max(:by({ $^a <=> $^b }), @array), 7, "basic subroutine form of max works";

is (@array.max: { $^a <=> $^b }), 7,
  "method form of max with identity comparison block works";

is max(@array), 7, 'sub form of max';

is max(:by({ $^a <=> $^b }), @array), 7,
  "subroutine form of max with identity comparison block works";

is (@array.max: { $^a.abs <=> $^b.abs }), -9,
  "method form of max taking a comparison block works";
is max(:by({ $^a.abs <=> $^b.abs }), @array), -9,
  "subroutine form of max taking a comparison block works";
is (@array.max: { $^a.abs }), -9,
  "method form of max taking a modifier block works";
is max(:by({ $^a.abs }), @array), -9,
  "subroutine form of max taking a modifier block works";

# Tests for C<minmax>:
is @array.minmax,  -9..7, "basic method form of minmax works";
is minmax(@array), -9..7,  'minmax(list)';

is (@array.minmax: { $^a <=> $^b }), -9..7,
  "method form of minmax with identity comparison block works";

is minmax(:by({ $^a <=> $^b }), @array), -9..7,
  "subroutine form of minmax with identity comparison block works";

is (@array.minmax: { $^a.abs <=> $^b.abs }), 0..-9,
  "method form of minmax taking a comparison block works";
is minmax(:by({ $^a.abs  <=> $^b.abs }), @array), 0..-9,
  "subroutine form of minmax taking a comparison block works";
is (@array.minmax: { abs $^a }), 0..-9,
  "method form of minmax taking a comparison block works";
is minmax(:by({ $^a.abs }), @array), 0..-9,
  "subroutine form of minmax taking a comparison block works";

is ((-10..9).minmax: { $^a.abs <=> $^b.abs }), 0..-10,
  "method form of minmax on Ranges taking a comparison block works";

is ((1..10).minmax: { ($_-3) * ($_-5) }), 4..10,
  "method form of minmax taking an arity-1 comparison block works";

# Error cases:
#?pugs 2 todo 'bug'
is 42.min, 42, ".min should work on scalars";
is 42.max, 42, ".max should work on scalars";
is (42,).min, 42, ".min should work on one-elem arrays";
is (42,).max, 42, ".max should work on one-elem arrays";

# Tests with literals:
is (1,2,3).max, 3, "method form of max with literals works";
is (1,2,3).min, 1, "method form of min with literals works";
is max(:by({$^a <=> $^b}), 1,2,3),  3, "subroutine form of max with literals works";
is min(:by({$^a <=> $^b}), 1,2,3),  1, "subroutine form of min with literals works";

# Try to read numbers from a file
{
    my $fh = open "t/spec/S32-list/numbers.data";
    @array = $fh.lines();
    is @array.max, 5, "max of strings read from a file works";
    is @array.min, -1, "min of strings read from a file works";

    # Same, but numifying the numbers first
    {
        @array = map { +$_ }, @array;
        is @array.max, 28, "max of strings read from a file works";
        is @array.min, -80, "min of strings read from a file works";
    }

}

is (1, Inf).max, Inf,"Inf is greater than 1";
is (-1, -Inf).min, -Inf,"-Inf is less than -1";
is (-Inf, Inf).min, -Inf,"-Inf is less than Inf";
is (-Inf, Inf).max, Inf,"Inf is greater than -Inf";

#############
#SIN FOUND!
#############
#The four below do not work in ANY implementation so far (the `right one' depends on your way of ordering the values 0, NaN, and Inf from least to greatest) The number of tests has been minused 4, from 46 to 42, for the time being.
#None of the three implementations (pugs, rakudo/alpha, rakudo/master) return what's set below. A trip to the Spec is the only solution, but I haven't enough time.
#for details, see http://irclog.perlgeek.de/perl6/2010-02-23#i_2022557
#sin found 22 Feb. 2010, 21:55 PST
#--lue
#############
#is (0, NaN).min, NaN,    "min(0,NaN)=NaN";
#is (Inf, NaN).min, NaN,    "max(Inf,NaN)=NaN";
#
#is (0, NaN).max, NaN,    "max(0,NaN)=NaN";
#is (Inf, NaN).max, NaN,    "max(Inf,NaN)=NaN";

is ([min] (5,10,-15,20)), -15, 'reduce min int';
is ([max] (5,10,-15,20)), 20, 'reduce max int';

is ([min] (5.1,10.3,-15.7,20.9)), -15.7, 'reduce min numeric';
is ([max] (5.4,10.7,-15.2,20.8)), 20.8, 'reduce max numeric';

{
    my @strings = <Inspiring bold John Barleycorn!
                   What dangers thou canst make us scorn!
                   Wi' tippenny, we fear nae evil;
                   Wi' usquabae, we'll face the devil!>;

    is @strings.min, "Barleycorn!", 'Default .min works on array of strings';
    is @strings.min(-> $a, $b { $a.chars <=> $b.chars || $a leg $b }), "us", '.min works with explicit comparator';
    is ([min] @strings), "Barleycorn!", '[min] works on array of strings';

    is @strings.max, "we'll", 'Default .max works on array of strings';
    is @strings.max(-> $a, $b { $a.chars <=> $b.chars || $a leg $b }), "Barleycorn!", 
       '.max works with explicit comparator';
    is ([max] @strings), "we'll", '[max] works on array of strings';
}

# RT #103178
{
    class A { has $.d };
    is (A.new(d => 5), A.new(d => 1), A.new(d => 10)).min(*.d).d,
        1, 'can use non-numbers with .min and unary closures';

}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/numbers.data���������������������������������������������������������0000664�0001750�0001750�00000000014�12224265625�017627� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������-1
-80
5
28
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/pick.t���������������������������������������������������������������0000664�0001750�0001750�00000012427�12224265625�016447� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 47;

=begin description

This test tests the C<pick> builtin. See S32::Containers#pick.

Previous discussions about pick.

L<"http://groups.google.com/group/perl.perl6.language/tree/browse_frm/thread/24e369fba3ed626e/4e893cad1016ed94?rnum=1&_done=%2Fgroup%2Fperl.perl6.language%2Fbrowse_frm%2Fthread%2F24e369fba3ed626e%2F6e6a2aad1dcc879d%3F#doc_2ed48e2376511fe3">

=end description

# L<S32::Containers/List/=item pick>

my @array = <a b c d>;
#?pugs skip "autothread"
ok ?(@array.pick eq any <a b c d>), "pick works on arrays";
#?niecza skip '().pick === Nil'
#?pugs skip 'Nil'
ok ().pick === Nil, '.pick on the empty list is Nil';

my @arr = <z z z>;

ok ~(@arr.pick(2)) eq 'z z',   'method pick with $num < +@values';
ok ~(@arr.pick(4)) eq 'z z z', 'method pick with $num > +@values';

#?pugs 2 skip 'NYI'
is pick(2, @arr), <z z>, 'sub pick with $num < +@values, implicit no-replace';
is pick(4, @arr), <z z z>, 'sub pick with $num > +@values';

#?pugs skip '.Str'
is (<a b c d>.pick(*).sort).Str, 'a b c d', 'pick(*) returns all the items in the array (but maybe not in order)';

{
  my @items = <1 2 3 4>;
  my @shuffled_items_10;
  push @shuffled_items_10, @items.pick(*) for ^10;
  isnt(@shuffled_items_10, @items xx 10,
       'pick(*) returned the items of the array in a random order');
}

#?pugs skip "autothreading"
{
    # Test that List.pick doesn't flatten array refs
    ok ?([[1, 2], [3, 4]].pick.join('|') eq any('1|2', '3|4')), '[[1,2],[3,4]].pick does not flatten';
    ok ?(~([[1, 2], [3, 4]].pick(*)) eq '1 2 3 4' | '3 4 1 2'), '[[1,2],[3,4]].pick(*) does not flatten';
}

{
    ok <5 5>.pick() == 5,
       '.pick() returns something can be used as single scalar';
}

#?pugs skip 'pick not defined: VNum Infinity'
{
    my @a = 1..100;
    my @b = pick(*, @a);
    is @b.elems, 100, "pick(*, @a) returns the correct number of elements";
    is ~@b.sort, ~(1..100), "pick(*, @a) returns the correct elements";
    is ~@b.grep(Int).elems, 100, "pick(*, @a) returns Ints (if @a is Ints)";
}

{
    my @a = 1..100;

    isa_ok @a.pick, Int, "picking a single element from an array of Ints produces an Int";
    #?pugs todo
    ok @a.pick ~~ 1..100, "picking a single element from an array of Ints produces one of them";

    #?pugs todo
    isa_ok @a.pick(1), Int, "picking 1 from an array of Ints produces an Int";
    #?pugs todo
    ok @a.pick(1) ~~ 1..100, "picking 1 from an array of Ints produces one of them";

    my @c = @a.pick(2);
    isa_ok @c[0], Int, "picking 2 from an array of Ints produces an Int...";
    isa_ok @c[1], Int, "... and an Int";
    #?pugs todo
    ok (@c[0] ~~ 1..100) && (@c[1] ~~ 1..100), "picking 2 from an array of Ints produces two of them";
    ok @c[0] != @c[1], "picking 2 from an array of Ints produces two distinct results";

    #?pugs 2 skip "NYI"
    is @a.pick("25").elems, 25, ".pick works Str arguments";
    is pick("25", @a).elems, 25, "pick works Str arguments";
}

#?pugs skip "NYI"
{
    #?rakudo todo 'error on pick :replace'
    dies_ok({ [1,2,3].pick(4, :replace) }, 'error on deprecated :replace');
}

# enums + pick
#?pugs skip "NYI"
{
    is Bool.pick(*).grep(Bool).elems, 2, 'Bool.pick works';

    enum A <b c d>;
    is A.pick(*).grep(A).elems, 3, 'RandomEnum.pick works';
}

# ranges + pick
{
    my %seen;
    %seen{$_} = 1 for (1..100).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems';
    ok (so 1 <= all(%seen.keys) <= 100), '... and all the elements are in range';
}

{
    my %seen;
    %seen{$_} = 1 for (1..300).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems';
    ok (so 1 <= all(%seen.keys) <= 300), '... and all the elements are in range';
}

{
    my %seen;
    %seen{$_} = 1 for (1..50).pick(*);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems';
    ok (so 1 <= all(%seen.keys) <= 50), '... and all the elements are in range';
}

{
    ok 1 <= (1..50).pick <= 50, 'Range.pick() works';
}

{
    my %seen;
    %seen{$_} = 1 for (1..1_000_000).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems';
    ok (so 1 <= all(%seen.keys) <= 1_000_000), '... and all the elements are in range';
}

{
    my %seen;
    %seen{$_} = 1 for (1^..1_000_000).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems (lower exclusive)';
    ok (so 1 < all(%seen.keys) <= 1_000_000), '... and all the elements are in range';
}

{
    my %seen;
    %seen{$_} = 1 for (1..^1_000_000).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems (upper exclusive)';
    ok (so 1 <= all(%seen.keys) < 1_000_000), '... and all the elements are in range';
}

{
    my %seen;
    %seen{$_} = 1 for (1^..^1_000_000).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems (both exclusive)';
    ok (so 1 < all(%seen.keys) < 1_000_000), '... and all the elements are in range';
}

#?pugs skip 'hogs memory'
{
    my %seen;
    %seen{$_} = 1 for (1 .. (10**1000) ).pick(50);
    is %seen.keys.elems, 50, 'Range.pick produces uniq elems in huge range';
    ok (so 1 <= all(%seen.keys) <= 10**1000), '... and all the elements are in range';
}

is (1..^2).pick, 1, 'pick on 1-elem range';

#?pugs todo
ok ('a'..'z').pick ~~ /\w/, 'Range.pick on non-Int range';

# RT #109586
#?pugs skip 'hogs memory'
nok ([==] (^2**64).roll(10).map(* +& 15)), 'Range.pick has enough entropy';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/reduce.t�������������������������������������������������������������0000664�0001750�0001750�00000003770�12224265625�016771� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

=begin description

This test tests the C<reduce> builtin.

Reference:
L<"http://groups.google.com/groups?selm=420DB295.3000902%40conway.org">

=end description

plan 14;

# L<S32::Containers/List/=item reduce>

{
  my @array = <5 -3 7 0 1 -9>;
  my $sum   = 5 + -3 + 7 + 0 + 1 + -9; # laziness :)


  is((reduce { $^a + $^b }, 0, @array), $sum, "basic reduce works (1)");
}

# Reduce with n-ary functions
{
  my @array  = <1 2 3 4 5 6 7 8>, Any;
  my $result = (((1 + 2 * 3) + 4 * 5) + 6 * 7) + 8 * Any;

  #?rakudo todo 'n-ary reduce'
  #?niecza skip 'n-ary reduce'
  is (@array.reduce: { $^a + $^b * $^c }), $result, "n-ary reduce() works";
}


{
  is( 42.reduce( {$^a+$^b} ), 42,  "method form of reduce works on numbers");
  is( 'str'.reduce( {$^a+$^b} ), 'str', "method form of reduce works on strings");
  is ((42,).reduce: { $^a + $^b }), 42,      "method form of reduce should work on arrays";
}

{
  my $hash = {a => {b => {c => 42}}};
  my @reftypes;
  sub foo (Hash $hash, Str $key) {
    push @reftypes, $hash.WHAT;
    $hash.{$key};
  }
  is((reduce(&foo, $hash, <a b c>)), 42, 'reduce(&foo) (foo ~~ .{}) works three levels deep');
  isa_ok(@reftypes[0], Hash, "first application of reduced hash subscript passed in a Hash");
  isa_ok(@reftypes[1], Hash, "second application of reduced hash subscript passed in a Hash");
  isa_ok(@reftypes[2], Hash, "third application of reduced hash subscript passed in a Hash");
}

is( (1).list.reduce({$^a * $^b}), 1, "Reduce of one element list produces correct result");

eval_lives_ok( 'reduce -> $a, $b, $c? { $a + $b * ($c//1) }, 1, 2', 'Use proper arity calculation');

{
    is( ((1..10).list.reduce: &infix:<+>), 55, '.reduce: &infix:<+> works' );
    is( ((1..4).list.reduce: &infix:<*>), 24, '.reduce: &infix:<*> works' );
}

# RT #66352
#?pugs skip 'where'
{
    multi a (Str $a, Str $b) { [+$a, +$b] };
    multi a (Array $a,$b where "+") { [+] @($a) };  #OK not used
    is ("1", "2", "+").reduce(&a), 3, 'reduce and multi subs';
}

done;

# vim: ft=perl6
��������rakudo-2013.12/t/spec/S32-list/reverse.t������������������������������������������������������������0000664�0001750�0001750�00000005135�12224265625�017172� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Containers/List/"=item reverse">

plan 21;



=begin pod

Tests for "reverse", which always reverse lists now. See flip()
in S32-str for the string reversal

=end pod


my @a = reverse(1, 2, 3, 4);
my @e = (4, 3, 2, 1);

is(@a, @e, "list was reversed");

{
    my $a = reverse("foo");
    #?pugs todo
    is($a, "foo", "string was not reversed; that's what flip() is for");

    @a = reverse "foo", "bar";
    is(+@a, 2, 'the reversed list has two elements');
    is(@a[0], "bar", 'the list was reversed properly');

    is(@a[1], "foo", 'the list was reversed properly');
}

# #?rakudo skip 'want()'
# {
#     my @cxt_log;
# 
#     class Foo {
#         my @.n;
#         method foo () {
#             push @cxt_log, want();
#             (1, 2, 3)
#         }
#         method bar () {
#             push @cxt_log, want();
#             return @!n = do {
#                 push @cxt_log, want();
#                 reverse self.foo;
#             }
#         }
#     }
# 
#     my @n = do {
#         push @cxt_log, want();
#         Foo.new.bar;
#     };
# 
#     #?pugs todo 'bug'
#     is(~@cxt_log, ~("List (Any)" xx 4), "contexts were passed correctly around masak's bug");
#     is(+@n, 3, "list context reverse in masak's bug");
#     is(~@n, "3 2 1", "elements seem reversed");
# }

{
    my @a = "foo";
    my @b = @a.reverse;
    #?niecza skip "Iterable NYI"
    #?pugs skip "Iterable NYI"
    isa_ok(@b, Iterable);
    my $b = @a.reverse;
    #?niecza skip "Iterable NYI"
    #?pugs skip "Iterable NYI"
    isa_ok($b, Iterable);
    is(@b[0], "foo", 'our list is reversed properly');
    is($b, "foo", 'in scalar context it is still a list');
    is(@a[0], "foo", "original array left untouched");
    @a .= reverse;
    is(@a[0], "foo", 'in place reversal works');
}

{
    my @a = ("foo", "bar");
    my @b = @a.reverse;
    #?niecza skip "Iterable NYI"
    #?pugs skip "Iterable NYI"
    isa_ok(@b, Iterable);
    my $b = @a.reverse;
    #?niecza skip "Iterable NYI"
    #?pugs skip "Iterable NYI"
    isa_ok($b, Iterable);
    is(@b[0], "bar", 'our array is reversed');
    is(@b[1], "foo", 'our array is reversed');

    is($b, "bar foo", 'in scalar context it is still a list');

    is(@a[0], "foo", "original array left untouched");
    is(@a[1], "bar", "original array left untouched");

    @a .= reverse;
    is(@a[0], "bar", 'in place reversal works');
    is(@a[1], "foo", 'in place reversal works');
}

# RT #77914
#?rakudo todo "RT 77914"
#?niecza skip 'Unable to resolve method reverse in class Parcel'
{
    is (<a b>, <c d>).reverse.join, 'dcba', '.reverse flattens parcels';
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/roll.t���������������������������������������������������������������0000664�0001750�0001750�00000010161�12224265625�016462� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 40;

=begin description

This test tests the C<roll> builtin. See S32::Containers#roll.

=end description

# L<S32::Containers/List/=item roll>

my @array = <a b c d>;
ok ?(@array.roll eq any <a b c d>), "roll works on arrays";

#?niecza skip '.roll on empty list'
ok ().roll === Nil, '.roll on the empty list is Nil';

my @arr = <z z z>;

ok ~(@arr.roll(2)) eq 'z z',   'method roll with $num < +@values';
ok ~(@arr.roll(4)) eq 'z z z z', 'method roll with $num > +@values';

#?pugs 2 todo 'feature'
is roll(2, @arr), <z z>, 'sub roll with $num < +@values, implicit no-replace';
is roll(4, @arr), <z z z z>, 'sub roll with $num > +@values';

is <a b c d>.roll(*)[^10].elems, 10, 'roll(*) generates at least ten elements';

{
  my @items = <1 2 3 4>;
  my @shuffled_items_10;
  push @shuffled_items_10, @items.roll(4) for ^10;
  isnt(@shuffled_items_10, @items xx 10,
       'roll(4) returned the items of the array in a random order');
}

is (0, 1).roll(*).[^10].elems, 10, '.roll(*) returns at least ten elements';

{
    # Test that List.roll doesn't flatten array refs
    ok ?([[1, 2], [3, 4]].roll.join('|') eq any('1|2', '3|4')), '[[1,2],[3,4]].roll does not flatten';
}

{
    ok <5 5>.roll() == 5,
       '.roll() returns something can be used as single scalar';
}

{
    my @a = 1..100;
    my @b = roll(100, @a);
    is @b.elems, 100, "roll(100, @a) returns the correct number of elements";
    is ~@b.grep(Int).elems, 100, "roll(100, @a) returns Ints (if @a is Ints)";
    is ~@b.grep(1..100).elems, 100, "roll(100, @a) returns numbers in the correct range";

    isa_ok @a.roll, Int, "rolling a single element from an array of Ints produces an Int";
    ok @a.roll ~~ 1..100, "rolling a single element from an array of Ints produces one of them";

    isa_ok @a.roll(1), Int, "rolling 1 from an array of Ints produces an Int";
    ok @a.roll(1) ~~ 1..100, "rolling 1 from an array of Ints produces one of them";

    my @c = @a.roll(2);
    isa_ok @c[0], Int, "rolling 2 from an array of Ints produces an Int...";
    isa_ok @c[1], Int, "... and an Int";
    ok (@c[0] ~~ 1..100) && (@c[1] ~~ 1..100), "rolling 2 from an array of Ints produces two of them";

    is @a.roll("25").elems, 25, ".roll works Str arguments";
    is roll("25", @a).elems, 25, "roll works Str arguments";
}

# enums + roll
{
    is Bool.roll(3).grep(Bool).elems, 3, 'Bool.roll works';

    enum A <b c d>;
    is A.roll(4).grep(A).elems, 4, 'RandomEnum.roll works';
}

# ranges + roll
{
    ok 1 <= (1..1_000_000).roll() <= 1_000_000, 'no argument roll works';
    
    my @matches := (1..1_000_000).roll(*);
    ok (so 1 <= all(@matches[^100]) <= 1_000_000), 'the first 100 elems are in range';
}

{
    my @matches = (1..1_000_000).roll(20);
    is @matches.elems, 20, 'right number of elements from Range.roll';
    ok (so 1 <= all(@matches) <= 1_000_000), 'all the elems are in range';
}

{
    my @matches = (1^..1_000_000).roll(20);
    is @matches.elems, 20, 'right number of elements from Range.roll (min exclusive)';
    ok (so 1 < all(@matches) <= 1_000_000), 'all the elems are in range';
}

{
    my @matches = (1..^1_000_000).roll(20);
    is @matches.elems, 20, 'right number of elements from Range.roll (max exclusive)';
    ok (so 1 <= all(@matches) < 1_000_000), 'all the elems are in range';
}

{
    my @matches = (1^..^1_000_000).roll(20);
    is @matches.elems, 20, 'right number of elements from Range.roll (both exclusive)';
    ok (so 1 < all(@matches) < 1_000_000), 'all the elems are in range';
}

{
    my @matches = (1..(10**1000)).roll(20);
    is @matches.elems, 20, 'right number of elements from Range.roll, huge range';
    ok (so 1 <= all(@matches) <= 10**1000), 'all the elems are in range';
}


is (1..^2).roll, 1, '1-elem Range roll';
ok ('a' .. 'z').roll ~~ /\w/, 'Str-Range roll';

# RT 89972
#?niecza skip "That's not the right way to spawn another Niecza"
{
    my $a = qqx{$*EXECUTABLE_NAME -e "print ~(1..10).pick(5)"};
    my $b = qqx{$*EXECUTABLE_NAME -e "print ~(1..10).pick(5)"};
    my $c = qqx{$*EXECUTABLE_NAME -e "print ~(1..10).pick(5)"};
    ok ($a ne $b || $b ne $c), 'different results due to random random-number seed';
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/sort.t���������������������������������������������������������������0000664�0001750�0001750�00000014552�12224265625�016511� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 32;

# L<S32::Containers/"List"/"=item sort">

{
    my @a = (4, 5, 3, 2, 5, 1);
    my @e = (1 .. 5, 5);

    my @s = sort(@a);
    is(@s, @e, 'array of numbers was sorted');
}

{
    my @a = (4, 5, 3, 2, 5, 1);
    my @e = (1 .. 5, 5);

    my @s = sort @a;
    is(@s, @e, 'array of numbers was sorted (w/out parens)');
}

{
    # This test used to have NaN in it, but that is nonsensical.
    #                                          --colomon
    
    my @a = (1.1,2,-3.05,0.1,Inf,42,-1e-07,-Inf).sort;
    my @e = (-Inf,-3.05,-1e-07,0.1,1.1,2,42,Inf);
    my @s = sort @a;
    is(@s, @e, 'array of mixed numbers including Inf');
}

{
    my @a = (4, 5, 3, 2, 5, 1);
    my @e = (1 .. 5, 5);

    my @s = @a.sort;
    is(@s, @e, 'array of numbers was sorted (using invocant form)');
}

#?pugs todo
{
    my @a = (2, 45, 6, 1, 3);
    my @e = (1, 2, 3, 6, 45);

    my @s = sort { $^a <=> $^b }, @a;
    is(@s, @e, '... with explicit spaceship');
}

#?rakudo skip "closure as non-final argument"
#?niecza skip 'Invocant handling is NYI'
#?pugs todo
{
    my @a = (2, 45, 6, 1, 3);
    my @e = (1, 2, 3, 6, 45);

    my @s = sort { $^a <=> $^b }: @a;
    is(@s, @e, '... with closure as indirect invocant');
}

#?rakudo todo "method fallback to sub unimpl"
#?niecza skip 'err, what?'
#?pugs todo
{
    my @a = (2, 45, 6, 1, 3);
    my @e = (1, 2, 3, 6, 45);

    my @s = { $^a <=> $^b }.sort: @a;
    is(@s, @e, '... with closure as direct invocant');
}

#?pugs todo
{
    my @a = (2, 45, 6, 1, 3);
    my @e = (1, 2, 3, 6, 45);

    my @s = @a.sort: { $^a <=> $^b };
    is(@s, @e, '... with explicit spaceship (using invocant form)');
}

#?pugs todo
{
    my @a = (2, 45, 6, 1, 3);
    my @e = (45, 6, 3, 2, 1);

    my @s = sort { $^b <=> $^a }, @a;
    is(@s, @e, '... reverse sort with explicit spaceship');
}

#?pugs todo
{
    my @a = (2, 45, 6, 1, 3);
    my @e = (45, 6, 3, 2, 1);

    my @s = @a.sort: { $^b <=> $^a };
    is(@s, @e, '... reverse sort with explicit spaceship (using invocant form)');
}

{
    my @a = <foo bar gorch baz>;
    my @e = <bar baz foo gorch>;

    my @s = sort(@a);
    is(@s, @e, 'array of strings was sorted');
}

{
    my @a = <foo bar gorch baz>;
    my @e = <bar baz foo gorch>;

    my @s = sort @a;
    is(@s, @e, 'array of strings was sorted (w/out parens)');
}

{
    my @a = <foo bar gorch baz>;
    my @e = <bar baz foo gorch>;

    my @s = @a.sort;
    is(@s, @e, 'array of strings was sorted (using invocant form)');
}

#?pugs todo
{
    my @a = <daa boo gaa aaa>;
    my @e = <aaa boo daa gaa>;

    my @s = sort { $^a cmp $^b }, @a;
    is(@s, @e, '... with explicit cmp');
}

#?pugs todo
{
    my @a = <daa boo gaa aaa>;
    my @e = <aaa boo daa gaa>;

    my @s = @a.sort: { $^a cmp $^b };
    is(@s, @e, '... with explicit cmp (using invocant form)');
}


#?pugs todo
{
    my %a = (4 => 'a', 1 => 'b', 2 => 'c', 5 => 'd', 3 => 'e');
    my @e = (4, 1, 2, 5, 3);

    my @s = sort -> $a, $b { %a{$a} cmp %a{$b} }, %a.keys;
    is(@s, @e, '... sort keys by string value');
}

#?pugs todo
{
    my %a = (4 => 'a', 1 => 'b', 2 => 'c', 5 => 'd', 3 => 'e');
    my @e = (4, 1, 2, 5, 3);

    my @s = %a.keys.sort: -> $a, $b { %a{$a} cmp %a{$b} };
    is(@s, @e, '... sort keys by string value (using invocant form)');
}

#?pugs todo
{
    my %a = ('a' => 4, 'b' => 1, 'c' => 2, 'd' => 5, 'e' => 3);
    my @e = <b c e a d>;

    my @s = sort -> $a, $b { %a{$a} <=> %a{$b} }, %a.keys;
    is(@s, @e, '... sort keys by numeric value');
}

#?pugs todo
{
    my %a = ('a' => 4, 'b' => 1, 'c' => 2, 'd' => 5, 'e' => 3);
    my @e = <b c e a d>;

    my @s = %a.keys.sort: -> $a, $b { %a{$a} <=> %a{$b} };
    is(@s, @e, '... sort keys by numeric value (using invocant form)');
}


#?pugs skip '.key'
{
    my %map = (p => 1, e => 2, r => 3, l => 4);

    is <r e p l>.sort({ %map{$_} }).join, 'perl',
            'can sort with automated Schwartzian Transform';

    my @s = %map.sort: { .value };
    isa_ok(@s[0], Pair, '%hash.sort returns a List of Pairs');
    is (@s.map: { .key }).join, 'perl', 'sort with unary sub'
}


#?niecza todo "Niecza's sort is not stable"
#?pugs skip 'Cannot cast into Array: VRef'
{
    is (<P e r l 6>.sort: { 0; }).join, 'Perl6',
    'sort with arity 0 closure is stable';

    my @a = ([5, 4], [5, 5], [5, 6], [0, 0], [1, 2], [1, 3], [0, 1], [5, 7]);

    {
        my @s = @a.sort: { .[0] };

        ok ([<] @s.map({.[1]})), 'sort with arity 1 closure is stable';
    }

    {
        my @s = @a.sort: { $^a.[0] <=> $^b.[0] };

        ok ([<] @s.map({.[1]})), 'sort with arity 2 closure is stable';
    }
}

##  XXX pmichaud, 2008-07-01:  .sort should work on non-list values
{
    is ~42.sort, "42", "method form of sort should work on numbers";
    is ~"str".sort, "str", "method form of sort should work on strings";
    is ~(42,).sort, "42",  "method form of sort should work on parcels";
}

# RT #67010
#?pugs todo
{
    my @list = 1, 2, Code;
    lives_ok { @list.sort: { $^a cmp $^b } },
        'sort by class name';
}

# RT #68112
#?rakudo skip "determine behavior of 0-arity methods passed to sort"
#?niecza skip "determine behavior of 0-arity methods passed to sort"
{
    sub foo () { 0 }   #OK not used
    lives_ok { (1..10).sort(&foo) },
        'sort accepts 0-arity method';
    # errr... is there even supposed to be a rand sub?
    lives_ok { (1..10).sort(&rand) },
        'sort accepts rand method';
}

# RT #71258
{
    class RT71258_1 { };

    my @sorted;

    #?niecza todo 'Is this test actually testing for correct behavior?'
    lives_ok { @sorted = (RT71258_1.new, RT71258_1.new).sort },
        'sorting by stringified class instance (name and memory address)';

    class RT71258_2 {
        has $.x;
        method Str { $.x }
    };

    # Following tests removed because you cannot 
    # affect the behavior of sort by defining 
    # sub cmp.  As far as I understand things, you
    # couldn't even affect it by defined 
    # a new sub infix:<cmp>. --colomon

    # multi sub cmp(RT71258_2 $a, RT71258_2 $b) {
    #     $a.x <=> $b.x;
    # }
    # 
    # #?rakudo todo 'nom regression'
    # lives_ok {
    #     @sorted = (
    #         RT71258_2.new(x => 2),
    #         RT71258_2.new(x => 3),
    #         RT71258_2.new(x => 1)
    #     ).sort
    # }, 'sorting stringified class instance with custom cmp';
    # 
    # #?rakudo todo 'nom regression'
    # is ~@sorted, '1 2 3',
    #     'checking sort order with custom cmp';
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/squish.t�������������������������������������������������������������0000664�0001750�0001750�00000007153�12224265625�017035� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 26;

=begin description

This test tests the C<squish> builtin and .squish method on Any/List.

=end description

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a b b c d e f f a>;
    is_deeply @array.squish,  <a b c d e f a>.list.item,
      "method form of squish works";
    is_deeply squish(@array), <a b c d e f a>.list.item,
      "subroutine form of squish works";
    is_deeply @array .= squish, [<a b c d e f a>],
      "inplace form of squish works";
    is_deeply @array, [<a b c d e f a>],
      "final result of in place";
} #4

{
    is_deeply squish(Any,'a', 'b', 'b', 'c', 'd', 'e', 'f', 'f', 'a'),
      (Any, <a b c d e f a>.list).list.item,
      'slurpy subroutine form of squish works';
} #1

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    is 42.squish, 42,    ".squish can work on scalars";
    is (42,).squish, 42, ".squish can work on one-elem arrays";
} #2

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my class A { method Str { '' } };
    is (A.new, A.new).squish.elems, 2, 'squish has === semantics for objects';
} #1

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @list = 1, "1";
    my @squish = squish(@list);
    is @squish, @list, "squish has === semantics for containers";
} #1

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @a := squish( 1..Inf );
    is @a[3], 4, "make sure squish is lazy";
} #1

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a b bb c d e f f a>;
    my $as    = *.substr: 0,1;
    is_deeply @array.squish(:$as),  <a b c d e f a>.list.item,
      "method form of squish with :as works";
    is_deeply squish(@array,:$as), <a b c d e f a>.list.item,
      "subroutine form of squish with :as works";
    is_deeply @array .= squish(:$as), [<a b c d e f a>],
      "inplace form of squish with :as works";
    is_deeply @array, [<a b c d e f a>],
      "final result with :as in place";
} #4

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a aa b bb c d e f f a>;
    my $with  = { substr($^a,0,1) eq substr($^b,0,1) }
    is_deeply @array.squish(:$with),  <a b c d e f a>.list.item,
      "method form of squish with :with works";
    is_deeply squish(@array,:$with), <a b c d e f a>.list.item,
      "subroutine form of squish with :with works";
    is_deeply @array .= squish(:$with), [<a b c d e f a>],
      "inplace form of squish with :with works";
    is_deeply @array, [<a b c d e f a>],
      "final result with :with in place";
} #4

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a aa b bb c d e f f a>;
    my $as    = *.substr(0,1).ord;
    my $with  = &[==];
    is_deeply @array.squish(:$as, :$with),  <a b c d e f a>.list.item,
      "method form of squish with :as and :with works";
    is_deeply squish(@array,:$as, :$with), <a b c d e f a>.list.item,
      "subroutine form of squish with :as and :with works";
    is_deeply @array .= squish(:$as, :$with), [<a b c d e f a>],
      "inplace form of squish with :as and :with works";
    is_deeply @array, [<a b c d e f a>],
      "final result with :as and :with in place";
} #4

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = ({:a<1>}, {:a<1>}, {:b<1>});
    my $with  = &[eqv];
    is_deeply @array.squish(:$with),  ({:a<1>}, {:b<1>}).list.item,
      "method form of squish with [eqv] and objects works";
    is_deeply squish(@array,:$with), ({:a<1>}, {:b<1>}).list.item,
      "subroutine form of squish with [eqv] and objects works";
    is_deeply @array .= squish(:$with), [{:a<1>}, {:b<1>}],
      "inplace form of squish with [eqv] and objects works";
    is_deeply @array, [{:a<1>}, {:b<1>}],
      "final result with [eqv] and objects in place";
} #4

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-list/uniq.t���������������������������������������������������������������0000664�0001750�0001750�00000010055�12224265625�016470� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 30;

=begin description

This test tests the C<uniq> builtin.

See the thread "[S32::Containers] uniq" on p6l, too.

=end description

{
    my @array = <a b b c d e b b b b f b>;
    is_deeply @array.uniq,  <a b c d e f>.list.item,
      "method form of uniq works";
    is_deeply uniq(@array), <a b c d e f>.list.item,
      "subroutine form of uniq works";
    is_deeply @array .= uniq, [<a b c d e f>],
      "inplace form of uniq works";
    is_deeply @array, [<a b c d e f>],
      "final result of in place";
} #4

{
    is_deeply uniq('a', 'b', 'b', 'c', 'd', 'e', 'b', 'b', 'b', 'b', 'f', 'b'),
      <a b c d e f>.list.item,
      'slurpy subroutine form of uniq works';
} #1

# With a userspecified criterion
#?niecza skip "with NYI"
#?pugs skip "Named argument found where no matched parameter expected"
{
    my @array = <a b d A c b>;
    # Semantics w/o junctions
    is ~@array.uniq( with => { lc($^a) eq lc($^b) } ),  "a b d c",
      "method form of uniq with own comparator works";
    is ~uniq(@array, with => { lc($^a) eq lc($^b) }), "a b d c",
      "subroutine form of uniq with own comparator works";
  
    # Semantics w/ junctions
    is eval('~@array.uniq(with => { lc($^a) eq lc($^b) }).values.sort'), "a b c d", 'sorting the result';
} #3

#?pugs todo 'bug'
{
    is 42.uniq, 42,    ".uniq can work on scalars";
    is (42,).uniq, 42, ".uniq can work on one-elem arrays";
} #2

# http://irclog.perlgeek.de/perl6/2009-10-31#i_1669037
#?pugs todo
{
    my $range = [1..4];
    my @array = $range, $range.WHICH;
    is @array.elems, 2,      ".uniq does not use naive WHICH (1)";
    is @array.uniq.elems, 2, ".uniq does not use naive WHICH (2)";
} #2

# RT #111360
{
    my class A { method Str { '' } };
    is (A.new, A.new).uniq.elems, 2, 'uniq has === semantics';
} #1

# RT #83454
{
    my @list = 1, "1";
    my @uniq = uniq(@list);
    is @uniq, @list, "uniq has === semantics";
} #1

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a b bb c d e b bbbb b b f b>;
    my $as    = *.substr: 0,1;
    is_deeply @array.uniq(:$as),  <a b c d e f>.list.item,
      "method form of uniq with :as works";
    is_deeply uniq(@array,:$as), <a b c d e f>.list.item,
      "subroutine form of uniq with :as works";
    is_deeply @array .= uniq(:$as), [<a b c d e f>],
      "inplace form of uniq with :as works";
    is_deeply @array, [<a b c d e f>],
      "final result with :as in place";
} #4

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a b bb c d e b bbbb b b f b>;
    my $with  = { substr($^a,0,1) eq substr($^b,0,1) }
    is_deeply @array.uniq(:$with),  <a b c d e f>.list.item,
      "method form of uniq with :with works";
    is_deeply uniq(@array,:$with), <a b c d e f>.list.item,
      "subroutine form of uniq with :with works";
    is_deeply @array .= uniq(:$with), [<a b c d e f>],
      "inplace form of uniq with :with works";
    is_deeply @array, [<a b c d e f>],
      "final result with :with in place";
} #4

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = <a b bb c d e b bbbb b b f b>;
    my $as    = *.substr(0,1).ord;
    my $with  = &[==];
    is_deeply @array.uniq(:$as),  <a b c d e f>.list.item,
      "method form of uniq with :as works";
    is_deeply uniq(@array,:$as), <a b c d e f>.list.item,
      "subroutine form of uniq with :as works";
    is_deeply @array .= uniq(:$as), [<a b c d e f>],
      "inplace form of uniq with :as works";
    is_deeply @array, [<a b c d e f>],
      "final result with :as in place";
} #4

#?pugs   skip 'NYI'
#?niecza skip 'NYI'
{
    my @array = ({:a<1>}, {:b<1>}, {:a<1>});
    my $with  = &[eqv];
    is_deeply @array.uniq(:$with),  ({:a<1>}, {:b<1>}).list.item,
      "method form of uniq with [eqv] and objects works";
    is_deeply uniq(@array,:$with), ({:a<1>}, {:b<1>}).list.item,
      "subroutine form of uniq with [eqv] and objects works";
    is_deeply @array .= uniq(:$with), [{:a<1>}, {:b<1>}],
      "inplace form of uniq with [eqv] and objects works";
    is_deeply @array, [{:a<1>}, {:b<1>}],
      "final result with [eqv] and objects in place";
} #4

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/abs.t�����������������������������������������������������������������0000664�0001750�0001750�00000002133�12224265625�016103� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 49;

# L<S32::Numeric/Numeric/"=item abs">

=begin pod

Basic tests for the abs() builtin

=end pod

for 0, 0 / 1, 0.0e0, 1, 50, 60.0e0, 99.99 -> $x {
    is(abs($x), $x, "got the right absolute value for $x");
    is($x.abs, $x, 'got the right absolute value for $x='~$x);

    is (abs($x)).WHAT.gist, $x.WHAT.gist, 'type of abs($x) agrees with type of $x';
    is $x.abs.WHAT.gist, $x.WHAT.gist, 'type of $x.abs agrees with type of $x';
}

for -1, -50, -60.0e0, -9999 / 100 {
    is(abs($_), -$_, "got the right absolute value for $_");
    is(.abs, -$_, 'got the right absolute value for $_='~$_);

    is (abs($_)).WHAT.gist, $_.WHAT.gist, 'type of abs($_) agrees with type of $_';
    is $_.abs.WHAT.gist, $_.WHAT.gist, 'type of $_.abs agrees with type of $_';
}

is( abs(NaN), NaN, 'absolute value of NaN is NaN');
is( abs(Inf), Inf, 'absolute value of Inf is Inf');
is( abs(-Inf), Inf, 'absolute value of -Inf is Inf');

is( abs("-10"), 10, 'absolute value of "-10" is 10');

is( abs(70596).WHAT.gist, 70596.abs.WHAT.gist, 'abs(x).WHAT parses as x.abs.WHAT' );

done;

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/base.t����������������������������������������������������������������0000664�0001750�0001750�00000001346�12224265625�016255� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

is  0.base(8),  '0',        '0.base(something)';
# RT #112872
is  0.base(2),  '0',        '0.base(2)';
is 42.base(10), '42',       '42.base(10)';
is 42.base(16), '2A',       '42.base(16)';
is 42.base(2) , '101010',   '42.base(2)';
is 35.base(36), 'Z',        '35.base(36)';
is 36.base(36), '10',       '36.base(36)';
is (-12).base(16), '-C',    '(-12).base(16)';

# RT 112900
#?niecza 4 skip "Rat.base NYI"
is (1/10000000000).base(3),
   '0.0000000000000000000010',   # is the trailing zero correct?
   '(1/10000000000).base(3) (RT 112900)';
is (3.25).base(16), '3.4',  '(3.25).base(16)';
is (10.5).base(2), '1010.1', '(10.5).base(2)';
is (-3.5).base(16), '-3.8', '(-3.5).base(16)';
#TODO more non-integer tests?
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/complex.t�������������������������������������������������������������0000664�0001750�0001750�00000013215�12224265625�017010� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 488;

# Basic tests functions specific to complex numbers.

isa_ok(1 + 2i, Complex, 'postfix:<i> creates a Complex number');
#?pugs   2 skip 'i'
isa_ok(i, Complex, 'i creates a Complex number');
ok i == 1i, 'i == 1i';
ok 1 != 1i, '!= and complex numbers';

isa_ok((3)i, Complex, '($n)i form creates a Complex number');
#?pugs skip 'parsefail'
isa_ok(3\i, Complex, '$n\i form creates a Complex number');

#?pugs todo
is_approx((2i)i, -2, 'postfix:<i> works on an imaginary number');
#?pugs todo
is_approx((2i + 3)i, -2 + 3i, 'postfix:<i> works on a Complex number');

#?pugs todo
eval_dies_ok '(2 + 3i) > (2 + 2i)', '> comparison of complex numbers dies';

#?pugs   3 skip 'i'
is_approx(i, 1i, 'standalone i works to generate a Complex number');
is_approx(1 - i, 1 - 1i, 'standalone i works to generate a Complex number');
is_approx(2i * i, -2, 'standalone i works times a Complex number');

# checked with the open CAS system "yacas":
# In> (3+4*I) / (2-I)
# Out> Complex(2/5,11/5)
# In> (3+4*I) * (2-I)
# Out> Complex(10,5)
# etc
is_approx (3+4i)/(2-1i), 2/5 + (11/5)i, 'Complex division';
is_approx (3+4i)*(2-1i), 10+5i,         'Complex multiplication';
is_approx (6+4i)/2,      3+2i,          'dividing Complex by a Real';
is_approx 2/(3+1i),      3/5 -(1/5)i,   'dividing a Real by a Complex';
is_approx 2 * (3+7i),    6+14i,         'Real * Complex';
is_approx (3+7i) * 2,    6+14i,         'Complex * Real';

isa_ok( eval((1+3i).perl), Complex, 'eval (1+3i).perl is Complex' );
is_approx( (eval (1+3i).perl), 1+3i, 'eval (1+3i).perl is 1+3i' );
isa_ok( eval((1+0i).perl), Complex, 'eval (1+0i).perl is Complex' );
is_approx( (eval (1+0i).perl), 1, 'eval (1+0i).perl is 1' );
isa_ok( eval((3i).perl), Complex, 'eval (3i).perl is Complex' );
is_approx( (eval (3i).perl), 3i, 'eval (3i).perl is 3i' );

#?niecza skip "NYI"
{
    #?pugs 2 skip '.Real'
    ok (1+0i).Real ~~ Real, "(1+0i).Real is a Real";
    is (1+0i).Real, 1, "(1+0i).Real is 1";
    isa_ok (1.2+0i).Int, Int, "(1.2+0i).Int is an Int";
    is (1.2+0i).Int, 1, "(1.2+0i).Int is 1";
    isa_ok (1.2.sin+0i).Rat, Rat, "(1.2.sin+0i).Rat is an Rat";
    is_approx (1.2.sin+0i).Rat, 1.2.sin, "(1.2.sin+0i).Rat is 1.2.sin";
    isa_ok (1.2+0i).Num, Num, "(1.2+0i).Num is an Num";
    is_approx (1.2+0i).Num, 1.2, "(1.2+0i).Num is 1.2";
    #?pugs 2 skip '.Complex'
    isa_ok (1.2+1i).Complex, Complex, "(1.2+1i).Complex is an Complex";
    is_approx (1.2+1i).Complex, 1.2+1i, "(1.2+1i).Complex is 1.2+1i";
}

# MUST: test .Str

#?pugs skip 'cis, unpolar'
#?DOES 120
{
  # placeholder to hold the skip.
}

# reset for pugs
#?DOES 1

my @examples = (0i, 1 + 0i, -1 + 0i, 1i, -1i, 2 + 0i, -2 + 0i, 2i, -2i,
                2 + 3i, 2 - 3i, -2 + 3i, -2 - 3i);

#?pugs emit #
push @examples, (cis(1.1), cis(3.1), cis(5.1), 35.unpolar(0.8), 40.unpolar(3.7));

for @examples -> $z {
    is_approx($z + 0, $z, "$z + 0 = $z");
    is_approx(0 + $z, $z, "0 + $z = $z");
    is_approx($z + 0.0.Num, $z, "$z + 0.0.Num = $z");
    is_approx(0.0.Num + $z, $z, "0.0.Num + $z = $z");
    is_approx($z + 0 / 1, $z, "$z + 0/1 = $z");
    is_approx(0 / 1 + $z, $z, "0/1 + $z = $z");
    
    is_approx($z - 0, $z, "$z - 0 = $z");
    is_approx(0 - $z, -$z, "0 - $z = -$z");
    is_approx($z - 0.0.Num, $z, "$z - 0.0.Num = $z");
    is_approx(0.0.Num - $z, -$z, "0.0.Num - $z = -$z");
    is_approx($z - 0 / 1, $z, "$z - 0/1 = $z");
    is_approx(0 / 1 - $z, -$z, "0/1 - $z = -$z");

    #?pugs 6 skip '.re,.im'
    is_approx($z + 2, $z.re + 2 + ($z.im)i, "$z + 2");
    is_approx(2 + $z, $z.re + 2 + ($z.im)i, "2 + $z");
    is_approx($z + 2.5.Num, $z.re + 2.5.Num + ($z.im)i, "$z + 2.5.Num = $z");
    is_approx(2.5.Num + $z, $z.re + 2.5.Num + ($z.im)i, "2.5.Num + $z = $z");
    is_approx($z + 3 / 2, $z.re + 3/2 + ($z.im)i, "$z + 3/2");
    is_approx(3 / 2 + $z, $z.re + 3/2 + ($z.im)i, "3/2 + $z");

    #?pugs 6 skip '.re,.im'
    is_approx($z - 2, $z.re - 2 + ($z.im)i, "$z - 2");
    is_approx(2 - $z, -$z.re + 2 - ($z.im)i, "2 - $z");
    is_approx($z - 2.5.Num, $z.re - 2.5.Num + ($z.im)i, "$z - 2.5.Num = $z");
    is_approx(2.5.Num - $z, -$z.re + 2.5.Num - ($z.im)i, "2.5.Num - $z = $z");
    is_approx($z - 3 / 2, $z.re - 3/2 + ($z.im)i, "$z - 3/2");
    is_approx(3 / 2 - $z, -$z.re + 3/2 - ($z.im)i, "3/2 - $z");
}

# L<S32::Numeric/Complex/=item re>
# L<S32::Numeric/Complex/=item im>

#?pugs skip 'NYI'
#?DOES 2
{
    is (1 + 2i).re, 1, 'Complex.re works';
    is (1 + 2i).im, 2, 'Complex.im works';
}

{
    is_approx 0i ** 2, 0, "Complex 0 ** Int works";
    #?pugs todo
    is_approx 0i ** 2.5, 0, "Complex 0 ** Rat works";
    is_approx 0i ** (2 + 0i), 0, "Complex 0 ** Complex works";
    is_approx 0 ** (2 + 0i), 0, "Real 0 ** Complex works";
}

# used to be RT #68848
{
    is_approx exp(3.0 * log(1i)), -1.83697e-16-1i,
              'exp(3.0 * log(1i))';
    sub iPower($a, $b) { exp($b * log($a)) };
    is_approx iPower(1i, 3.0), -1.83697e-16-1i, 'same as wrapped as sub';
}

#?pugs   skip 'e'
is_approx e.log(1i), -2i / pi, "log e base i == -2i / pi";

# Complex math with strings, to make sure type coercion is working correctly
{
    is 3i + "1", 1 + 3i, '3i + "1"';
    is "1" + 3i, 1 + 3i, '"1" + 3i';
    is 3i - "1", 3i - 1, '3i - "1"';
    is "1" - 3i, 1 - 3i, '"1" - 3i';
    is 3i * "1", 3i * 1, '3i * "1"';
    is "1" * 3i, 1 * 3i, '"1" * 3i';
    is 3i / "1", 3i / 1, '3i / "1"';
    is "1" / 3i, 1 / 3i, '"1" / 3i';
    is 3i ** "1", 3i ** 1, '3i ** "1"';
    is "1" ** 3i, 1 ** 3i, '"1" ** 3i';
    
}

# Conjugation
#?pugs skip '.conj'
#?DOES 2
{
  is (2+3i).conj, 2-3i, 'conj 2+3i -> 2-3i';
  is (5-4i).conj, 5+4i, 'conj 5-4i -> 5+4i';
}

#?pugs todo
eval_dies_ok "(1 + 2i) < (2 + 4i)", 'Cannot arithmetically compare Complex numbers';

done;

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/cool-num.t������������������������������������������������������������0000664�0001750�0001750�00000007137�12224265625�017100� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

=begin pod

Basic tests of mathematical functions on Cool

=end pod

my $magic = Complex.new(1.1, 2.1);

class NotComplex is Cool {
    method Numeric() {
        $magic;
    }
}

is "-17".abs, 17, '"-17".abs == 17';
is NotComplex.new.abs, $magic.abs, 'NotComplex.new.abs == $magic.abs';

is "3".conj, 3, '"3".conj == 3';
#?niecza todo
is NotComplex.new.conj, $magic.conj, 'NotComplex.new.conj == $magic.conj';

is_approx "3".exp, 3.exp, '"3".exp == 3.exp';
is_approx NotComplex.new.exp, $magic.exp, 'NotComplex.new.exp == $magic.exp';
is_approx "3".exp("2"), 3.exp(2), '"3".exp("2") == 3.exp(2)';
is_approx NotComplex.new.exp("2"), $magic.exp("2"), 'NotComplex.new.exp("2") == $magic.exp("2")';
is_approx "3".exp(NotComplex.new), 3.exp($magic), '"3".exp(NotComplex.new) == 3.exp($magic)';
is_approx NotComplex.new.exp(NotComplex.new), $magic.exp($magic), 'NotComplex.new.exp(NotComplex.new) == $magic.exp($magic)';

is_approx "17".log, 17.log, '"17".log == 17.log';
is_approx NotComplex.new.log, $magic.log, 'NotComplex.new.log == $magic.log';
is_approx "17".log("17"), 17.log(17), '"17".log("17") == 17.log(17)';
is_approx NotComplex.new.log("17"), $magic.log(17), 'NotComplex.new.log("17") == $magic.log(17)';
is_approx "17".log(NotComplex.new), 17.log($magic), '"17".log("17") == 17.log(17)';
is_approx NotComplex.new.log(NotComplex.new), $magic.log($magic), 'NotComplex.new.log(NotComplex.new) == $magic.log($magic)';

is_approx "17".log10, 17.log10, '"17".log10 == 17.log10';
is_approx NotComplex.new.log10, $magic.log10, 'NotComplex.new.log10 == $magic.log10';

is_approx "17".sqrt, 17.sqrt, '"17".sqrt == 17.sqrt';
is_approx NotComplex.new.sqrt, $magic.sqrt, 'NotComplex.new.sqrt == $magic.sqrt';

#?niecza skip 'roots NYI'
#?DOES 8
{
    my @found-roots = "17".roots("4");
    my @ideal-roots = 17.roots(4);
    
    for @ideal-roots -> $i {
        is @found-roots.grep({ ($i - $_).abs < 1e-6 }).elems, 1, "root $i found once";
    }

    @found-roots = NotComplex.new.roots("3");
    @ideal-roots = $magic.roots(3);
    
    for @ideal-roots -> $i {
        is @found-roots.grep({ ($i - $_).abs < 1e-6 }).elems, 1, "root $i found once";
    }
}

#?niecza skip 'coercion would discard nonzero imaginary part'
#?DOES 2
{
is_approx "17"i, 17i, '"17"i == 17i';
is_approx (NotComplex.new)i, $magic\i, '(NotComplex.new)i == $magic\i';
}

#?rakudo skip 'angle conversion'
#?niecza skip 'angle conversion'
#?DOES 4
{
is_approx "17".to-radians(Degrees), 17.to-radians(Degrees),
          '"17".to-radians(Degrees) == 17.to-radians(Degrees)';
is_approx NotComplex.new.to-radians(Gradians), $magic.to-radians(Gradians),
          'NotComplex.new.to-radians(Gradians) == $magic.to-radians(Gradians)';

is_approx "17".from-radians(Degrees), 17.from-radians(Degrees),
          '"17".from-radians(Degrees) == 17.from-radians(Degrees)';
is_approx NotComplex.new.from-radians(Gradians), $magic.from-radians(Gradians),
          'NotComplex.new.from-radians(Gradians) == $magic.from-radians(Gradians)';
}

is_approx "17.25".floor, 17.25.floor, '"17.25".floor == 17.25.floor';
is_approx "17.25".ceiling, 17.25.ceiling, '"17.25".ceiling == 17.25.ceiling';
is_approx "17.25".round, 17.25.round, '"17.25".floar == 17.25.round';
is_approx "17.25".round("0.1"), 17.25.round(0.1), '"17.25".floar("0.1") == 17.25.round(0.1)';
is_approx "17.25".truncate, 17.25.truncate, '"17.25".floar == 17.25.truncate';

is "17".sign, 1, '"17".sign == 1';
is "-17".sign, -1, '"-17".sign == -1';
is "0".sign, 0, '"0".sign == 0';

is_approx "17".cis, 17.cis, '"17".cis == 17.cis';
is_approx "17".unpolar("42"), 17.unpolar(42), '"17".unpolar("42") == 17.unpolar(42)';

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/expmod.t��������������������������������������������������������������0000664�0001750�0001750�00000001347�12224265625�016640� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 117;

# L<S32::Numeric/Numeric/"=item expmod">

=begin pod

Basic tests for the expmod() builtin

=end pod

for 2..30 -> $i {
    is 7.expmod($i, 10),   7 ** $i % 10,  "7.expmod($i, 10) == { 7 ** $i % 10 }";
    is 9.expmod($i, 10),   9 ** $i % 10,  "9.expmod($i, 10) == { 9 ** $i % 10 }";
    is expmod(11, $i, 8),  11 ** $i % 8,  "expmod(11, $i, 8) == { 11 ** $i % 8 }";
    is expmod(13, $i, 12), 13 ** $i % 12, "expmod(13, $i, 12) == { 13 ** $i % 12 }";
}

is 2988348162058574136915891421498819466320163312926952423791023078876139.expmod(
        2351399303373464486466122544523690094744975233415544072992656881240319,
        10 ** 40),
   1527229998585248450016808958343740453059, "Rosettacode example is correct";�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/exp.t�����������������������������������������������������������������0000664�0001750�0001750�00000004431�12224265625�016135� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 72;

# L<S32::Numeric/Numeric/"=item exp">

=begin pod

Basic tests for the exp() builtin

=end pod

# SHOULD: test method forms of exp as well.

my $e_to_the_fifth = 5497075/37039;
my $pi = 312689/99532;

{
    is_approx(5.exp, $e_to_the_fifth, '5.exp == e to the fifth');
    is_approx(5.Rat.exp, $e_to_the_fifth, '5.Rat.exp == e to the fifth');
    is_approx(5.Num.exp, $e_to_the_fifth, '5.Num.exp == e to the fifth');
    is_approx(0.exp, 1, '0.exp == 1');

    is_approx((1i*$pi).exp, -1, '(i pi).exp == -1');
    is_approx((-1i*$pi).exp, -1, '(-i pi).exp == -1');

    #?pugs 7 todo
    is_approx(5.exp(2), 32, '5.exp(2) == 32');
    is_approx(5.Rat.exp(2), 32, '5.Rat.exp == 32');
    is_approx(5.Num.exp(2), 32, '5.Num.exp == 32');
    is_approx(0.exp(2), 1, '0.exp(2) == 1');
 
    is_approx((1i*$pi).exp(2), 2 ** (1i*$pi), '(i pi).exp(2) == 2 ** (1i*$pi)');
    is_approx((-1i*$pi).exp(2), 2 ** (-1i*$pi), '(-i pi).exp(2) == 2 ** (-1i*$pi)');
    is_approx(2.exp(1i*$pi), (1i*$pi) ** 2, '(2).exp(i pi) == (1i*$pi) ** 2');
}

is_approx(exp(5), $e_to_the_fifth, 'got the exponential of 5');
is_approx(exp(0), 1, 'exp(0) == 1');
is_approx(exp(-1),  0.3678794, '1/e is correct');
is(exp(Inf), Inf, 'exp(Inf) == Inf');
is(exp(-Inf), 0, 'exp(-Inf) == 0');
is(exp(NaN), NaN, 'exp(NaN) == NaN');
is_approx(exp(log(100)),100, 'e^(log(100))=100');

is_approx((1i*$pi).exp, -1, '(i $pi).exp == -1');
is_approx(exp(1i*$pi), -1, 'exp(i $pi) == -1');
is_approx(exp(-1i*$pi), -1, 'exp(-i $pi) == -1');

#?pugs 3 todo
is_approx(exp(5, 2), 32, 'got 32');
is_approx(exp(0, 2), 1, 'exp(0, 2) == 1');
is_approx(exp(-1, 2),  1/2, '1/2 is correct');
is(exp(Inf, 2), Inf, 'exp(Inf) == Inf');
#?pugs todo
is(exp(-Inf, 2), 0, 'exp(-Inf) == 0');
is(exp(NaN, 2), NaN, 'exp(NaN) == NaN');
#?pugs skip 'log multi'
is_approx(exp(log(100, 2), 2),100, 'e^(log(100, 2), 2)=100');

#?pugs 2 todo
is_approx(exp(1i*$pi, 2), 2 ** (1i*$pi), 'exp(i $pi, 2) == 2 ** (1i*$pi)');
is_approx(exp(-1i*$pi, 2), 2 ** (-1i*$pi), 'exp(-i $pi, 2) == 2 ** (-1i*$pi)');

##?pugs skip '..'
{
    for 1 .. 20 {
	    my $arg = 2.0 * $pi / $_;
	    is_approx(exp(1i * $arg), cos($arg) + 1i * sin($arg), 'ex$pi == cos + i sin No. ' ~ $_);
	    is_approx(exp(1i * $arg) * exp(-1i * $arg), 1, 'exp(ix) * exp(-ix) == 1 No. ' ~ $_);
    }
}
# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/fatrat.t��������������������������������������������������������������0000664�0001750�0001750�00000025061�12237474612�016626� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 274;

# Basic test functions specific to FatRats.

# Test ways of making Rats
#?pugs skip 'new'
isa_ok(FatRat.new(1,4), FatRat, "FatRat.new makes a FatRat");
#?pugs todo
isa_ok( (1/4).FatRat, FatRat, "cast of Rat makes a FatRat");
#?pugs todo
isa_ok( 1.Int.FatRat, FatRat, "cast of Int makes a FatRat");
#?pugs todo
isa_ok( 1.Num.FatRat, FatRat, "cast of Num makes a FatRat");

isa_ok(1 / 4, Rat, "/ makes a Rat");

#?pugs 2 skip 'new'
isa_ok( eval(FatRat.new(1, 3).perl), FatRat, 'eval FatRat.new(1, 3).perl is FatRat' );
is_approx (eval FatRat.new(1, 3).perl), 1/3, 'eval FatRat.new(1, 3).perl is 1/3';

# Test ~
#?pugs 4 skip 'new'
is(~(FatRat.new(1,4)), ~(0.25e0), "FatRats stringify properly");
is(~(FatRat.new(-1,2)), ~(-0.5e0), "FatRats stringify properly");
is(~(FatRat.new(7,4)), ~(1.75e0), "FatRats stringify properly");
is(~(FatRat.new(7,-1)), ~(-7), "FatRats stringify properly");

# Test new
#?pugs 6 skip 'new'
is(FatRat.new(1, -7).nude, (-1, 7), "Negative signs move to numeFatRator");
is(FatRat.new(-32, -33).nude, (32, 33), "Double negatives cancel out");
is(FatRat.new(2, 4).nude, (1, 2), "Reduce to simplest form in constructor");
is(FatRat.new(39, 33).nude, (13, 11), "Reduce to simplest form in constructor");
is(FatRat.new(0, 33).nude, (0, 1), "Reduce to simplest form in constructor");
is(FatRat.new(1451234131, 60).nude, (1451234131, 60), "Reduce huge number to simplest form in constructor");

sub postfix:<R>($x) { $x.FatRat }

#?pugs todo
isa_ok 1R, FatRat, "1R is a FatRat";
is 1R, 1, "1R == 1";
#?pugs todo
isa_ok 1/4R, FatRat, "1/4R is a FatRat";
is 1/4R, 1/4, "1/4R == 1/4";
 
# Test basic math
is(1 / 4R + 1 / 4R, 1/2, "1/4R + 1/4R = 1/2");
#?pugs todo
isa_ok(1 / 4R + 1 / 4R, FatRat, "1/4R + 1/4R is a FatRat");
is(1 / 4 + 1 / 4R, 1/2, "1/4 + 1/4R = 1/2");
#?pugs todo
isa_ok(1 / 4 + 1 / 4R, FatRat, "1/4 + 1/4R is a FatRat");
is(1 / 4R + 1 / 4, 1/2, "1/4R + 1/4 = 1/2");
#?pugs todo
isa_ok(1 / 4R + 1 / 4, FatRat, "1/4R + 1/4 is a FatRat");
is(1 / 4R + 2 / 7R, 15/28, "1/4R + 2/7R = 15/28");
is(1 / 4R + 1, 5/4, "1/4R + 1 = 5/4");
#?pugs todo
isa_ok(1 / 4R + 1, FatRat, "1/4R + 1 is a FatRat");
is(1 + 1 / 4R, 5/4, "1 + 1/4R = 5/4");
#?pugs todo
isa_ok(1 + 1 / 4R, FatRat, "1 + 1/4R is a FatRat");

is(1 / 4R - 1 / 4R, 0/1, "1/4R - 1/4R = 0/1");
is(1 / 4R - 3 / 4R, -1/2, "1/4R - 3/4R = -1/2");
#?pugs skip 'nude'
is((1 / 4R - 3 / 4R).nude, (-1, 2), "1/4R - 3/4R = -1/2 is simplified internally");
#?pugs todo
isa_ok((1 / 4R - 3 / 4R), FatRat, "1/4R - 3/4R is a FatRat");
#?pugs todo
isa_ok((1 / 4 - 3 / 4R), FatRat, "1/4 - 3/4R is a FatRat");
#?pugs todo
isa_ok((1 / 4R - 3 / 4), FatRat, "1/4R - 3/4 is a FatRat");
is(1 / 4R - 1, -3/4, "1/4R - 1 = -3/4R");
#?pugs todo
isa_ok(1 / 4R - 1, FatRat, "1/4R - 1 is a FatRat");
is(1 - 1 / 4R, 3/4, "1 - 1/4R = 3/4R");
#?pugs todo
isa_ok(1 - 1 / 4R, FatRat, "1 - 1/4R is a FatRat");

is((2 / 3R) * (5 / 4R), 5/6, "2/3R * 5/4R = 5/6");
#?pugs skip 'nude'
is(((2 / 3R) * (5 / 4R)).nude, (5, 6), "2/3R * 5/4R = 5/6 is simplified internally");
#?pugs todo
isa_ok((2 / 3R) * (5 / 4R), FatRat, "2/3R * 5/4R is a FatRat");
#?pugs todo
isa_ok((2 / 3) * (5 / 4R), FatRat, "2/3 * 5/4R is a FatRat");
#?pugs todo
isa_ok((2 / 3R) * (5 / 4), FatRat, "2/3R * 5/4 is a FatRat");
is((2 / 3R) * 2, 4/3, "2/3R * 2 = 4/3");
#?pugs todo
isa_ok((2 / 3R) * 2, FatRat, "2/3R * 2 is a FatRat");
#?pugs skip 'nude'
is(((2 / 3R) * 3).nude, (2, 1), "2R/3 * 3 = 2 is simplified internally");
is(2 * (2 / 3R), 4/3, "2 * 2/3R = 4/3");
#?pugs todo
isa_ok(2 * (2 / 3R), FatRat, "2 * 2/3R is a FatRat");
#?pugs skip 'nude'
is((3 * (2 / 3R)).nude, (2, 1), "3 * 2/3R = 2 is simplified internally");

is((2 / 3R) / (5 / 4R), 8/15, "2/3R / 5/4R = 8/15");
#?pugs todo
isa_ok((2 / 3R) / (5 / 4R), FatRat, "2/3R / 5/4R is a FatRat");
#?pugs todo
isa_ok((2 / 3) / (5 / 4R), FatRat, "2/3 / 5/4R is a FatRat");
#?pugs todo
isa_ok((2 / 3R) / (5 / 4), FatRat, "2/3R / 5/4 is a FatRat");
is((2 / 3R) / 2, 1/3, "2/3R / 2 = 1/3");
#?pugs skip 'nude'
is(((2 / 3R) / 2).nude, (1, 3), "2/3R / 2 = 1/3 is simplified internally");
#?pugs todo
isa_ok((2 / 3R) / 2, FatRat, "2/3R / 2 is a FatRat");
is(2 / (1 / 3R), 6, "2 / 1/3R = 6");
#?pugs todo
isa_ok(2 / (1 / 3R), FatRat, "2 / 1/3R is a FatRat");
#?pugs skip 'nude'
is((2 / (2 / 3R)).nude, (3, 1), "2 / 2/3R = 3 is simplified internally");

{
    # use numbers that can be exactly represented as floating points
    # so there's no need to use is_approx 

    my $a = 1/2R;
    is ++$a, 3/2, 'prefix:<++> on FatRats';
    is $a++, 3/2, 'postfix:<++> on FatRats (1)';
    is $a,   5/2, 'postfix:<++> on FatRats (2)';
    #?pugs todo
    isa_ok $a, FatRat, "and it's still a FatRat";
    $a = -15/8R;
    is ++$a, -7/8, 'prefix:<++> on negative FatRat';

    my $b = 5/2R;
    is --$b, 3/2, 'prefix:<--> on FatRats';
    is $b--, 3/2, 'postfix:<--> on FatRats (1)';
    is $b,   1/2, 'postfix:<--> on FatRats (2)';
    #?pugs todo
    isa_ok $b, FatRat, "and it's still a FatRat";
    $b = -15/8R;
    is --$b, -23/8, 'prefix:<--> on negative FatRat';
}

# Give the arithmetical operators a workout

for -1/4R, 2/7R, 65/8R / 10**100 -> $a {
    for -7, 0, 1, 5 -> $b {
        is_approx($a + $b, $a.Num + $b.Num, "FatRat + Int works ($a, $b)");
        is_approx($b + $a, $b.Num + $a.Num, "Int + FatRat works ($a, $b)");
        is_approx($a - $b, $a.Num - $b.Num, "FatRat - Int works ($a, $b)");
        is_approx($b - $a, $b.Num - $a.Num, "Int - FatRat works ($a, $b)");
        is_approx($a * $b, $a.Num * $b.Num, "FatRat * Int works ($a, $b)");
        is_approx($b * $a, $b.Num * $a.Num, "Int * FatRat works ($a, $b)");
        is_approx($a / $b, $a.Num / $b.Num, "FatRat / Int works ($a, $b)") if $b != 0;
        #?pugs skip 'one failure'
        is_approx($b / $a, $b.Num / $a.Num, "Int / FatRat works ($a, $b)");
    }

    for (1R/2**256, -4/5R) -> $b {
        is_approx($a + $b, $a.Num + $b.Num, "FatRat + FatRat works ($a, $b)");
        is_approx($b + $a, $b.Num + $a.Num, "FatRat + FatRat works ($a, $b)");
        is_approx($a - $b, $a.Num - $b.Num, "FatRat - FatRat works ($a, $b)");
        is_approx($b - $a, $b.Num - $a.Num, "FatRat - FatRat works ($a, $b)");
        is_approx($a * $b, $a.Num * $b.Num, "FatRat * FatRat works ($a, $b)");
        is_approx($b * $a, $b.Num * $a.Num, "FatRat * FatRat works ($a, $b)");
        is_approx($a / $b, $a.Num / $b.Num, "FatRat / FatRat works ($a, $b)");
        is_approx($b / $a, $b.Num / $a.Num, "FatRat / FatRat works ($a, $b)");
    }

    my $neg = -$a;
    #?pugs todo
    isa_ok($neg, FatRat, "prefix<-> geneFatRates a FatRat on $a");
    is_approx($neg, -($a.Num), "prefix<-> geneFatRates the correct number for $a");
}

# (note that trig on Rats is tested extensively in S32-trig but not trig on FatRats.  yet.)

is_approx sin(5.0e0), sin(10/2R), 'sin(FatRat) works';

# Quick test of some basic mixed type math

is_approx (1 / 2R) + 3.5e0, 4.0, "1/2R + 3.5 = 4.0";
is_approx 3.5e0 + (1 / 2R), 4.0, "3.5 + 1/2R = 4.0";
is_approx (1 / 2R) - 3.5e0, -3.0, "1/2R - 3.5 = -3.0";
is_approx 3.5e0 - (1 / 2R), 3.0, "3.5 - 1/2R = 3.0";
is_approx (1 / 3R) * 6.6e0, 2.2, "1/3R * 6.6 = 2.2";
is_approx 6.6e0 * (1 / 3R), 2.2, "6.6 * 1/3R = 2.2";
is_approx (1 / 3R) / 2.0e0, 1 / 6, "1/3R / 2.0 = 1/6";
is_approx 2.0e0 / (1 / 3R), 6.0, "2.0 / 1/3R = 6.0";

is_approx (1 / 2R) + 3.5e0 + 1i, 4.0 + 1i, "1/2R + 3.5 + 1i = 4.0 + 1i";
is_approx (3.5e0 + 1i) + (1 / 2R), 4.0 + 1i, "(3.5 + 1i) + 1/2R = 4.0 + 1i";
is_approx (1 / 2R) - (3.5e0 + 1i), -3.0 - 1i, "1/2R - (3.5 + 1i) = -3.0 - 1i";
is_approx (3.5e0 + 1i) - (1 / 2R), 3.0 + 1i, "(3.5 + 1i) - 1/2R = 3.0 + 1i";
is_approx (1 / 3R) * (6.6e0 + 1i), 2.2 + (1i/3), "1/3R * (6.6 + 1i) = 2.2 + (1/3)i";
is_approx (6.6e0 + 1i) * (1 / 3R), 2.2 + (1i/3), "(6.6 + 1i) * 1/3R = 2.2 + (1/3)i";
is_approx (1 / 3R) / 2.0i, 1 / (6.0i), "1/3R / 2.0i = 1/(6i)";
is_approx 2.0i / (1 / 3R), 6.0i, "2.0i / 1/3R = 6.0i";

# # Cast from Num uses an epsilon value.
# -- Off because we need to figure out the right way to do this
# is( exp(1).FatRat, FatRat.new(2721, 1001), "Num to FatRat with default epsilon");
# is( exp(1).FatRat(1e-4), FatRat.new(193, 71), "Num to FatRat with epsilon 1e-4");
# is( exp(1).FatRat(FatRat.new(1,1e4.Int)), FatRat.new(193, 71),
#     "Num to FatRat with epsilon of FatRat");

is (5/4R).Int,       1, 'FatRat.Int';
is <a b c>.[4/3R],  'b', 'Indexing an array with a FatRat';

ok (1/2R) == (1/2).FatRat, 'Rat.FatRat works';
#?pugs todo
isa_ok (1/2).FatRat, FatRat, '... and actually returns a FatRat';
ok (1/2R) == (1/2R).FatRat, 'FatRat.FatRat works';
#?pugs todo
isa_ok (1/2R).FatRat, FatRat, '... and actually returns a FatRat';

#?pugs 2 skip '===R'
ok 1/2R === 1/2R, 'FatRats are value types, so 1/2R === 1/2R';
ok 1/2R !=== 1/3R, '=== with false outcome';

#?rakudo skip 'FatRat arith + type objects'
{
    my FatRat $a;
    $a += 0.1 for ^10;
    ok $a == 1, 'can do += on variable initialized by type object';
    #?pugs todo
    isa_ok $a, FatRat, "and it's the correct type";
}

ok 16/5R eqv 16/5R, 'infix:<eqv> works with FatRats';

#?rakudo todo 'unknown'
#?pugs skip 'isa_ok'
isa_ok .88888888888R.WHAT.gist, '(FatRat)', 'WHAT works on FatRat created from 11 digit decimal fraction';

{
    my $a += 0.1R;
    #?pugs todo
    isa_ok $a, FatRat, 'Any() + 0.1R is a FatRat';
}

#?pugs todo
isa_ok (2/3R) ** 3, FatRat, "FatRat raised to a positive Int power is a FatRat";
is (2/3R) ** 3, 8/27, "FatRat raised to a positive Int power gets correct answer";


{
    my $epsilon = 0.5.FatRat ** 128;
    nok 1 - $epsilon == 1,   'infix:<==>(FatRat, Int) does not go through Num';
    nok 1 - $epsilon == 1.0, 'infix:<==>(FatRat, Rat) does not go through Num';
    ok  1 - $epsilon == 1 - $epsilon, 'infix:<==>(FatRat, FatRat) can return True too';
    ok  1 - $epsilon  < 1,   'FatRat < Int (+)';
    nok 1 + $epsilon  < 1,   'FatRat < Int (-)';
    ok  1 - $epsilon  < 1.0, 'FatRat < Rat (+)';
    nok 1 + $epsilon  < 1.0, 'FatRat < Rat (-)';
    ok  1 + $epsilon  > 1,   'FatRat > Int (+)';
    nok 1 - $epsilon  > 1.0, 'FatRat > Rat (+)';
    ok  1 + $epsilon  > 1.0, 'FatRat > Rat (+)';
    nok 1 - $epsilon  > 1,   'FatRat > Int (+)';
    ok  1 - $epsilon <= 1,   'FatRat <= Int (+)';
    nok 1 + $epsilon <= 1,   'FatRat <= Int (-)';
    ok  1 - $epsilon <= 1.0, 'FatRat <= Rat (+)';
    nok 1 + $epsilon <= 1.0, 'FatRat <= Rat (-)';
    ok  1 + $epsilon >= 1,   'FatRat >= Int (+)';
    nok 1 - $epsilon >= 1.0, 'FatRat >= Rat (+)';
    ok  1 + $epsilon >= 1.0, 'FatRat >= Rat (+)';
    nok 1 - $epsilon >= 1,   'FatRat >= Int (+)';

    #?pugs 3 skip 'Order:**'
    is 1 + $epsilon <=> 1 + $epsilon, Order::Same, '<=> Same';
    is 1 + $epsilon <=> 1,            Order::More, '<=> More';
    is 1 - $epsilon <=> 1,            Order::Less, '<=> Less';

}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/int.t�����������������������������������������������������������������0000664�0001750�0001750�00000011022�12224265625�016125� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 107;

# L<S32::Numeric/Real/=item truncate>
# truncate and .Int are synonynms.
# Possibly more tests for truncate should be added here, too.

=begin pod

Basic tests for the int() builtin

=end pod

# basic sanity:
is(-0, 0, '-0 is the same as 0 - hey, they are integers ;-)');

isa_ok( eval(1.perl), Int, 'eval 1.perl is Int' );
is( eval(1.perl), 1, 'eval 1.perl is 1' );
isa_ok( eval((-12).perl), Int, 'eval -12.perl is Int' );
is( eval((-12).perl), -12, 'eval -12.perl is -12' );
isa_ok( eval(0.perl), Int, 'eval 0.perl is Int' );
is( eval(0.perl), 0, 'eval 0.perl is 0' );
isa_ok( eval((-0).perl), Int, 'eval -0.perl is Int' );
is( eval((-0).perl), -0, 'eval -0.perl is 0' );

is((-1).Int, -1, "(-1).Int is -1");
is(0.Int, 0, "0.Int is 0");
is(1.Int, 1, "1.Int is 1");
is(3.14159265.Int, 3, "3.14159265.Int is 3");
is((-3.14159265).Int, -3, "(-3.14159265).Int is -3");

is(0.999.Int,   0, "0.999.Int is 0");
is(0.51.Int,    0, "0.51.Int is 0");
is(0.5.Int,     0, "0.5.Int is 0");
is(0.49.Int,    0, "0.49.Int is 0");
is(0.1.Int,     0, "0.1.Int is 0");
isa_ok(0.1.Int, Int, '0.1.Int returns an Int');

is((-0.999).Int, 0, "(-0.999).Int is 0");
is((-0.51).Int,  0, "(-0.51).Int is 0");
is((-0.5).Int,   0, "(-0.5).Int is 0");
is((-0.49).Int,  0, "(-0.49).Int is 0");
is((-0.1).Int,   0, "(-0.1).Int is 0");
isa_ok((-0.1).Int, Int, 'int(-0.1) returns an Int');

is(1.999.Int, 1, "int(1.999) is 1");
is(1.51.Int,  1, "int(1.51) is 1");
is(1.5.Int,   1, "int(1.5) is 1");
is(1.49.Int,  1, "int(1.49) is 1");
is(1.1.Int,   1, "int(1.1) is 1");

is((-1.999).Int, -1, "int(-1.999) is -1");
is((-1.51).Int, -1, "int(-1.51) is -1");
is((-1.5).Int, -1, "int(-1.5) is -1");
is((-1.49).Int, -1, "int(-1.49) is -1");
is((-1.1).Int, -1, "int(-1.1) is -1");

is(1.999.Num.Int, 1, "int(1.999.Num) is 1");
is(1.1.Num.Int,   1, "int(1.1.Num) is 1");

is((-1.999).Num.Int, -1, "int(-1.999.Num) is -1");
is((-1.1).Num.Int, -1, "int(-1.1.Num) is -1");

nok ?0, "?0 is false";
isa_ok ?0, Bool, "?0 is Bool";
ok ?1, "?1 is true";
isa_ok ?1, Bool, "?1 is Bool";
ok ?42, "?42 is true";
isa_ok ?42, Bool, "?42 is Bool";

nok 0.Bool, "0.Bool is false";
isa_ok 0.Bool, Bool, "0.Bool is Bool";
ok 1.Bool, "1.Bool is true";
isa_ok 1.Bool, Bool, "1.Bool is Bool";
ok 42.Bool, "42.Bool is true";
isa_ok 42.Bool, Bool, "42.Bool is Bool";

is('-1.999'.Int, -1, "int('-1.999') is -1");
#?niecza 3 skip "0x, 0d, and 0o NYI"
is('0x123'.Int, 0x123, "int('0x123') is 0x123");
is('0d456'.Int, 0d456, "int('0d456') is 0d456");
#?rakudo 2 skip "trailing characters produce failures"
is('0o678'.Int, 0o67, "int('0o678') is 0o67");
#?niecza skip "trailing d produces a failure"
is('3e4d5'.Int, 3e4, "int('3e4d5') is 3e4");

#?DOES 24
{
    sub __int( $s ) {
        my $pos = $s.index('.');
        if defined($pos) { return substr($s, 0, $pos); }
        return $s;
    };

    # Check the defaulting to $_

    for 0, 0.0, 1, 50, 60.0, 99.99, 0.4, 0.6, -1, -50, -60.0, -99.99 {
        my $int = __int($_.Num);
        #?pugs skip ".Int"
        is(.Int, $int, "integral value for $_ is $int");
        isa_ok(.Int, Int);
    }
}

#?DOES 1
# Special values
is((1.9e3).Int, 1900, "int 1.9e3 is 1900");
#?rakudo 2 todo 'Inf and NaN NYI for Int' 
#?pugs   3 todo 'Inf and NaN NYI for Int'
is((Inf).Int,    Inf, "int Inf is Inf");
is((-Inf).Int,  -Inf, "int -Inf is -Inf");
#?rakudo todo 'Inf and NaN NYI for Int'
#?rakudo.jvm skip 'Inf and NaN NYI for Int'
is((NaN).Int,    NaN, "int NaN is NaN");

# RT #65132
#?pugs todo
eval_dies_ok 'int 3.14', 'dies: int 3.14 (prefix:int is gone)';

#?pugs 10 skip 'lsb'
is 0.lsb,        Nil, "0.lsb is Nil";
is 1.lsb,        0,   "1.lsb is 0";
is 2.lsb,        1,   "2.lsb is 1";
is 256.lsb,      8,   "256.lsb is 8";
is (-1).lsb,     0,   "(-1).lsb is 0";       # 1111 1111
is (-2).lsb,     1,   "(-2).lsb is 1";       # 1111 1110
is (-126).lsb,   1,   "(-126).lsb is 1";     # 1000 0010
is (-127).lsb,   0,   "(-127).lsb is 0";     # 1000 0001
is (-128).lsb,   7,   "(-128).lsb is 7";     # 1000 0000
is (-32768).lsb, 15,  "(-32768).lsb is 15";

#?pugs 11 skip 'msb'
is 0.msb,        Nil, "0.msb is Nil";
is 1.msb,        0,   "1.msb is 0";
is 2.msb,        1,   "2.msb is 1";
is 256.msb,      8,   "256.msb is 8";
is (-1).msb,     0,   "(-1).msb is 0";       # 1111 1111
is (-2).msb,     1,   "(-2).msb is 1";       # 1111 1110
is (-126).msb,   7,   "(-126).msb is 7";     # 1000 0010
is (-127).msb,   7,   "(-127).msb is 7";     # 1000 0001
is (-128).msb,   7,   "(-128).msb is 7";     # 1000 0000
is (-129).msb,   8,   "(-129).msb is 8";
is (-32768).msb, 15,  "(-32768).msb is 15";

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/is-prime.t������������������������������������������������������������0000664�0001750�0001750�00000004055�12224265625�017070� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 35;

# L<S32::Numeric/Numeric/"=item is-prime">

=begin pod

Basic tests for the is-prime() builtin

=end pod

# I know the all the 45724385972894572891 tests seem repetitious, but 
# I am seeing inconsistent results on my Rakudo build, and I am hoping
# these repeated tests might help track it down.

nok 45724385972894572891.is-prime, "45724385972894572891 is not prime";
nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";
nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";
nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";

is (1..100).grep(*.is-prime), 
   (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97),
   "Method form gets primes < 100 correct";
is (1..100).grep({ is-prime($_) }), 
  (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97),
  "Sub form gets primes < 100 correct";

nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";
nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";
nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";
nok 45724385972894572891.is-prime, "45724385972894572891 is still not prime";

for (2801, 104743, 105517, 1300129, 15485867, 179424691, 32416187773) -> $prime {
    ok $prime.is-prime,  "$prime is a prime (method)";
    ok is-prime($prime), "$prime is a prime (sub)";
}

for (0, 32416187771, 32416187772, 32416187775) -> $composite {
    nok $composite.is-prime,  "$composite is not a prime (method)";
    nok is-prime($composite), "$composite is not a prime (sub)";
}

ok  170141183460469231731687303715884105727.is-prime, "170141183460469231731687303715884105727 is prime";
nok 170141183460469231731687303715884105725.is-prime, "170141183460469231731687303715884105725 is not prime";
ok 6864797660130609714981900799081393217269435300143305409394463459185543183397656052122559640661454554977296311391480858037121987999716643812574028291115057151.is-prime, "M13 is prime";�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/log.t�����������������������������������������������������������������0000664�0001750�0001750�00000004764�12224265625�016133� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 29;

=begin pod

Basic tests for the log() and log10() builtins

=end pod

my $log_5 = 940945/584642;
my $log_one_tenth = -254834/110673;
my $log10_5 = 49471/70777;
my $log10_one_tenth = -1;
my $pi = 312689/99532;

# L<S32::Numeric/Numeric/"=item log">

is_approx(log(5), $log_5, 'got the log of 5');
is_approx(log(0.1), $log_one_tenth, 'got the log of 0.1');

# with given base:
#?pugs 3 skip 'No compatible multi variant found: "&log"'
is_approx(log(8, 2), 3, 'log(8, 2) is 3'); 
is_approx(log(42, 23),  1.192051192, 'log(42, 23)');

# with non-Num
is_approx(log("42", "23"),  1.192051192, 'log(42, 23) with strings');

# L<S32::Numeric/Numeric/"=item log10">

is_approx(log10(5), $log10_5, 'got the log10 of 5');
is_approx(log10(0.1), $log10_one_tenth, 'got the log10 of 0.1');

is( log(0), -Inf, 'log(0) = -Inf');

is( log(Inf), Inf, 'log(Inf) = Inf');
is( log(-Inf), NaN, 'log(-Inf) = NaN');
is( log(NaN), NaN, 'log(NaN) = NaN');

is( log10(0), -Inf, 'log10(0) = -Inf');
is( log10(Inf), Inf, 'log10(Inf) = Inf');
is( log10(-Inf), NaN, 'log10(-Inf) = NaN');
is( log10(NaN), NaN, 'log10(NaN) = NaN');


# please add tests for complex numbers
#
# The closest I could find to documentation is here: http://tinyurl.com/27pj7c
# I use 1i instead of i since I don't know if a bare i will be supported

# log(exp(i pi)) = i pi log(exp(1)) = i pi
is_approx(log(-1 + 0i,), 0 + 1i * $pi, "got the log of -1");
is_approx(log10(-1 + 0i), 0 + 1i * $pi / log(10), "got the log10 of -1");

# log(exp(1+i pi)) = 1 + i pi
is_approx(log(-exp(1) + 0i), 1 + 1i * $pi, "got the log of -e");
is_approx(log10(-10 + 0i), 1 + 1i * $pi / log(10), "got the log10 of -10");
is_approx(log10(10), 1.0, 'log10(10)=1');

is_approx(log((1+1i) / sqrt(2)), 0 + 1i * $pi / 4, "got log of exp(i pi/4)");
is_approx(log(1i), 1i * $pi / 2, "got the log of i (complex unit)");

is_approx(log10(1i), 1i * $pi / (2*log(10)), 'got the log10 of i');
is_approx(log10((1+1i) / sqrt(2)), 0 + 1i * $pi / (4*log(10)), "got log10 of exp(i pi/4)");

is_approx(log(-1i), -0.5i * $pi , "got the log of -i (complex unit)");
is_approx(log10(-1i), -0.5i * $pi / log(10), "got the log10 of -i (complex unit)");

# TODO: please add more testcases for log10 of complex numbers

is_approx( (-1i).log10(), -0.5i*$pi / log(10), " (i).log10 = - i  * pi/(2 log(10))");
isa_ok( log10(-1+0i), Complex, 'log10 of a complex returns a complex, not a list');

#?rakudo todo 'HugeInt.log'
#?pugs todo
is_approx (10 ** 1000).log10, 1000, "Can take the log of very large Ints";

# vim: ft=perl6
������������rakudo-2013.12/t/spec/S32-num/pi.t������������������������������������������������������������������0000664�0001750�0001750�00000000761�12224265625�015753� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 4;

# L<S32::Numeric/Numeric/"Numeric provides some constants">

=begin pod

=head1 DESCRIPTION

Basic tests for builtin Num::pi

=end pod


# See also: L<"http://theory.cs.iitm.ernet.in/~arvindn/pi/"> :)
my $PI = 3.141592e0;

is_approx(eval("pi"), $PI, "pi imported by default");

#?pugs todo
eval_dies_ok("3 + pi()", "pi() is not a sub");

is_approx(eval("3 + pi"), $PI+3, "3+pi, as a bareword");

is_approx(eval("pi + 3"), $PI+3, "pi+3, as a bareword");

# vim: ft=perl6
���������������rakudo-2013.12/t/spec/S32-num/polar.t���������������������������������������������������������������0000664�0001750�0001750�00000003046�12224265625�016457� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 48;

# L<S32::Numeric/Complex/"=item polar">

=begin pod

#Basic tests for polar()

=end pod

my $sq2 = 2.sqrt;
sub check_polar($complex, $magnitude_want, $angle_want) {
   my ($magnitude, $angle) = $complex.polar;
   is_approx($magnitude, $magnitude_want, "$complex has a magnitude of $magnitude_want");
   is_approx($angle, $angle_want, "$complex has an angle of $angle_want");
}

# reference angles
{
   check_polar( 1+0i, 1   , 0         );
   check_polar( 1+1i, $sq2, pi/4      );
   check_polar( 0+1i, 1   , pi/2      );
   check_polar(-1+1i, $sq2, pi/4+pi/2 );
   check_polar(-1+0i, 1   , pi        );
   check_polar(-1-1i, $sq2, -pi+pi/4  );
   check_polar( 0-1i, 1   , -pi/2     );
   check_polar( 1-1i, $sq2, -pi/4     );
}

# ints
{
   check_polar( 4+0i, 4      , 0         );
   check_polar( 2+5i, 5.38516, 1.19028995);
   check_polar( 0+9i, 9      , pi/2      );
   check_polar(-3+2i, 3.60555, 2.55359005);
   check_polar(-9+0i, 9      , pi        );
   check_polar(-4-7i, 8.06226, -2.0899424);
   check_polar( 0-6i, 6      , -pi/2     );
   check_polar( 7-6i, 9.21954, -0.7086263);
}

# rats
{
   check_polar( 9.375+0i    , 9.375   , 0         );
   check_polar( 4.302+8.304i, 9.352198, 1.09280250);
   check_polar( 0+    2.631i, 2.631   , pi/2      );
   check_polar(-4.175+6.180i, 7.458085, 2.16493496);
   check_polar(-8.087+0i    , 8.087   , pi        );
   check_polar(-9.191-4.810i, 10.37355, -2.6594494);
   check_polar( 0-    0.763i, 0.763   , -pi/2     );
   check_polar( 9.927-5.192i, 11.20277, -0.4818920);
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/power.t���������������������������������������������������������������0000664�0001750�0001750�00000006653�12224265625�016505� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 52;

# Real **
is(0 ** 0,    1, "0 ** 0 ==  1");
is(0 ** 1,    0, "0 ** 1 ==  0");
is(1 ** 2,    1, "1 **  2 ==  1");
is(4 ** 0,    1, "4 **  0 ==  1");
is(4 ** 1,    4, "4 **  1 ==  4");
is(4 ** 2,   16, "4 **  2 == 16");

is 0 ** 4553535345364535345634543534, 0, "0 ** 4553535345364535345634543534 == 0";
is 1 ** 4553535345364535345634543534, 1, "1 ** 4553535345364535345634543534 == 1";
is 1e0 ** 4553535345364535345634543534, 1, "1e0 ** 4553535345364535345634543534 == 1";
isa_ok 1e0 ** 4553535345364535345634543534, Num, "1e0 ** 4553535345364535345634543534 is a Num";
#?rakudo.parrot 2 todo "Simple bigint optimizations NYI"
is (-1) ** 4553535345364535345634543534, 1, "-1 ** 4553535345364535345634543534 == 1";
is (-1) ** 4553535345364535345634543533, -1, "-1 ** 4553535345364535345634543534 == -1";
#?niecza skip "Slow and wrong"
#?pugs   skip "Slow and wrong"
is 2 ** 4553535345364535345634543534, Inf, "2 ** 4553535345364535345634543534 == Inf";
#?rakudo.parrot todo "Simple bigint optimizations NYI"
#?niecza 2 skip "Slow and wrong"
#?pugs   2 skip "Slow and wrong"
is (-2) ** 4553535345364535345634543534, Inf, "-2 ** 4553535345364535345634543534 == Inf";
is (-2) ** 4553535345364535345634543533, -Inf, "-2 ** 4553535345364535345634543534 == -Inf";

is(4 ** 0.5,  2, "4 ** .5 ==  2");
is(4 ** (1/2), 2, "4 ** (1/2) == 2 ");
is(4 ** (-1/2), 0.5, "4 ** (-1/2) == 1/2 ");
is((-2) ** 2, 4, "-2 ** 2 = 4");

#?niecza todo '#87'
is(1 ** Inf, 1, '1**Inf=1');
is(0 ** Inf, 0, '0**Inf=0');
#?pugs 2 todo
is(Inf ** 2, Inf, 'Inf**2 = Inf');
is((-Inf) ** 3, -Inf, '(-Inf)**3 = -Inf');
#?pugs skip 'hangs'
is(Inf ** Inf, Inf, 'Inf**Inf = Inf');
is(NaN ** 2, NaN, "NaN propagates with integer powers");
is(NaN ** 3.14, NaN, "NaN propagates with numeric powers");
is(0 ** NaN, NaN, "0**NaN=NaN");

# Not at all sure the next three cases are correct!

#?niecza 2 todo 'complex NaN stringy'
#?rakudo skip 'NaN**1i should be NaN'
is(NaN ** 1i, NaN, "NaN**1i=NaN");
#?rakudo skip '1i**NaN should be NaN'
is(1i ** NaN, NaN, "1i**NaN=NaN");
#?rakudo skip 'NaN**0 should be NaN'
is(NaN ** 0, NaN, "NaN**0=NaN");

is(NaN ** NaN, NaN, "NaN**NaN=NaN");
is(Inf ** NaN, NaN, "Inf**NaN=NaN");
is(NaN ** Inf, NaN, "NaN**Inf=NaN");

is_approx(exp(1) ** 0.5,  exp(0.5), "e **  .5 ==   exp(.5)");
is_approx(exp(1) ** 2.5,  exp(2.5), "e ** 2.5 ==  exp(2.5)");

# Complex ** Real
# These work by accident even if you don't have Complex **
is_approx((4 + 0i) ** 2, 4 ** 2, "(4+0i) ** 2 == 16");
#?pugs todo
is_approx(1i ** 4, 1, "i ** 4 == 1");
is_approx((4 + 0i) ** .5, 2, "(4+0i) ** .5 == 2");

#?pugs todo
is_approx(1i ** 2, -1, "i ** 2 == -1");
#?pugs todo
is_approx(1i ** 3, -1i, "i ** 3 == -i");
#?pugs todo
is_approx(5i ** 3, -125i, "5i ** 3 = -125i");
#?pugs todo
is_approx(3i ** 3, -27i, "3i ** 3 = -27i");
#?pugs todo
is_approx((-3i) ** 3, 27i, "-3i ** 3 = 27i");

#?rakudo skip 'i'
#?pugs skip 'i'
is_approx (-1) ** -i, 23.1406926327793, "(-1) ** -i is approx 23.1406926327793";

#?DOES 4
#?pugs skip '.roots'
{
    for (8i).roots(4) -> $z {
        is_approx($z ** 4, 8i, "quartic root of 8i ** 4 = 8i");
    }
}
#?DOES 1

# Real ** Complex
#?pugs todo
{
    is_approx(exp(1) ** (pi * 1i), -1, "e ** pi i = -1");
}

# Complex ** Complex
is_approx((4 + 0i) ** (2 + 0i), 4 ** 2, "(4+0i) ** (2+0i) == 16");

# Rat ** a large number
ok(1.015 ** 200 !~~ NaN, "1.015 ** 200 is not NaN");
is_approx(1.015 ** 200, 19.6430286394751, "1.015 ** 200 == 19.6430286394751");

done;

# vim: ft=perl6
�������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/rand.t����������������������������������������������������������������0000664�0001750�0001750�00000006100�12224265625�016260� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;
BEGIN { @*INC.push('t/spec/packages') };
use Test::Util;

plan 115;

=begin pod

Basic tests for the rand builtin

=end pod

# L<S32::Numeric/Numeric/"=item rand">

ok(rand >= 0, 'rand returns numbers greater than or equal to 0');
ok(rand < 1, 'rand returns numbers less than 1');

sub test_rand_range(Int $num) {
  for 1..20 {
    my $result = $num.rand;
    ok($num > $result >= 0, "rand returns numbers in [0, $num)");
  }
}

test_rand_range(2);
test_rand_range(3);
test_rand_range(5);
test_rand_range(7);
test_rand_range(11);

# L<S32::Numeric/Real/"=item srand">

lives_ok { srand(1) }, 'srand(1) lives and parses';

{
    my sub repeat_rand ($seed) {
        srand($seed);
        for 1..99 { rand; }
        return rand;
    }

    ok(repeat_rand(314159) == repeat_rand(314159),
        'srand() provides repeatability for rand');

    ok(repeat_rand(0) == repeat_rand(0),
        'edge case: srand(0) provides repeatability');

    ok(repeat_rand(0) != repeat_rand(1),
        'edge case: srand(0) not the same as srand(1)');
}

{
    my sub repeat_rand ($seed) {
        srand($seed);
        for 1..99 { rand; }
        return rand;
    }

    ok(repeat_rand(314159) == repeat_rand(314159),
        'srand(...) provides repeatability for rand');

    ok(repeat_rand(0) == repeat_rand(0),
        'edge case: srand(0) provides repeatability');

    ok(repeat_rand(0) != repeat_rand(1),
        'edge case: srand(0) not the same as srand(:seed(1))');
}

#?rakudo skip 'Test is too slow'
#?niecza skip 'Test is too slow'
# Similar code under Perl 5 runs in < 15s.
{
    srand;

    my $cells = 2 ** 16;                 # possible values from rand()
    my $samples = 500 * $cells;          # how many rand() calls we'll make
    my $freq_wanted = $samples / $cells; # ideal samples per cell
#    my @freq_observed[$cells];
    my @freq_observed;

    @freq_observed[ $cells.rand ]++ for 1 .. $samples;

    my $cs = 0;
    for @freq_observed -> $obsfreq {
        $cs += (($obsfreq // 0) - $freq_wanted) ** 2;
    }
    $cs /= $freq_wanted;

    my $badness = abs( 1 - $cs / ( $cells - 1 ) );

    # XXX: My confidence in this test is rather low.
    # I got the number below by running the same test repeatedly with Perl 5
    # and observing its results then again with deliberately corrupted
    # "results".  The value I picked is between the worst of the natural
    # results and the best of the b0rked results.
    # My hope is that someone who understands Chi Squared tests
    # better than I do will find what I've written easier to fix
    # than to write a good test from scratch.
    # The good news is it passes with Rakudo when I cut down on $samples
    # and wait a while.

    ok( $badness < 0.15, 'rand is pretty random' );
}

{
    # this catches if the random number generator is biased toward
    # smaller numbers in a range.
    my %h;
    %h{$_}++ for (^5).roll(1000);
    ok %h<3> + %h<4> > 300, "Distribution is not very uneven";
}

# RT #113968
#?niecza skip "throws_like"
#?DOES 4
{
    throws_like 'rand()', X::Obsolete;
    throws_like 'rand(3)', X::Obsolete;
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/rat.t�����������������������������������������������������������������0000664�0001750�0001750�00000033156�12224265625�016135� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 824;

# Basic test functions specific to rational numbers.

# Test ways of making Rats
#?pugs skip 'Must only use named arguments to new() constructor'
isa_ok(Rat.new(1,4), Rat, "Rat.new makes a Rat");
isa_ok(1 / 4, Rat, "/ makes a Rat");
isa_ok( 1.Int.Rat, Rat, "cast of Int makes a Rat");
isa_ok( 1.Num.Rat, Rat, "cast of Num makes a Rat");

#?niecza skip 'No value for parameter $n in CORE Rat.new'
isa_ok( Rat.new, Rat, 'Rat.new is Rat' );
#?niecza skip 'No value for parameter $n in CORE Rat.new'
#?pugs todo
isa_ok( eval(Rat.new.perl), Rat, 'eval Rat.new.perl is Rat' );
#?pugs 2 skip 'Must only use named arguments to new() constructor'
#?rakudo 4 todo '<1/3> literal should be Rat'
isa_ok( eval(Rat.new(1, 3).perl), Rat, 'eval Rat.new(1, 3).perl is Rat' );
is( (eval Rat.new(1, 3).perl), 1/3, 'eval Rat.new(1, 3).perl is 1/3' );
isa_ok( eval((1/3).perl), Rat, 'eval (1/3).perl is Rat' );
is( (eval (1/3).perl), 1/3, 'eval (1/3).perl is 1/3' );
#?pugs 3 todo 'tenths'
is( (1/10).perl, "0.1", '(1/10).perl is 0.1' );
is( (1/5).perl, "0.2", '(1/5).perl is .2' );
is( (1/2).perl, "0.5", '(1/2).perl is .5' );

# Test ~
#?pugs 4 skip 'Must only use named arguments to new() constructor'
is(~(Rat.new(1,4)), ~(0.25e0), "Rats stringify properly");
is(~(Rat.new(-1,2)), ~(-0.5e0), "Rats stringify properly");
is(~(Rat.new(7,4)), ~(1.75e0), "Rats stringify properly");
is(~(Rat.new(7,-1)), ~(-7), "Rats stringify properly");

# Test new
#?pugs 9 skip 'Must only use named arguments to new() constructor'
is(Rat.new(1, -7).nude, (-1, 7), "Negative signs move to numerator");
is(Rat.new(-32, -33).nude, (32, 33), "Double negatives cancel out");
is(Rat.new(2, 4).nude, (1, 2), "Reduce to simplest form in constructor");
is(Rat.new(39, 33).nude, (13, 11), "Reduce to simplest form in constructor");
is(Rat.new(0, 33).nude, (0, 1), "Reduce to simplest form in constructor");
is(Rat.new(1451234131, 60).nude, (1451234131, 60), "Reduce huge number to simplest form in constructor");
#?niecza skip 'Unable to resolve method nude in class Num'
is(Rat.new(1141234123, 0).nude, (1, 0), "Huge over zero becomes one over zero");
#?niecza skip 'Unable to resolve method nude in class Num'
is(Rat.new(-7, 0).nude, (-1, 0), "Negative over zero becomes negative one over zero");
#?niecza todo
dies_ok( { Rat.new(0, 0) }, "Zero over zero is not a legal Rat");

# Test basic math
is(1 / 4 + 1 / 4, 1/2, "1/4 + 1/4 = 1/2");
isa_ok(1 / 4 + 1 / 4, Rat, "1/4 + 1/4 is a Rat");
is(1 / 4 + 2 / 7, 15/28, "1/4 + 2/7 = 15/28");
is(1 / 4 + 1, 5/4, "1/4 + 1 = 5/4");
isa_ok(1 / 4 + 1, Rat, "1/4 + 1 is a Rat");
is(1 + 1 / 4, 5/4, "1 + 1/4 = 5/4");
isa_ok(1 + 1 / 4, Rat, "1 + 1/4 is a Rat");

is(1 / 4 - 1 / 4, 0/1, "1/4 - 1/4 = 0/1");
is(1 / 4 - 3 / 4, -1/2, "1/4 - 3/4 = -1/2");
#?pugs skip '.nude'
is((1 / 4 - 3 / 4).nude, (-1, 2), "1/4 - 3/4 = -1/2 is simplified internally");
isa_ok((1 / 4 - 3 / 4), Rat, "1/4 - 3/4 is a Rat");
is(1 / 4 - 1, -3/4, "1/4 - 1 = -3/4");
isa_ok(1 / 4 - 1, Rat, "1/4 - 1 is a Rat");
is(1 - 1 / 4, 3/4, "1 - 1/4 = 3/4");
isa_ok(1 - 1 / 4, Rat, "1 - 1/4 is a Rat");

is((2 / 3) * (5 / 4), 5/6, "2/3 * 5/4 = 5/6");
#?pugs skip '.nude'
is(((2 / 3) * (5 / 4)).nude, (5, 6), "2/3 * 5/4 = 5/6 is simplified internally");
isa_ok((2 / 3) * (5 / 4), Rat, "2/3 * 5/4 is a Rat");
is((2 / 3) * 2, 4/3, "2/3 * 2 = 4/3");
isa_ok((2 / 3) * 2, Rat, "2/3 * 2 is a Rat");
#?pugs skip '.nude'
is(((2 / 3) * 3).nude, (2, 1), "2/3 * 3 = 2 is simplified internally");
is(2 * (2 / 3), 4/3, "2 * 2/3 = 4/3");
isa_ok(2 * (2 / 3), Rat, "2 * 2/3 is a Rat");
#?pugs skip '.nude'
is((3 * (2 / 3)).nude, (2, 1), "3 * 2/3 = 2 is simplified internally");

is((2 / 3) / (5 / 4), 8/15, "2/3 / 5/4 = 8/15");
isa_ok((2 / 3) / (5 / 4), Rat, "2/3 / 5/4 is a Rat");
is((2 / 3) / 2, 1/3, "2/3 / 2 = 1/3");
#?pugs skip '.nude'
is(((2 / 3) / 2).nude, (1, 3), "2/3 / 2 = 1/3 is simplified internally");
isa_ok((2 / 3) / 2, Rat, "2/3 / 2 is a Rat");
is(2 / (1 / 3), 6, "2 / 1/3 = 6");
isa_ok(2 / (1 / 3), Rat, "2 / 1/3 is a Rat");
#?pugs skip '.nude'
is((2 / (2 / 3)).nude, (3, 1), "2 / 2/3 = 3 is simplified internally");

{
    # use numbers that can be exactly represented as floating points
    # so there's no need to use is_approx 

    my $a = 1/2;
    is ++$a, 3/2, 'prefix:<++> on Rats';
    is $a++, 3/2, 'postfix:<++> on Rats (1)';
    is $a,   5/2, 'postfix:<++> on Rats (2)';
    $a = -15/8;
    is ++$a, -7/8, 'prefix:<++> on negative Rat';

    my $b = 5/2;
    is --$b, 3/2, 'prefix:<--> on Rats';
    is $b--, 3/2, 'postfix:<--> on Rats (1)';
    is $b,   1/2, 'postfix:<--> on Rats (2)';
    $b = -15/8;
    is --$b, -23/8, 'prefix:<--> on negative Rat';
}

# Give the arithmetical operators a workout

{
    for 1/2, 2/3, -1/4, 4/5, 2/7, 65/8 -> $a {
        for -7, -1, 0, 1, 2, 5, 7, 42 -> $b {
            is_approx($a + $b, $a.Num + $b.Num, "Rat + Int works ($a, $b)");
            is_approx($b + $a, $b.Num + $a.Num, "Int + Rat works ($a, $b)");
            is_approx($a - $b, $a.Num - $b.Num, "Rat - Int works ($a, $b)");
            is_approx($b - $a, $b.Num - $a.Num, "Int - Rat works ($a, $b)");
            is_approx($a * $b, $a.Num * $b.Num, "Rat * Int works ($a, $b)");
            is_approx($b * $a, $b.Num * $a.Num, "Int * Rat works ($a, $b)");
            is_approx($a / $b, $a.Num / $b.Num, "Rat / Int works ($a, $b)") if $b != 0;
            is_approx($b / $a, $b.Num / $a.Num, "Int / Rat works ($a, $b)");
        }

        for (1/2, 2/3, -1/4, 4/5, 2/7, 65/8) -> $b {
            is_approx($a + $b, $a.Num + $b.Num, "Rat + Rat works ($a, $b)");
            is_approx($b + $a, $b.Num + $a.Num, "Rat + Rat works ($a, $b)");
            is_approx($a - $b, $a.Num - $b.Num, "Rat - Rat works ($a, $b)");
            is_approx($b - $a, $b.Num - $a.Num, "Rat - Rat works ($a, $b)");
            is_approx($a * $b, $a.Num * $b.Num, "Rat * Rat works ($a, $b)");
            is_approx($b * $a, $b.Num * $a.Num, "Rat * Rat works ($a, $b)");
            is_approx($a / $b, $a.Num / $b.Num, "Rat / Rat works ($a, $b)");
            is_approx($b / $a, $b.Num / $a.Num, "Rat / Rat works ($a, $b)");
        }

        my $neg = -$a;
        isa_ok($neg, Rat, "prefix<-> generates a Rat on $a");
        is_approx($neg, -($a.Num), "prefix<-> generates the correct number for $a");
    }
}

#pugs needs a reset here...
#?DOES 1 

# used to be a (never ticketed) Rakudo bug: sin(Rat) died
# (note that trig on Rats is tested extensively in S32-trig)

is_approx sin(5.0e0), sin(10/2), 'sin(Rat) works';

# SHOULD: Add zero denominator tests
# Added three constructor tests above.  Unsure about the
# wisdom of allowing math with zero denominator Rats,
# so I'm holding off on writing tests for it.

# there are a few division by zero tests in S03-operator/div.t

#?niecza todo
#?pugs todo 'NaN.Rat'
is NaN.Rat, NaN, "NaN.Rat == NaN";

{
    #?pugs todo 'Inf.Rat'
    #?niecza todo
    is Inf.Rat, Inf, "Inf.Rat == Inf";
    #?pugs todo 'Inf.Rat'
    #?niecza todo
    is (-Inf).Rat, -Inf, "(-Inf).Rat == -Inf";

    # RT #74648
    #?rakudo skip 'RT 74648'
    #?niecza todo
    isa_ok Inf.Int / 1, Rat, "Inf.Int / 1 is a Rat";
}

# Quick test of some basic mixed type math

is_approx (1 / 2) + 3.5e0, 4.0, "1/2 + 3.5 = 4.0";
is_approx 3.5e0 + (1 / 2), 4.0, "3.5 + 1/2 = 4.0";
is_approx (1 / 2) - 3.5e0, -3.0, "1/2 - 3.5 = -3.0";
is_approx 3.5e0 - (1 / 2), 3.0, "3.5 - 1/2 = 3.0";
is_approx (1 / 3) * 6.6e0, 2.2, "1/3 * 6.6 = 2.2";
is_approx 6.6e0 * (1 / 3), 2.2, "6.6 * 1/3 = 2.2";
is_approx (1 / 3) / 2.0e0, 1 / 6, "1/3 / 2.0 = 1/6";
is_approx 2.0e0 / (1 / 3), 6.0, "2.0 / 1/3 = 6.0";

is_approx (1 / 2) + 3.5e0 + 1i, 4.0 + 1i, "1/2 + 3.5 + 1i = 4.0 + 1i";
is_approx (3.5e0 + 1i) + (1 / 2), 4.0 + 1i, "(3.5 + 1i) + 1/2 = 4.0 + 1i";
is_approx (1 / 2) - (3.5e0 + 1i), -3.0 - 1i, "1/2 - (3.5 + 1i) = -3.0 - 1i";
is_approx (3.5e0 + 1i) - (1 / 2), 3.0 + 1i, "(3.5 + 1i) - 1/2 = 3.0 + 1i";
is_approx (1 / 3) * (6.6e0 + 1i), 2.2 + (1i/3), "1/3 * (6.6 + 1i) = 2.2 + (1/3)i";
is_approx (6.6e0 + 1i) * (1 / 3), 2.2 + (1i/3), "(6.6 + 1i) * 1/3 = 2.2 + (1/3)i";
is_approx (1 / 3) / 2.0i, 1 / (6.0i), "1/3 / 2.0i = 1/(6i)";
is_approx 2.0i / (1 / 3), 6.0i, "2.0i / 1/3 = 6.0i";

# Cast from Num uses an epsilon value.
#?pugs 3 skip 'Must only use named arguments to new() constructor'
is( exp(1).Rat, Rat.new(2721, 1001), "Num to Rat with default epsilon");
is( exp(1).Rat(1e-4), Rat.new(193, 71), "Num to Rat with epsilon 1e-4");
is( exp(1).Rat(Rat.new(1,1e4.Int)), Rat.new(193, 71),
    "Num to Rat with epsilon of Rat");

is (5/4).Int,       1, 'Rat.Int';
is <a b c>.[4/3],  'b', 'Indexing an array with a Rat (RT 69738)';

is_approx 424/61731 + 832/61731, 424.Num / 61731.Num + 832.Num / 61731.Num, "424/61731 + 832/61731 works";
is_approx 424/61731 - 832/61731, 424.Num / 61731.Num - 832.Num / 61731.Num, "424/61731 - 832/61731 works";
is_approx 424/61731 + 833/123462, 424.Num / 61731.Num + 833.Num / 123462.Num, "424/61731 + 833/123462 works";
is_approx 424/61731 - 833/123462, 424.Num / 61731.Num - 833.Num / 123462.Num, "424/61731 - 833/123462 works";

isa_ok 424/61731 + 832/61731, Rat, "424/61731 + 832/61731 is a Rat";
isa_ok 424/61731 - 832/61731, Rat, "424/61731 - 832/61731 is a Rat";
isa_ok 424/61731 + 833/123462, Rat, "424/61731 + 833/123462 is a Rat";
isa_ok 424/61731 - 833/123462, Rat, "424/61731 - 833/123462 is a Rat";

is_approx 61731 + 832/61731, 61731.Num + 832.Num / 61731.Num, "61731 + 832/61731 works";
is_approx 832/61731 + 61731, 61731.Num + 832.Num / 61731.Num, "832/61731 + 61731 works";
is_approx 61731 - 832/61731, 61731.Num - 832.Num / 61731.Num, "61731 - 832/61731 works";
is_approx 832/61731 - 61731, 832.Num / 61731.Num - 61731.Num, "832/61731 - 61731 works";

is_approx 424/61731 + 832/61733, 424.Num / 61731.Num + 832.Num / 61733.Num, "424/61731 + 832/61733 works";
is_approx 424/61731 - 832/61733, 424.Num / 61731.Num - 832.Num / 61733.Num, "424/61731 - 832/61733 works";

is_approx (424/61731) * (832/61731), (424.Num / 61731.Num) * (832.Num / 61731.Num), "424/61731 * 832/61731 works";
is_approx (424/61731) / (61731/832), (424.Num / 61731.Num) / (61731.Num / 832.Num), "424/61731 / 61731/832 works";

is_approx 61731 * (61731/832), 61731.Num * (61731.Num / 832.Num), "61731 * 61731/832 works";
is_approx (61731/832) * 61731, 61731.Num * (61731.Num / 832.Num), "61731/832 * 61731 works";
is_approx (832/61731) / 61731, (832.Num / 61731.Num) / 61731.Num, "832/61731 / 61731 works";
is_approx 61731 / (832/61731), 61731.Num / (832.Num / 61731.Num), "61731 / 832/61731 works";

is_approx (424/61731) * (61731/61733), (424.Num / 61731.Num) * (61731.Num / 61733.Num), "424/61731 * 61731/61733 works";
isa_ok (424/61731) * (61731/61733), Rat, "424/61731 * 61731/61733 is a Rat";
is_approx (424/61731) / (61733/61731), (424.Num / 61731.Num) / (61733.Num / 61731.Num), "424/61731 / 61733/61731 works";
isa_ok (424/61731) / (61733/61731), Rat, "424/61731 / 61733/61731 is a Rat";

ok (1/2) == (1/2).Rat, 'Rat.Rat works';
isa_ok (1/2).Rat, Rat, '... and actually returns a Rat';

ok 1/2 === 1/2, 'Rats are value types, so 1/2 === 1/2';
ok 1/2 !=== 1/3, '=== with false outcome';

# http://irclog.perlgeek.de/perl6/2010-02-24#i_2027452
#?pugs 2 skip 'Illegal division by zero'
is (3/0).Num, Inf, "(3/0).Num = +Inf";
is (-42/0).Num, -Inf, "(-42/0).Num = -Inf";

#?niecza skip 'No value for parameter $n in CORE Rat.new'
#?pugs skip 'Cannot cast from VObject to Double'
ok Rat.new() == 0, 'Rat.new() is 0';

{
    my Rat $a;
    $a += 0.1 for ^10;
    ok $a == 1, 'can do += on variable initialized by type object';
}

ok 16/5 eqv 16/5, 'infix:<eqv> works with rats';

# RT #72870
is .88888888888.WHAT.gist, Rat.gist, 'WHAT works on Rat created from 11 digit decimal fraction';

# RT #74624
{
    my $a += 0.1;
    isa_ok $a, Rat, 'Any() + 0.1 is a Rat';
}

isa_ok (2/3) ** 3, Rat, "Rat raised to a positive Int power is a Rat";
is (2/3) ** 3, 8/27, "Rat raised to a positive Int power gets correct answer";

# the spec says that Rat denominators can't grow larger than a uint64,
# and arithmetic operations need to spill over to Num
{
    # taken from http://www.perlmonks.org/?node_id=952765
    my $s = 0;
    for 1..1000 {
        $s += 1/$_**2
    };
    is_approx $s, 1.64393456668156, 'can sum up 1/$_**2 in a loop';
    isa_ok $s, Num, 'and we had an overflow to Num';
    my $bigish = 2 ** 34;
    my $bigish_n = $bigish.Num;
    # TODO: not just check the type of the results, but also the numeric value
    isa_ok (1/$bigish) * (1/$bigish),       Num, 'multiplication overflows to Num';
    is_approx (1/$bigish) * (1/$bigish), (1/$bigish_n) * (1/$bigish_n), '... right result';
    isa_ok (1/$bigish) ** 2,                Num, 'exponentation overflows to Num';
    is_approx (1/$bigish) ** 2, (1/$bigish_n) ** 2, '... right result';
    is_approx (1/$bigish) * (1/$bigish), (1/$bigish_n) * (1/$bigish_n), '... right result';
    isa_ok (1/$bigish) + (1 / ($bigish+1)), Num, 'addition overflows to Num';
    is_approx (1/$bigish) + (1/($bigish+1)), (1/$bigish_n) + (1/($bigish_n+1)), '... right result';
    isa_ok (1/$bigish) - (1 / ($bigish+1)), Num, 'subtraction overflows to Num';
    is_approx (1/$bigish) - (1/($bigish+1)), (1/$bigish_n) - (1/($bigish_n+1)), '... right result';
    isa_ok (1/$bigish) / (($bigish+1)/3),   Num, 'division overflows to Num';
    is_approx (1/$bigish) / (($bigish+1)/3), (1/$bigish_n) / (($bigish_n+1)/3), '... right result';

}

#?pugs skip 'Must only use named arguments to new() constructor'
is Rat.new(9,33).norm.nude, (3, 11), ".norm exists and doesn't hurt matters";

isa_ok 241025348275725.3352, Rat, "241025348275725.3352 is a Rat";
#?pugs skip 'No such method in class Rat: "&norm"'
is 241025348275725.3352.Rat.norm.nude, (301281685344656669, 1250), "Rat.Rat yields correct Rat";

#RT #112822
#?pugs skip 'No such method in class Rat: "&norm"'
is 241025348275725.3352.Str, "241025348275725.3352", 'stringification of bigish Rats';

done;

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/real-bridge.t���������������������������������������������������������0000664�0001750�0001750�00000026253�12237474612�017526� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 200;

=begin pod

Basic tests easily defining a Real type

=end pod

class Fixed2 does Real {
    has Int $.one-hundredths;

    multi method new(Int $a) {
        self.bless(:one-hundredths($a * 100));
    }

    multi method new(Rat $a) {
        self.bless(:one-hundredths(floor($a * 100)));
    }

    method Bridge() {
        $.one-hundredths.Bridge / 100.Bridge;
    }
}

my $zero = Fixed2.new(0);
my $one = Fixed2.new(1);
my $one-and-one-hundredth = Fixed2.new(1.01);
my $one-and-ninety-nine-hundredths = Fixed2.new(1.99);  
my $three = Fixed2.new(3);
my $ten = Fixed2.new(10);
my $neg-pi = Fixed2.new(-3.14);

isa_ok $zero, Fixed2, "Fixed2 sanity test";
isa_ok $one, Fixed2, "Fixed2 sanity test";
isa_ok $one-and-one-hundredth, Fixed2, "Fixed2 sanity test";
isa_ok $neg-pi, Fixed2, "Fixed2 sanity test";
ok $zero ~~ Real, "Fixed2 sanity test";
ok $one ~~ Real, "Fixed2 sanity test";
ok $one-and-one-hundredth ~~ Real, "Fixed2 sanity test";
ok $neg-pi ~~ Real, "Fixed2 sanity test";

is_approx $zero.succ, 1, "0.succ works";
is_approx $neg-pi.succ, -2.14, "(-3.14).succ works";
is_approx $zero.pred, -1, "0.pred works";
is_approx $neg-pi.pred, -4.14, "(-3.14).pred works";

{
    my $i = $zero.Bool;
    isa_ok $i, Bool, "0.Bool is an Bool";
    is $i, Bool::False, "0.Bool is False";
    
    $i = $one-and-ninety-nine-hundredths.Bool;
    isa_ok $i, Bool, "1.99.Bool is an Bool";
    is $i, Bool::True, "1.99.Bool is True";
}

{
    my $i = $neg-pi.Int;
    isa_ok $i, Int, "-3.14.Int is an Int";
    is $i, -3, "-3.14.Int is -3";
    
    $i = $one-and-ninety-nine-hundredths.Int;
    isa_ok $i, Int, "1.99.Int is an Int";
    is $i, 1, "1.99.Int is 1";
}

{
    my $i = $neg-pi.Rat;
    isa_ok $i, Rat, "-3.14.Rat is an Rat";
    is_approx $i, -3.14, "-3.14.Rat is -3.14";
    
    $i = $one-and-ninety-nine-hundredths.Rat;
    isa_ok $i, Rat, "1.99.Rat is an Rat";
    is_approx $i, 1.99, "1.99.Rat is 1.99";
}

{
    my $i = $neg-pi.Num;
    isa_ok $i, Num, "-3.14.Num is an Num";
    is_approx $i, -3.14, "-3.14.Num is -3.14";
    
    $i = $one-and-ninety-nine-hundredths.Num;
    isa_ok $i, Num, "1.99.Num is an Num";
    is_approx $i, 1.99, "1.99.Num is 1.99";
}

{
    my $s = $one-and-ninety-nine-hundredths.Str;
    isa_ok $s, Str, "1.99.Str is a Str";
    is $s, "1.99", '1.99.Str is "1.99"';

    $s = $neg-pi.Str;
    isa_ok $s, Str, "-3.14.Str is a Str";
    is $s, "-3.14", '-3.14.Str is "-3.14"';
}

is_approx $zero.abs, 0, "0.abs works";
ok $zero.abs ~~ Real, "0.abs produces a Real";
is_approx $one.abs, 1, "1.abs works";
ok $one.abs ~~ Real, "1.abs produces a Real";
is_approx $one-and-one-hundredth.abs, 1.01, "1.01.abs works";
ok $one-and-one-hundredth.abs ~~ Real, "1.01.abs produces a Real";
is_approx $neg-pi.abs, 3.14, "-3.14.abs works";
ok $neg-pi.abs ~~ Real, "-3.14.abs produces a Real";

is_approx $zero.sign, 0, "0.sign works";
is_approx $one.sign, 1, "1.sign works";
is_approx $one-and-one-hundredth.sign, 1, "1.01.sign works";
is_approx $neg-pi.sign, -1, "-3.14.sign works";

is $zero <=> 0, Same, "0 <=> 0 is Same";
is $one <=> 0.Num, More, "1 <=> 0 is More";
is $one-and-one-hundredth <=> 1.1, Less, "1.01 <=> 1.1 is Less";
is $neg-pi <=> -3, Less, "-3.14 <=> -3 is Less";
is -1 <=> $zero, Less, "-1 <=> 0 is Less";
is 1.Rat <=> $one, Same, "1 <=> 1 is Same";
is 1.001 <=> $one-and-one-hundredth, Less, "1.001 <=? 1.01 is Less";
is $neg-pi <=> -3.14, Same, "-3.14 <=> -3.14 is Same";

nok $zero < 0, "not 0 < 0";
nok $one < 0.Num, "not 1 < 0";
ok $one-and-one-hundredth < 1.1, "1.01 < 1.1";
ok $neg-pi < -3, "-3.14 < -3";
ok -1 < $zero, "-1 < 0";
nok 1.Rat < $one, "not 1 < 1";
ok 1.001 < $one-and-one-hundredth, "1.001 < 1.01";
nok $neg-pi < -3.14, "not -3.14 < -3.14";

ok $zero <= 0, "0 <= 0";
nok $one <= 0.Num, "not 1 <= 0";
ok $one-and-one-hundredth <= 1.1, "1.01 <= 1.1";
ok $neg-pi <= -3, "-3.14 <= -3";
ok -1 <= $zero, "-1 <= 0";
ok 1.Rat <= $one, "1 <= 1";
ok 1.001 <= $one-and-one-hundredth, "1.001 <= 1.01";
ok $neg-pi <= -3.14, "-3.14 <= -3.14";

nok $zero > 0, "not 0 > 0";
ok $one > 0.Num, "1 > 0";
nok $one-and-one-hundredth > 1.1, "not 1.01 > 1.1";
nok $neg-pi > -3, "not -3.14 > -3";
nok -1 > $zero, "not -1 > 0";
nok 1.Rat > $one, "not 1 > 1";
nok 1.001 > $one-and-one-hundredth, "not 1.001 > 1.01";
nok $neg-pi > -3.14, "not -3.14 > -3.14";

ok $zero >= 0, "0 >= 0";
ok $one >= 0.Num, "1 >= 0";
nok $one-and-one-hundredth >= 1.1, "not 1.01 >= 1.1";
nok $neg-pi >= -3, "not -3.14 >= -3";
nok -1 >= $zero, "not -1 >= 0";
ok 1.Rat >= $one, "1 >= 1";
nok 1.001 >= $one-and-one-hundredth, "not 1.001 >= 1.01";
ok $neg-pi >= -3.14, "-3.14 >= -3.14";

ok $zero == 0, "0 == 0";
nok $one == 0.Num, "not 1 == 0";
nok $one-and-one-hundredth == 1.1, "not 1.01 == 1.1";
nok $neg-pi == -3, "not -3.14 == -3";
nok -1 == $zero, "not -1 == 0";
ok 1.Rat == $one, "1 == 1";
nok 1.001 == $one-and-one-hundredth, "not 1.001 == 1.01";
ok $neg-pi == -3.14, "-3.14 == -3.14";

# bonus round!
isa_ok $zero.Complex, Complex, "0.Complex is a Complex";
ok $zero == $zero.Complex, "0 == 0.Complex";
ok $neg-pi == $neg-pi.Complex, "-3.14 == -3.14.Complex";
ok $neg-pi == -3.14.Complex, "-3.14 == -3.14.Complex";
ok -3.14 == $neg-pi.Complex, "-3.14 == -3.14.Complex";
nok $zero == $neg-pi.Complex, "not 0 == -3.14.Complex";

nok $zero != 0, "not 0 != 0";
ok $one != 0.Num, "1 != 0";
ok $one-and-one-hundredth != 1.1, "1.01 != 1.1";
ok $neg-pi != -3, "-3.14 != -3";
ok -1 != $zero, "-1 != 0";
nok 1.Rat != $one, "not 1 != 1";
ok 1.001 != $one-and-one-hundredth, "1.001 != 1.01";
nok $neg-pi != -3.14, "not -3.14 != -3.14";

# bonus round!
nok $zero != $zero.Complex, "not 0 != 0.Complex";
nok $neg-pi != $neg-pi.Complex, "not -3.14 != -3.14.Complex";
nok $neg-pi != -3.14.Complex, "not -3.14 != -3.14.Complex";
nok -3.14 != $neg-pi.Complex, "not -3.14 != -3.14.Complex";
ok $zero != $neg-pi.Complex, "0 != -3.14.Complex";

is $zero cmp 0, Same, "0 cmp 0 is Order::Same";
is $one cmp 0.Num, More, "1 cmp 0 is Order::More";
is $one-and-one-hundredth cmp 1.1, Less, "1.01 cmp 1.1 is Order::Less";
is $neg-pi cmp -3, Less, "-3.14 cmp -3 is Order::Less";
is -1 cmp $zero, Less, "-1 cmp 0 is Order::Less";
is 1.Rat cmp $one, Same, "1 cmp 1 is Order::Same";
is 1.001 cmp $one-and-one-hundredth, Less, "1.001 cmp 1.01 is Order::Less";
is $neg-pi cmp -3.14, Same, "-3.14 cmp -3.14 is Order::Same";

nok $zero before 0, "not 0 before 0";
nok $one before 0.Num, "not 1 before 0";
ok $one-and-one-hundredth before 1.1, "1.01 before 1.1";
ok $neg-pi before -3, "-3.14 before -3";
ok -1 before $zero, "-1 before 0";
nok 1.Rat before $one, "not 1 before 1";
ok 1.001 before $one-and-one-hundredth, "1.001 before 1.01";
nok $neg-pi before -3.14, "not -3.14 before -3.14";

nok $zero after 0, "not 0 after 0";
ok $one after 0.Num, "1 after 0";
nok $one-and-one-hundredth after 1.1, "not 1.01 after 1.1";
nok $neg-pi after -3, "not -3.14 after -3";
nok -1 after $zero, "not -1 after 0";
nok 1.Rat after $one, "not 1 after 1";
nok 1.001 after $one-and-one-hundredth, "not 1.001 after 1.01";
nok $neg-pi after -3.14, "not -3.14 after -3.14";

is_approx -$zero, 0, "-0 == 0";
is_approx -$one, -1, "-1 == -1";
is_approx -$one-and-one-hundredth, -1.01, "-1.01 == -1.01";
is_approx -$neg-pi, 3.14, "-(-3.14) == 3.14";

is $one + $one, 2, "1 + 1 == 2";
is $one + -1, 0, "1 + -1 == 0";
is $one-and-one-hundredth + $one-and-one-hundredth, 2.02, "1.01 + 1.01 == 2.02";
is_approx 1.01 + -$one, 0.01, "1.01 + -1 == 0.01";
is_approx $one-and-one-hundredth + 1.Num, 2.01, "1.01 + 1 == 2.01";

is $one - $one, 0, "1 - 1 == 0";
is $one - 1, 0, "1 - 1 == 0";
is $one-and-one-hundredth - $one-and-one-hundredth, 0, "1.01 - 1.01 == 0";
is $one-and-one-hundredth - 1.01, 0, "1.01 - 1.01 == 0";
is_approx 1.01 - $one, 0.01, "1.01 - 1 == 0.01";
is_approx $one-and-one-hundredth - 1.Num, 0.01, "1.01 - 1 == 0.01";

is_approx $one * $one, $one, "1 * 1 == 1";
is_approx $one * 1, $one, "1 * 1 == 1";
is_approx $one-and-one-hundredth * $one, 1.01, "1.01 * 1 == 1.01";
is_approx -1 * $neg-pi, 3.14, "-1 * -3.14 == 3.14";
is_approx $one-and-one-hundredth * 2.Num, 2.02, "1.01 * 2 == 2.02";

is_approx $one / $one, $one, "1 / 1 == 1";
is_approx $one / 1, $one, "1 / 1 == 1";
is_approx $one-and-one-hundredth / $one, 1.01, "1.01 / 1 == 1.01";
is_approx -1 / $neg-pi, 1 / 3.14, "-1 / -3.14 == 1 / 3.14";
is_approx $neg-pi / 2.Num, -1.57, "-3.14 / 2 == -1.57";

is_approx $one % $one, $zero, "1 % 1 == 0";
is_approx $ten % $three, $one, "10 % 3 == 1";
is_approx $one-and-ninety-nine-hundredths % $one-and-one-hundredth, 0.98, "1.99 % 1.01 = 0.98";
is_approx 10 % $one-and-ninety-nine-hundredths, 0.05, "10 % 1.99 = 0.05";
is_approx $one-and-one-hundredth % 0.2, 0.01, "1.01 % 0.2 = 0.01";

is_approx $one-and-one-hundredth.log, 1.01.log, "1.01.log is correct";
is_approx log($one-and-one-hundredth), 1.01.log, "log(1.01) is correct";
is_approx $one-and-one-hundredth.log($ten), 1.01.log10, "1.01.log(10) is correct";
is_approx log($one-and-one-hundredth, $ten), 1.01.log10, "log(1.01, 10) is correct";
is_approx $one-and-one-hundredth.log($ten * 1i), 1.01.log / log(10i), "1.01.log(10i) is correct";
is_approx ($one-and-one-hundredth * 1i).log($ten), log(1.01i) / log(10), "1.01i.log(10) is correct";

is_approx $one-and-one-hundredth.cis, 1.01.cis, "1.01.cis is correct";
is_approx cis($one-and-one-hundredth), 1.01.cis, "cis(1.01) is correct";
is_approx $one-and-one-hundredth.unpolar($neg-pi), 1.01.unpolar(-3.14), "1.01.unpolar(-3.14) is correct";
is_approx unpolar($one-and-one-hundredth, $neg-pi), 1.01.unpolar(-3.14), "1.01.unpolar(-3.14) is correct";

is $one-and-one-hundredth.floor, 1, "1.01.floor is correct";
is floor(1), 1, "1.floor is correct";
is $one-and-one-hundredth.ceiling, 2, "1.01.ceiling is correct";
is ceiling(1), 1, "1.ceiling is correct";
is $one-and-one-hundredth.truncate, 1, "1.01.truncate is correct";
is truncate($neg-pi), -3, "-3.14.truncate is correct";
is $one-and-one-hundredth.round(1/100), 1.01, "1.01.round(1/100) is correct";
is round($one-and-one-hundredth, 1/10), 1, "1.01.round(1/10) is correct";
is round($one-and-one-hundredth), 1, "1.01.round is correct";

is $one-and-one-hundredth ** $neg-pi, 1.01 ** -3.14, "1.01 ** -3.14 is correct";
is $neg-pi ** $one, -3.14 ** 1, "-3.14 ** 1 is correct";

is $one-and-one-hundredth.exp, 1.01.exp, "1.01.exp is correct";
is $neg-pi.exp, (-3.14).exp, "-3.14.exp is correct";
is $one-and-one-hundredth.exp(10.Rat), 1.01.exp(10), "1.01.exp(10) is correct";
is 2.exp($neg-pi), 2.exp(-3.14), "2.exp(-3.14) is correct";
is_approx $one-and-one-hundredth.exp(10i), 1.01.exp(10i), "1.01.exp(10i) is correct";

{
    my @l = $neg-pi.roots(4);
    ok(@l.elems == 4, '(-3.14).roots(4) returns 4 elements');
    my $quartic = (-3.14.Complex) ** .25;
    ok(@l.grep({ ($_ - $quartic).abs < 1e-5 }).Bool, '(-3.14) ** 1/4 is a quartic root of -3.14');
    ok(@l.grep({ ($_ + $quartic).abs < 1e-5 }).Bool, '-(-3.14) ** 1/4 is a quartic root of -3.14');
    ok(@l.grep({ ($_ - $quartic\i).abs < 1e-5 }).Bool, '(-3.14)i ** 1/4 is a quartic root of -3.14');
    ok(@l.grep({ ($_ + $quartic\i).abs < 1e-5 }).Bool, '-(-3.14)i ** 1/4 is a quartic root of -3.14');
}

ok 0 <= 4.rand < 4, "Int.rand returns a valid result";
ok 0 <= (4/3).rand < 4/3, "Rat.rand returns a valid result";
ok 0 <= $one-and-one-hundredth.rand < $one-and-one-hundredth, "Fixed2.rand returns a valid result";
ok 0 <= 32.75.Num.rand < 32.75, "Num.rand returns a valid result";

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/roots.t���������������������������������������������������������������0000664�0001750�0001750�00000011054�12224265625�016506� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 55;

# L<S32::Numeric/Numeric/"=item roots">

sub approx($a, $b){
    my ($x,$y);
    my $eps = 1e-3;
    # coerce both to Complex
    $x = $a + 0i;
    $y = $b + 0i;
    my $re = abs($x.re - $y.re);
    my $im = abs($x.im - $y.im);
    # both real and imag part must be with $eps of expected
    return ( $re < $eps && $im < $eps );
}

sub has_approx($n, @list) {
    for @list -> $i {
        if approx($i, $n) {
            return 1;
        }
    }
    return Mu;
}

{
    my @l = roots(0, 1);
    ok(@l.elems == 1, 'roots(0, 1) returns 1 element');
    ok(has_approx(0, @l), 'roots(0, 1) contains 0');
}
{
    my @l = roots(0, 0);
    ok(@l.elems == 1, 'roots(0, 0) returns 1 element');
    ok(@l[0] ~~ 'NaN', 'roots(0,0) returns NaN');
}
{
    my @l = roots(0, -1);
    ok(@l.elems == 1, 'roots(0, -1) returns 1 element');
    ok(@l[0] ~~ 'NaN', 'roots(0,-1) returns NaN');
}
{
    my @l = roots(100, -1);
    ok(@l.elems == 1, 'roots(100, -1) returns 1 element');
    ok(@l[0] ~~ 'NaN', 'roots(100,-1) returns NaN');
}
{
    my @m = roots(1, 0);
    ok(@m.elems == 1, 'roots(1, 0) returns 1 element');
    ok(@m[0] ~~ 'NaN', 'roots(1,0) returns NaN');
}
{
    my @m = roots(Inf, 0);
    ok(@m.elems == 1, 'roots(Inf, 0) returns 1 element');
    ok(@m[0] ~~ 'NaN', 'roots(Inf,0) returns NaN');
}
{
    my @m = roots(-Inf, 0);
    ok(@m.elems == 1, 'roots(-Inf, 0) returns 1 element');
    ok(@m[0] ~~ 'NaN', 'roots(-Inf,0) returns NaN');
}
{
    my @m = roots(NaN, 0);
    ok(@m.elems == 1, 'roots(NaN, 0) returns 1 element');
    ok(@m[0] ~~ 'NaN', 'roots(NaN,0) returns NaN');
}
{
    my @l = roots(4, 2);
    ok(@l.elems == 2, 'roots(4, 2) returns 2 elements');
    ok(has_approx(2, @l), 'roots(4, 2) contains 2');
    ok(has_approx(-2, @l), 'roots(4, 2) contains -2');
}
{
    my @l = roots(-1, 2);
    ok(@l.elems == 2, 'roots(-1, 2) returns 2 elements');
    ok(has_approx(1i, @l), 'roots(-1, 2) contains 1i');
    ok(has_approx(-1i, @l), 'roots(-1, 2) contains -1i');
}

#?pugs todo 'feature'
{
    my @l = 16.roots(4);
    ok(@l.elems == 4, '16.roots(4) returns 4 elements');
    ok(has_approx(2, @l), '16.roots(4) contains 2');
    ok(has_approx(-2, @l), '16.roots(4) contains -2');
    ok(has_approx(2i, @l), '16.roots(4) contains 2i');
    ok(has_approx(-2i, @l), '16.roots(4) contains -2i');
}
{
    my @l = (-1).roots(2);
    ok(@l.elems == 2, '(-1).roots(2) returns 2 elements');
    ok(has_approx(1i, @l), '(-1).roots(2) contains i');
    ok(has_approx(-1i, @l), '(-1).roots(2) contains -i');
}
{
    my @l = 0e0.roots(2);
    ok(@l.elems == 2, '0e0.roots(2) returns 2 elements');
    ok(has_approx(0, @l), '0e0.roots(2) contains 0');
}
{
    my @l = roots(NaN, 1);
    ok(@l.elems == 1, 'roots(NaN, 1) returns 1 element');
    ok(@l[0] ~~ NaN, 'roots(NaN,1) returns NaN');
}
{
    my @l = roots(Inf, 1);
    ok(@l.elems == 1, 'roots(Inf, 1) returns 1 element');
    ok(@l[0] ~~ Inf, 'roots(Inf,1) returns Inf');
}

my $pi = 312689/99532;

{
    my @l = roots(1i,2);
    ok(@l.elems == 2, 'roots(1i,2) returns 2 elements');
    ok(has_approx(exp(5i*$pi/4), @l), 'exp(5i*$pi/4) is a square root of i');
    ok(has_approx(exp(1i*$pi/4), @l), 'exp(1i*$pi/4) is a square root of i');
}
{
    my @l = roots(1+1i,2);
    ok(@l.elems == 2, 'roots(1+1i,2) returns 2 elements');
    ok(has_approx(exp(log(2)/4 + 1i*$pi/8), @l),'exp(log(2)/4 + 1i*$pi/8) is a square root of 1+1i');
    ok(has_approx(exp(log(2)/4 + 9i*$pi/8), @l),'exp(log(2)/4 + 9i*$pi/8) is a square root of 1+1i');
}
{
    my @l = 8.roots(3);
    ok(@l.elems == 3, '8.roots(3) returns 3 elements');
    ok(has_approx(2,@l), '2 is a cube root of 8');
    ok(has_approx(exp(1/3*(log(8) + 2i*$pi)),@l), 'exp(1/3*(log(8) + 2i*$pi)) is a cube root of 8');
    ok(has_approx(exp(1/3*(log(8) + 4i*$pi)),@l), 'exp(1/3*(log(8) + 4i*$pi)) is a cube root of 8');
}
{
    my @l = (-8).Num.roots(3);
    ok(@l.elems == 3, '(-8).roots(3) returns 3 elements');
    ok(has_approx(-2,@l), '2 is a cube root of -8');
    ok(has_approx(exp(1/3*(log(8) + 3i*$pi)),@l), 'exp(1/3*(log(8) + 3i*$pi)) is a cube root of -8');
    ok(has_approx(exp(1/3*(log(8) + 5i*$pi)),@l), 'exp(1/3*(log(8) + 5i*$pi)) is a cube root of -8');
}
{
    my @l = 8.5.roots(4);
    ok(@l.elems == 4, '8.5.roots(4) returns 4 elements');
    my $quartic = 8.5 ** .25;
    ok(has_approx($quartic, @l), '8.5 ** 1/4 is a quartic root of 8.5');
    ok(has_approx(-$quartic, @l), '-(8.5 ** 1/4) is a quartic root of 8.5');
    ok(has_approx($quartic\i, @l), '(8.5 ** 1/4)i is a quartic root of 8.5');
    ok(has_approx(-$quartic\i, @l), '-(8.5 ** 1/4)i is a quartic root of 8.5');
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/rounders.t������������������������������������������������������������0000664�0001750�0001750�00000012212�12224265625�017176� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 128;

# L<S32::Numeric/Real/"=item round">
# L<S32::Numeric/Real/"=item floor">
# L<S32::Numeric/Real/"=item truncate">
# L<S32::Numeric/Real/"=item ceiling">

=begin pod

Basic tests for the round(), floor(), truncate() and ceiling() built-ins

=end pod

is( floor(NaN), NaN, 'floor(NaN) is NaN');
is( round(NaN), NaN, 'round(NaN) is NaN');
is( ceiling(NaN), NaN,  'ceiling(NaN) is NaN');
is( truncate(NaN), NaN, 'truncate(NaN) is NaN');

is( floor(Inf), Inf, 'floor(Inf) is Inf');
is( round(Inf), Inf, 'round(Inf) is Inf');
is( ceiling(Inf), Inf,  'ceiling(Inf) is Inf');
is( truncate(Inf), Inf, 'truncate(Inf) is Inf');

is( floor(-Inf), -Inf, 'floor(-Inf) is -Inf');
is( round(-Inf), -Inf, 'round(-Inf) is -Inf');
is( ceiling(-Inf), -Inf,  'ceiling(-Inf) is -Inf');
is( truncate(-Inf), -Inf, 'truncate(-Inf) is -Inf');

is( NaN.floor, NaN, 'NaN.floor is NaN');
is( NaN.round, NaN, 'NaN.round is NaN');
is( NaN.ceiling, NaN,  'NaN.ceiling is NaN');
is( NaN.truncate, NaN, 'NaN.truncate is NaN');

is( Inf.floor, Inf, 'Inf.floor is Inf');
is( Inf.round, Inf, 'Inf.round is Inf');
is( Inf.ceiling, Inf,  'Inf.ceiling is Inf');
is( Inf.truncate, Inf, 'Inf.truncate is Inf');

is( (-Inf).floor, -Inf, '(-Inf).floor is -Inf');
is( (-Inf).round, -Inf, '(-Inf).round is -Inf');
is( (-Inf).ceiling, -Inf,  '(-Inf).ceiling is -Inf');
is( (-Inf).truncate, -Inf, '(-Inf).truncate is -Inf');

my %tests =
    ( ceiling => [ [ 1.5, 2 ], [ 2, 2 ], [ 1.4999, 2 ],
         [ -0.1, 0 ], [ -1, -1 ], [ -5.9, -5 ],
         [ -0.5, 0 ], [ "-0.499.Num", 0 ], [ "-5.499.Num", -5 ], 
         [ "2.Num", 2 ] ],
      floor => [ [ 1.5, 1 ], [ 2, 2 ], [ 1.4999, 1 ],
         [ -0.1, -1 ], [ -1, -1 ], [ -5.9, -6 ],
         [ -0.5, -1 ], [ "-0.499.Num", -1 ], [ "-5.499.Num", -6 ], 
         [ "2.Num", 2 ]  ],
      round => [ [ 1.5, 2 ], [ 2, 2 ], [ 1.4999, 1 ],
         [ -0.1, 0 ], [ -1, -1 ], [ -5.9, -6 ],
         [ -0.5, 0 ], [ "-0.499.Num", 0 ], [ "-5.499.Num", -5 ], 
         [ "2.Num", 2 ]  ],
      truncate => [ [ 1.5, 1 ], [ 2, 2 ], [ 1.4999, 1 ],
         [ -0.1, 0 ], [ -1, -1 ], [ -5.9, -5 ],
         [ -0.5, 0 ], [ "-0.499.Num", 0 ], [ "-5.499.Num", -5 ], 
         [ "2.Num", 2 ]  ],
    );

#?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 }

for %tests.keys.sort -> $type {
    my @subtests = @(%tests{$type});	# XXX .[] doesn't work yet!
    for @subtests -> $test {
        my $code = "{$type}({$test[0]})";
        my $res = eval($code);

        if ($!) {
            #?pugs todo 'feature'
            flunk("failed to parse $code ($!)");
        } else {
            ok($res == $test[1], "$code == {$test[1]}");
        }
    }
}

 
for %tests.keys.sort -> $type {
    my @subtests = @(%tests{$type});    # XXX .[] doesn't work yet!
    for @subtests -> $test {
        my $code = "({$test[0]}).{$type}";
        my $res = eval($code);

        if ($!) {
            #?pugs todo 'feature'
            flunk("failed to parse $code ($!)");
        } else {
            ok($res == $test[1], "$code == {$test[1]}");
        }
    }
}

for %tests.keys.sort -> $t {
    isa_ok eval("{$t}(1.1)"), Int, "rounder $t returns an Int";

}

# RT #118545  Round with arguments
#?pugs 4 skip "round with arguments"
{   
    my $integer = 987654321;
    is $integer.round(1),   987654321, "round integer with argument";
    is $integer.round(5),   987654320, "($integer).round(5) == 987654320";
    is $integer.round(1e5), 987700000, "($integer).round(1e5) == 987700000";
    is 2.round(3/20),       1.95,      "2.round(3/20) == 1.95";
}

#?pugs 4 skip "round with arguments"
{
    my $num = 123.456789;
    is $num.round(1),     123,       "round with argument";
    is $num.round(5),     125,       "($num).round(5) == 125";
    is $num.round(1/100), 123.46,    "($num).round(1/100) == 123.46";
    #?niecza todo "rounding with Num makes more rounding errors"
    #?rakudo.jvm todo "nigh"
    is $num.round(1e-5),  123.45679, "($num).round(1e-5) == 123.45679";
}




{
    my $big-int = 1234567890123456789012345678903;
    is $big-int.floor, $big-int, "floor passes bigints unchanged";
    is $big-int.ceiling, $big-int, "ceiling passes bigints unchanged";
    is $big-int.round, $big-int, "round passes bigints unchanged";
    is $big-int.truncate, $big-int, "truncate passes bigints unchanged";
}

{
    my $big-rat = 1234567890123456789012345678903 / 2;
    my $big-int = 1234567890123456789012345678903 div 2;
    is $big-rat.floor, $big-int, "floor handles Rats properly";
    is $big-rat.ceiling, $big-int + 1, "ceiling handles Rats properly";
    is $big-rat.round, $big-int + 1, "round handles Rats properly";
    is $big-rat.truncate, $big-int, "truncate handles Rats properly";
}

{
    my $big-rat = FatRat.new(1234567890123456789012345678903, 2);
    my $big-int = 1234567890123456789012345678903 div 2;
    is $big-rat.floor, $big-int, "floor handles FatRats properly";
    is $big-rat.ceiling, $big-int + 1, "ceiling handles FatRats properly";
    is $big-rat.round, $big-int + 1, "round handles FatRats properly";
    is $big-rat.truncate, $big-int, "truncate handles FatRats properly";
}

done;

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/rshift_pos_amount.t���������������������������������������������������0000664�0001750�0001750�00000062257�12224265625�021116� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������
use v6;
use Test;

plan 189;

my @got = (-300..300) X+> (0..9);
my @exp = (-300, -150, -75, -38, -19, -10, -5, -3, -2, -1, -299, -150, -75, -38, -19, -10, -5, -3, -2, -1, -298, 
     -149, -75, -38, -19, -10, -5, -3, -2, -1, -297, -149, -75, -38, -19, -10, -5, -3, -2, -1, -296, -148, -74, 
     -37, -19, -10, -5, -3, -2, -1, -295, -148, -74, -37, -19, -10, -5, -3, -2, -1, -294, -147, -74, -37, -19, 
     -10, -5, -3, -2, -1, -293, -147, -74, -37, -19, -10, -5, -3, -2, -1, -292, -146, -73, -37, -19, -10, -5, 
     -3, -2, -1, -291, -146, -73, -37, -19, -10, -5, -3, -2, -1, -290, -145, -73, -37, -19, -10, -5, -3, -2, 
     -1, -289, -145, -73, -37, -19, -10, -5, -3, -2, -1, -288, -144, -72, -36, -18, -9, -5, -3, -2, -1, -287, 
     -144, -72, -36, -18, -9, -5, -3, -2, -1, -286, -143, -72, -36, -18, -9, -5, -3, -2, -1, -285, -143, -72, 
     -36, -18, -9, -5, -3, -2, -1, -284, -142, -71, -36, -18, -9, -5, -3, -2, -1, -283, -142, -71, -36, -18, 
     -9, -5, -3, -2, -1, -282, -141, -71, -36, -18, -9, -5, -3, -2, -1, -281, -141, -71, -36, -18, -9, -5, -3, 
     -2, -1, -280, -140, -70, -35, -18, -9, -5, -3, -2, -1, -279, -140, -70, -35, -18, -9, -5, -3, -2, -1, 
     -278, -139, -70, -35, -18, -9, -5, -3, -2, -1, -277, -139, -70, -35, -18, -9, -5, -3, -2, -1, -276, -138, 
     -69, -35, -18, -9, -5, -3, -2, -1, -275, -138, -69, -35, -18, -9, -5, -3, -2, -1, -274, -137, -69, -35, 
     -18, -9, -5, -3, -2, -1, -273, -137, -69, -35, -18, -9, -5, -3, -2, -1, -272, -136, -68, -34, -17, -9, -5, 
     -3, -2, -1, -271, -136, -68, -34, -17, -9, -5, -3, -2, -1, -270, -135, -68, -34, -17, -9, -5, -3, -2, -1, 
     -269, -135, -68, -34, -17, -9, -5, -3, -2, -1, -268, -134, -67, -34, -17, -9, -5, -3, -2, -1, -267, -134, 
     -67, -34, -17, -9, -5, -3, -2, -1, -266, -133, -67, -34, -17, -9, -5, -3, -2, -1, -265, -133, -67, -34, 
     -17, -9, -5, -3, -2, -1, -264, -132, -66, -33, -17, -9, -5, -3, -2, -1, -263, -132, -66, -33, -17, -9, -5, 
     -3, -2, -1, -262, -131, -66, -33, -17, -9, -5, -3, -2, -1, -261, -131, -66, -33, -17, -9, -5, -3, -2, -1, 
     -260, -130, -65, -33, -17, -9, -5, -3, -2, -1, -259, -130, -65, -33, -17, -9, -5, -3, -2, -1, -258, -129, 
     -65, -33, -17, -9, -5, -3, -2, -1, -257, -129, -65, -33, -17, -9, -5, -3, -2, -1, -256, -128, -64, -32, 
     -16, -8, -4, -2, -1, -1, -255, -128, -64, -32, -16, -8, -4, -2, -1, -1, -254, -127, -64, -32, -16, -8, -4, 
     -2, -1, -1, -253, -127, -64, -32, -16, -8, -4, -2, -1, -1, -252, -126, -63, -32, -16, -8, -4, -2, -1, -1, 
     -251, -126, -63, -32, -16, -8, -4, -2, -1, -1, -250, -125, -63, -32, -16, -8, -4, -2, -1, -1, -249, -125, 
     -63, -32, -16, -8, -4, -2, -1, -1, -248, -124, -62, -31, -16, -8, -4, -2, -1, -1, -247, -124, -62, -31, 
     -16, -8, -4, -2, -1, -1, -246, -123, -62, -31, -16, -8, -4, -2, -1, -1, -245, -123, -62, -31, -16, -8, -4, 
     -2, -1, -1, -244, -122, -61, -31, -16, -8, -4, -2, -1, -1, -243, -122, -61, -31, -16, -8, -4, -2, -1, -1, 
     -242, -121, -61, -31, -16, -8, -4, -2, -1, -1, -241, -121, -61, -31, -16, -8, -4, -2, -1, -1, -240, -120, 
     -60, -30, -15, -8, -4, -2, -1, -1, -239, -120, -60, -30, -15, -8, -4, -2, -1, -1, -238, -119, -60, -30, 
     -15, -8, -4, -2, -1, -1, -237, -119, -60, -30, -15, -8, -4, -2, -1, -1, -236, -118, -59, -30, -15, -8, -4, 
     -2, -1, -1, -235, -118, -59, -30, -15, -8, -4, -2, -1, -1, -234, -117, -59, -30, -15, -8, -4, -2, -1, -1, 
     -233, -117, -59, -30, -15, -8, -4, -2, -1, -1, -232, -116, -58, -29, -15, -8, -4, -2, -1, -1, -231, -116, 
     -58, -29, -15, -8, -4, -2, -1, -1, -230, -115, -58, -29, -15, -8, -4, -2, -1, -1, -229, -115, -58, -29, 
     -15, -8, -4, -2, -1, -1, -228, -114, -57, -29, -15, -8, -4, -2, -1, -1, -227, -114, -57, -29, -15, -8, -4, 
     -2, -1, -1, -226, -113, -57, -29, -15, -8, -4, -2, -1, -1, -225, -113, -57, -29, -15, -8, -4, -2, -1, -1, 
     -224, -112, -56, -28, -14, -7, -4, -2, -1, -1, -223, -112, -56, -28, -14, -7, -4, -2, -1, -1, -222, -111, 
     -56, -28, -14, -7, -4, -2, -1, -1, -221, -111, -56, -28, -14, -7, -4, -2, -1, -1, -220, -110, -55, -28, 
     -14, -7, -4, -2, -1, -1, -219, -110, -55, -28, -14, -7, -4, -2, -1, -1, -218, -109, -55, -28, -14, -7, -4, 
     -2, -1, -1, -217, -109, -55, -28, -14, -7, -4, -2, -1, -1, -216, -108, -54, -27, -14, -7, -4, -2, -1, -1, 
     -215, -108, -54, -27, -14, -7, -4, -2, -1, -1, -214, -107, -54, -27, -14, -7, -4, -2, -1, -1, -213, -107, 
     -54, -27, -14, -7, -4, -2, -1, -1, -212, -106, -53, -27, -14, -7, -4, -2, -1, -1, -211, -106, -53, -27, 
     -14, -7, -4, -2, -1, -1, -210, -105, -53, -27, -14, -7, -4, -2, -1, -1, -209, -105, -53, -27, -14, -7, -4, 
     -2, -1, -1, -208, -104, -52, -26, -13, -7, -4, -2, -1, -1, -207, -104, -52, -26, -13, -7, -4, -2, -1, -1, 
     -206, -103, -52, -26, -13, -7, -4, -2, -1, -1, -205, -103, -52, -26, -13, -7, -4, -2, -1, -1, -204, -102, 
     -51, -26, -13, -7, -4, -2, -1, -1, -203, -102, -51, -26, -13, -7, -4, -2, -1, -1, -202, -101, -51, -26, 
     -13, -7, -4, -2, -1, -1, -201, -101, -51, -26, -13, -7, -4, -2, -1, -1, -200, -100, -50, -25, -13, -7, -4, 
     -2, -1, -1, -199, -100, -50, -25, -13, -7, -4, -2, -1, -1, -198, -99, -50, -25, -13, -7, -4, -2, -1, -1, 
     -197, -99, -50, -25, -13, -7, -4, -2, -1, -1, -196, -98, -49, -25, -13, -7, -4, -2, -1, -1, -195, -98, 
     -49, -25, -13, -7, -4, -2, -1, -1, -194, -97, -49, -25, -13, -7, -4, -2, -1, -1, -193, -97, -49, -25, -13, 
     -7, -4, -2, -1, -1, -192, -96, -48, -24, -12, -6, -3, -2, -1, -1, -191, -96, -48, -24, -12, -6, -3, -2, 
     -1, -1, -190, -95, -48, -24, -12, -6, -3, -2, -1, -1, -189, -95, -48, -24, -12, -6, -3, -2, -1, -1, -188, 
     -94, -47, -24, -12, -6, -3, -2, -1, -1, -187, -94, -47, -24, -12, -6, -3, -2, -1, -1, -186, -93, -47, -24, 
     -12, -6, -3, -2, -1, -1, -185, -93, -47, -24, -12, -6, -3, -2, -1, -1, -184, -92, -46, -23, -12, -6, -3, 
     -2, -1, -1, -183, -92, -46, -23, -12, -6, -3, -2, -1, -1, -182, -91, -46, -23, -12, -6, -3, -2, -1, -1, 
     -181, -91, -46, -23, -12, -6, -3, -2, -1, -1, -180, -90, -45, -23, -12, -6, -3, -2, -1, -1, -179, -90, 
     -45, -23, -12, -6, -3, -2, -1, -1, -178, -89, -45, -23, -12, -6, -3, -2, -1, -1, -177, -89, -45, -23, -12, 
     -6, -3, -2, -1, -1, -176, -88, -44, -22, -11, -6, -3, -2, -1, -1, -175, -88, -44, -22, -11, -6, -3, -2, 
     -1, -1, -174, -87, -44, -22, -11, -6, -3, -2, -1, -1, -173, -87, -44, -22, -11, -6, -3, -2, -1, -1, -172, 
     -86, -43, -22, -11, -6, -3, -2, -1, -1, -171, -86, -43, -22, -11, -6, -3, -2, -1, -1, -170, -85, -43, -22, 
     -11, -6, -3, -2, -1, -1, -169, -85, -43, -22, -11, -6, -3, -2, -1, -1, -168, -84, -42, -21, -11, -6, -3, 
     -2, -1, -1, -167, -84, -42, -21, -11, -6, -3, -2, -1, -1, -166, -83, -42, -21, -11, -6, -3, -2, -1, -1, 
     -165, -83, -42, -21, -11, -6, -3, -2, -1, -1, -164, -82, -41, -21, -11, -6, -3, -2, -1, -1, -163, -82, 
     -41, -21, -11, -6, -3, -2, -1, -1, -162, -81, -41, -21, -11, -6, -3, -2, -1, -1, -161, -81, -41, -21, -11, 
     -6, -3, -2, -1, -1, -160, -80, -40, -20, -10, -5, -3, -2, -1, -1, -159, -80, -40, -20, -10, -5, -3, -2, 
     -1, -1, -158, -79, -40, -20, -10, -5, -3, -2, -1, -1, -157, -79, -40, -20, -10, -5, -3, -2, -1, -1, -156, 
     -78, -39, -20, -10, -5, -3, -2, -1, -1, -155, -78, -39, -20, -10, -5, -3, -2, -1, -1, -154, -77, -39, -20, 
     -10, -5, -3, -2, -1, -1, -153, -77, -39, -20, -10, -5, -3, -2, -1, -1, -152, -76, -38, -19, -10, -5, -3, 
     -2, -1, -1, -151, -76, -38, -19, -10, -5, -3, -2, -1, -1, -150, -75, -38, -19, -10, -5, -3, -2, -1, -1, 
     -149, -75, -38, -19, -10, -5, -3, -2, -1, -1, -148, -74, -37, -19, -10, -5, -3, -2, -1, -1, -147, -74, 
     -37, -19, -10, -5, -3, -2, -1, -1, -146, -73, -37, -19, -10, -5, -3, -2, -1, -1, -145, -73, -37, -19, -10, 
     -5, -3, -2, -1, -1, -144, -72, -36, -18, -9, -5, -3, -2, -1, -1, -143, -72, -36, -18, -9, -5, -3, -2, -1, 
     -1, -142, -71, -36, -18, -9, -5, -3, -2, -1, -1, -141, -71, -36, -18, -9, -5, -3, -2, -1, -1, -140, -70, 
     -35, -18, -9, -5, -3, -2, -1, -1, -139, -70, -35, -18, -9, -5, -3, -2, -1, -1, -138, -69, -35, -18, -9, 
     -5, -3, -2, -1, -1, -137, -69, -35, -18, -9, -5, -3, -2, -1, -1, -136, -68, -34, -17, -9, -5, -3, -2, -1, 
     -1, -135, -68, -34, -17, -9, -5, -3, -2, -1, -1, -134, -67, -34, -17, -9, -5, -3, -2, -1, -1, -133, -67, 
     -34, -17, -9, -5, -3, -2, -1, -1, -132, -66, -33, -17, -9, -5, -3, -2, -1, -1, -131, -66, -33, -17, -9, 
     -5, -3, -2, -1, -1, -130, -65, -33, -17, -9, -5, -3, -2, -1, -1, -129, -65, -33, -17, -9, -5, -3, -2, -1, 
     -1, -128, -64, -32, -16, -8, -4, -2, -1, -1, -1, -127, -64, -32, -16, -8, -4, -2, -1, -1, -1, -126, -63, 
     -32, -16, -8, -4, -2, -1, -1, -1, -125, -63, -32, -16, -8, -4, -2, -1, -1, -1, -124, -62, -31, -16, -8, 
     -4, -2, -1, -1, -1, -123, -62, -31, -16, -8, -4, -2, -1, -1, -1, -122, -61, -31, -16, -8, -4, -2, -1, -1, 
     -1, -121, -61, -31, -16, -8, -4, -2, -1, -1, -1, -120, -60, -30, -15, -8, -4, -2, -1, -1, -1, -119, -60, 
     -30, -15, -8, -4, -2, -1, -1, -1, -118, -59, -30, -15, -8, -4, -2, -1, -1, -1, -117, -59, -30, -15, -8, 
     -4, -2, -1, -1, -1, -116, -58, -29, -15, -8, -4, -2, -1, -1, -1, -115, -58, -29, -15, -8, -4, -2, -1, -1, 
     -1, -114, -57, -29, -15, -8, -4, -2, -1, -1, -1, -113, -57, -29, -15, -8, -4, -2, -1, -1, -1, -112, -56, 
     -28, -14, -7, -4, -2, -1, -1, -1, -111, -56, -28, -14, -7, -4, -2, -1, -1, -1, -110, -55, -28, -14, -7, 
     -4, -2, -1, -1, -1, -109, -55, -28, -14, -7, -4, -2, -1, -1, -1, -108, -54, -27, -14, -7, -4, -2, -1, -1, 
     -1, -107, -54, -27, -14, -7, -4, -2, -1, -1, -1, -106, -53, -27, -14, -7, -4, -2, -1, -1, -1, -105, -53, 
     -27, -14, -7, -4, -2, -1, -1, -1, -104, -52, -26, -13, -7, -4, -2, -1, -1, -1, -103, -52, -26, -13, -7, 
     -4, -2, -1, -1, -1, -102, -51, -26, -13, -7, -4, -2, -1, -1, -1, -101, -51, -26, -13, -7, -4, -2, -1, -1, 
     -1, -100, -50, -25, -13, -7, -4, -2, -1, -1, -1, -99, -50, -25, -13, -7, -4, -2, -1, -1, -1, -98, -49, 
     -25, -13, -7, -4, -2, -1, -1, -1, -97, -49, -25, -13, -7, -4, -2, -1, -1, -1, -96, -48, -24, -12, -6, -3, 
     -2, -1, -1, -1, -95, -48, -24, -12, -6, -3, -2, -1, -1, -1, -94, -47, -24, -12, -6, -3, -2, -1, -1, -1, 
     -93, -47, -24, -12, -6, -3, -2, -1, -1, -1, -92, -46, -23, -12, -6, -3, -2, -1, -1, -1, -91, -46, -23, 
     -12, -6, -3, -2, -1, -1, -1, -90, -45, -23, -12, -6, -3, -2, -1, -1, -1, -89, -45, -23, -12, -6, -3, -2, 
     -1, -1, -1, -88, -44, -22, -11, -6, -3, -2, -1, -1, -1, -87, -44, -22, -11, -6, -3, -2, -1, -1, -1, -86, 
     -43, -22, -11, -6, -3, -2, -1, -1, -1, -85, -43, -22, -11, -6, -3, -2, -1, -1, -1, -84, -42, -21, -11, -6, 
     -3, -2, -1, -1, -1, -83, -42, -21, -11, -6, -3, -2, -1, -1, -1, -82, -41, -21, -11, -6, -3, -2, -1, -1, 
     -1, -81, -41, -21, -11, -6, -3, -2, -1, -1, -1, -80, -40, -20, -10, -5, -3, -2, -1, -1, -1, -79, -40, -20, 
     -10, -5, -3, -2, -1, -1, -1, -78, -39, -20, -10, -5, -3, -2, -1, -1, -1, -77, -39, -20, -10, -5, -3, -2, 
     -1, -1, -1, -76, -38, -19, -10, -5, -3, -2, -1, -1, -1, -75, -38, -19, -10, -5, -3, -2, -1, -1, -1, -74, 
     -37, -19, -10, -5, -3, -2, -1, -1, -1, -73, -37, -19, -10, -5, -3, -2, -1, -1, -1, -72, -36, -18, -9, -5, 
     -3, -2, -1, -1, -1, -71, -36, -18, -9, -5, -3, -2, -1, -1, -1, -70, -35, -18, -9, -5, -3, -2, -1, -1, -1, 
     -69, -35, -18, -9, -5, -3, -2, -1, -1, -1, -68, -34, -17, -9, -5, -3, -2, -1, -1, -1, -67, -34, -17, -9, 
     -5, -3, -2, -1, -1, -1, -66, -33, -17, -9, -5, -3, -2, -1, -1, -1, -65, -33, -17, -9, -5, -3, -2, -1, -1, 
     -1, -64, -32, -16, -8, -4, -2, -1, -1, -1, -1, -63, -32, -16, -8, -4, -2, -1, -1, -1, -1, -62, -31, -16, 
     -8, -4, -2, -1, -1, -1, -1, -61, -31, -16, -8, -4, -2, -1, -1, -1, -1, -60, -30, -15, -8, -4, -2, -1, -1, 
     -1, -1, -59, -30, -15, -8, -4, -2, -1, -1, -1, -1, -58, -29, -15, -8, -4, -2, -1, -1, -1, -1, -57, -29, 
     -15, -8, -4, -2, -1, -1, -1, -1, -56, -28, -14, -7, -4, -2, -1, -1, -1, -1, -55, -28, -14, -7, -4, -2, -1, 
     -1, -1, -1, -54, -27, -14, -7, -4, -2, -1, -1, -1, -1, -53, -27, -14, -7, -4, -2, -1, -1, -1, -1, -52, 
     -26, -13, -7, -4, -2, -1, -1, -1, -1, -51, -26, -13, -7, -4, -2, -1, -1, -1, -1, -50, -25, -13, -7, -4, 
     -2, -1, -1, -1, -1, -49, -25, -13, -7, -4, -2, -1, -1, -1, -1, -48, -24, -12, -6, -3, -2, -1, -1, -1, -1, 
     -47, -24, -12, -6, -3, -2, -1, -1, -1, -1, -46, -23, -12, -6, -3, -2, -1, -1, -1, -1, -45, -23, -12, -6, 
     -3, -2, -1, -1, -1, -1, -44, -22, -11, -6, -3, -2, -1, -1, -1, -1, -43, -22, -11, -6, -3, -2, -1, -1, -1, 
     -1, -42, -21, -11, -6, -3, -2, -1, -1, -1, -1, -41, -21, -11, -6, -3, -2, -1, -1, -1, -1, -40, -20, -10, 
     -5, -3, -2, -1, -1, -1, -1, -39, -20, -10, -5, -3, -2, -1, -1, -1, -1, -38, -19, -10, -5, -3, -2, -1, -1, 
     -1, -1, -37, -19, -10, -5, -3, -2, -1, -1, -1, -1, -36, -18, -9, -5, -3, -2, -1, -1, -1, -1, -35, -18, -9, 
     -5, -3, -2, -1, -1, -1, -1, -34, -17, -9, -5, -3, -2, -1, -1, -1, -1, -33, -17, -9, -5, -3, -2, -1, -1, 
     -1, -1, -32, -16, -8, -4, -2, -1, -1, -1, -1, -1, -31, -16, -8, -4, -2, -1, -1, -1, -1, -1, -30, -15, -8, 
     -4, -2, -1, -1, -1, -1, -1, -29, -15, -8, -4, -2, -1, -1, -1, -1, -1, -28, -14, -7, -4, -2, -1, -1, -1, 
     -1, -1, -27, -14, -7, -4, -2, -1, -1, -1, -1, -1, -26, -13, -7, -4, -2, -1, -1, -1, -1, -1, -25, -13, -7, 
     -4, -2, -1, -1, -1, -1, -1, -24, -12, -6, -3, -2, -1, -1, -1, -1, -1, -23, -12, -6, -3, -2, -1, -1, -1, 
     -1, -1, -22, -11, -6, -3, -2, -1, -1, -1, -1, -1, -21, -11, -6, -3, -2, -1, -1, -1, -1, -1, -20, -10, -5, 
     -3, -2, -1, -1, -1, -1, -1, -19, -10, -5, -3, -2, -1, -1, -1, -1, -1, -18, -9, -5, -3, -2, -1, -1, -1, -1, 
     -1, -17, -9, -5, -3, -2, -1, -1, -1, -1, -1, -16, -8, -4, -2, -1, -1, -1, -1, -1, -1, -15, -8, -4, -2, -1, 
     -1, -1, -1, -1, -1, -14, -7, -4, -2, -1, -1, -1, -1, -1, -1, -13, -7, -4, -2, -1, -1, -1, -1, -1, -1, -12, 
     -6, -3, -2, -1, -1, -1, -1, -1, -1, -11, -6, -3, -2, -1, -1, -1, -1, -1, -1, -10, -5, -3, -2, -1, -1, -1, 
     -1, -1, -1, -9, -5, -3, -2, -1, -1, -1, -1, -1, -1, -8, -4, -2, -1, -1, -1, -1, -1, -1, -1, -7, -4, -2, 
     -1, -1, -1, -1, -1, -1, -1, -6, -3, -2, -1, -1, -1, -1, -1, -1, -1, -5, -3, -2, -1, -1, -1, -1, -1, -1, 
     -1, -4, -2, -1, -1, -1, -1, -1, -1, -1, -1, -3, -2, -1, -1, -1, -1, -1, -1, -1, -1, -2, -1, -1, -1, -1, 
     -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 
     0, 0, 0, 0, 0, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 0, 0, 0, 0, 0, 0, 0, 0, 4, 2, 1, 0, 0, 0, 0, 0, 0, 0, 
     5, 2, 1, 0, 0, 0, 0, 0, 0, 0, 6, 3, 1, 0, 0, 0, 0, 0, 0, 0, 7, 3, 1, 0, 0, 0, 0, 0, 0, 0, 8, 4, 2, 1, 0, 
     0, 0, 0, 0, 0, 9, 4, 2, 1, 0, 0, 0, 0, 0, 0, 10, 5, 2, 1, 0, 0, 0, 0, 0, 0, 11, 5, 2, 1, 0, 0, 0, 0, 0, 0, 
     12, 6, 3, 1, 0, 0, 0, 0, 0, 0, 13, 6, 3, 1, 0, 0, 0, 0, 0, 0, 14, 7, 3, 1, 0, 0, 0, 0, 0, 0, 15, 7, 3, 1, 
     0, 0, 0, 0, 0, 0, 16, 8, 4, 2, 1, 0, 0, 0, 0, 0, 17, 8, 4, 2, 1, 0, 0, 0, 0, 0, 18, 9, 4, 2, 1, 0, 0, 0, 
     0, 0, 19, 9, 4, 2, 1, 0, 0, 0, 0, 0, 20, 10, 5, 2, 1, 0, 0, 0, 0, 0, 21, 10, 5, 2, 1, 0, 0, 0, 0, 0, 22, 
     11, 5, 2, 1, 0, 0, 0, 0, 0, 23, 11, 5, 2, 1, 0, 0, 0, 0, 0, 24, 12, 6, 3, 1, 0, 0, 0, 0, 0, 25, 12, 6, 3, 
     1, 0, 0, 0, 0, 0, 26, 13, 6, 3, 1, 0, 0, 0, 0, 0, 27, 13, 6, 3, 1, 0, 0, 0, 0, 0, 28, 14, 7, 3, 1, 0, 0, 
     0, 0, 0, 29, 14, 7, 3, 1, 0, 0, 0, 0, 0, 30, 15, 7, 3, 1, 0, 0, 0, 0, 0, 31, 15, 7, 3, 1, 0, 0, 0, 0, 0, 
     32, 16, 8, 4, 2, 1, 0, 0, 0, 0, 33, 16, 8, 4, 2, 1, 0, 0, 0, 0, 34, 17, 8, 4, 2, 1, 0, 0, 0, 0, 35, 17, 8, 
     4, 2, 1, 0, 0, 0, 0, 36, 18, 9, 4, 2, 1, 0, 0, 0, 0, 37, 18, 9, 4, 2, 1, 0, 0, 0, 0, 38, 19, 9, 4, 2, 1, 
     0, 0, 0, 0, 39, 19, 9, 4, 2, 1, 0, 0, 0, 0, 40, 20, 10, 5, 2, 1, 0, 0, 0, 0, 41, 20, 10, 5, 2, 1, 0, 0, 0, 
     0, 42, 21, 10, 5, 2, 1, 0, 0, 0, 0, 43, 21, 10, 5, 2, 1, 0, 0, 0, 0, 44, 22, 11, 5, 2, 1, 0, 0, 0, 0, 45, 
     22, 11, 5, 2, 1, 0, 0, 0, 0, 46, 23, 11, 5, 2, 1, 0, 0, 0, 0, 47, 23, 11, 5, 2, 1, 0, 0, 0, 0, 48, 24, 12, 
     6, 3, 1, 0, 0, 0, 0, 49, 24, 12, 6, 3, 1, 0, 0, 0, 0, 50, 25, 12, 6, 3, 1, 0, 0, 0, 0, 51, 25, 12, 6, 3, 
     1, 0, 0, 0, 0, 52, 26, 13, 6, 3, 1, 0, 0, 0, 0, 53, 26, 13, 6, 3, 1, 0, 0, 0, 0, 54, 27, 13, 6, 3, 1, 0, 
     0, 0, 0, 55, 27, 13, 6, 3, 1, 0, 0, 0, 0, 56, 28, 14, 7, 3, 1, 0, 0, 0, 0, 57, 28, 14, 7, 3, 1, 0, 0, 0, 
     0, 58, 29, 14, 7, 3, 1, 0, 0, 0, 0, 59, 29, 14, 7, 3, 1, 0, 0, 0, 0, 60, 30, 15, 7, 3, 1, 0, 0, 0, 0, 61, 
     30, 15, 7, 3, 1, 0, 0, 0, 0, 62, 31, 15, 7, 3, 1, 0, 0, 0, 0, 63, 31, 15, 7, 3, 1, 0, 0, 0, 0, 64, 32, 16, 
     8, 4, 2, 1, 0, 0, 0, 65, 32, 16, 8, 4, 2, 1, 0, 0, 0, 66, 33, 16, 8, 4, 2, 1, 0, 0, 0, 67, 33, 16, 8, 4, 
     2, 1, 0, 0, 0, 68, 34, 17, 8, 4, 2, 1, 0, 0, 0, 69, 34, 17, 8, 4, 2, 1, 0, 0, 0, 70, 35, 17, 8, 4, 2, 1, 
     0, 0, 0, 71, 35, 17, 8, 4, 2, 1, 0, 0, 0, 72, 36, 18, 9, 4, 2, 1, 0, 0, 0, 73, 36, 18, 9, 4, 2, 1, 0, 0, 
     0, 74, 37, 18, 9, 4, 2, 1, 0, 0, 0, 75, 37, 18, 9, 4, 2, 1, 0, 0, 0, 76, 38, 19, 9, 4, 2, 1, 0, 0, 0, 77, 
     38, 19, 9, 4, 2, 1, 0, 0, 0, 78, 39, 19, 9, 4, 2, 1, 0, 0, 0, 79, 39, 19, 9, 4, 2, 1, 0, 0, 0, 80, 40, 20, 
     10, 5, 2, 1, 0, 0, 0, 81, 40, 20, 10, 5, 2, 1, 0, 0, 0, 82, 41, 20, 10, 5, 2, 1, 0, 0, 0, 83, 41, 20, 10, 
     5, 2, 1, 0, 0, 0, 84, 42, 21, 10, 5, 2, 1, 0, 0, 0, 85, 42, 21, 10, 5, 2, 1, 0, 0, 0, 86, 43, 21, 10, 5, 
     2, 1, 0, 0, 0, 87, 43, 21, 10, 5, 2, 1, 0, 0, 0, 88, 44, 22, 11, 5, 2, 1, 0, 0, 0, 89, 44, 22, 11, 5, 2, 
     1, 0, 0, 0, 90, 45, 22, 11, 5, 2, 1, 0, 0, 0, 91, 45, 22, 11, 5, 2, 1, 0, 0, 0, 92, 46, 23, 11, 5, 2, 1, 
     0, 0, 0, 93, 46, 23, 11, 5, 2, 1, 0, 0, 0, 94, 47, 23, 11, 5, 2, 1, 0, 0, 0, 95, 47, 23, 11, 5, 2, 1, 0, 
     0, 0, 96, 48, 24, 12, 6, 3, 1, 0, 0, 0, 97, 48, 24, 12, 6, 3, 1, 0, 0, 0, 98, 49, 24, 12, 6, 3, 1, 0, 0, 
     0, 99, 49, 24, 12, 6, 3, 1, 0, 0, 0, 100, 50, 25, 12, 6, 3, 1, 0, 0, 0, 101, 50, 25, 12, 6, 3, 1, 0, 0, 0, 
     102, 51, 25, 12, 6, 3, 1, 0, 0, 0, 103, 51, 25, 12, 6, 3, 1, 0, 0, 0, 104, 52, 26, 13, 6, 3, 1, 0, 0, 0, 
     105, 52, 26, 13, 6, 3, 1, 0, 0, 0, 106, 53, 26, 13, 6, 3, 1, 0, 0, 0, 107, 53, 26, 13, 6, 3, 1, 0, 0, 0, 
     108, 54, 27, 13, 6, 3, 1, 0, 0, 0, 109, 54, 27, 13, 6, 3, 1, 0, 0, 0, 110, 55, 27, 13, 6, 3, 1, 0, 0, 0, 
     111, 55, 27, 13, 6, 3, 1, 0, 0, 0, 112, 56, 28, 14, 7, 3, 1, 0, 0, 0, 113, 56, 28, 14, 7, 3, 1, 0, 0, 0, 
     114, 57, 28, 14, 7, 3, 1, 0, 0, 0, 115, 57, 28, 14, 7, 3, 1, 0, 0, 0, 116, 58, 29, 14, 7, 3, 1, 0, 0, 0, 
     117, 58, 29, 14, 7, 3, 1, 0, 0, 0, 118, 59, 29, 14, 7, 3, 1, 0, 0, 0, 119, 59, 29, 14, 7, 3, 1, 0, 0, 0, 
     120, 60, 30, 15, 7, 3, 1, 0, 0, 0, 121, 60, 30, 15, 7, 3, 1, 0, 0, 0, 122, 61, 30, 15, 7, 3, 1, 0, 0, 0, 
     123, 61, 30, 15, 7, 3, 1, 0, 0, 0, 124, 62, 31, 15, 7, 3, 1, 0, 0, 0, 125, 62, 31, 15, 7, 3, 1, 0, 0, 0, 
     126, 63, 31, 15, 7, 3, 1, 0, 0, 0, 127, 63, 31, 15, 7, 3, 1, 0, 0, 0, 128, 64, 32, 16, 8, 4, 2, 1, 0, 0, 
     129, 64, 32, 16, 8, 4, 2, 1, 0, 0, 130, 65, 32, 16, 8, 4, 2, 1, 0, 0, 131, 65, 32, 16, 8, 4, 2, 1, 0, 0, 
     132, 66, 33, 16, 8, 4, 2, 1, 0, 0, 133, 66, 33, 16, 8, 4, 2, 1, 0, 0, 134, 67, 33, 16, 8, 4, 2, 1, 0, 0, 
     135, 67, 33, 16, 8, 4, 2, 1, 0, 0, 136, 68, 34, 17, 8, 4, 2, 1, 0, 0, 137, 68, 34, 17, 8, 4, 2, 1, 0, 0, 
     138, 69, 34, 17, 8, 4, 2, 1, 0, 0, 139, 69, 34, 17, 8, 4, 2, 1, 0, 0, 140, 70, 35, 17, 8, 4, 2, 1, 0, 0, 
     141, 70, 35, 17, 8, 4, 2, 1, 0, 0, 142, 71, 35, 17, 8, 4, 2, 1, 0, 0, 143, 71, 35, 17, 8, 4, 2, 1, 0, 0, 
     144, 72, 36, 18, 9, 4, 2, 1, 0, 0, 145, 72, 36, 18, 9, 4, 2, 1, 0, 0, 146, 73, 36, 18, 9, 4, 2, 1, 0, 0, 
     147, 73, 36, 18, 9, 4, 2, 1, 0, 0, 148, 74, 37, 18, 9, 4, 2, 1, 0, 0, 149, 74, 37, 18, 9, 4, 2, 1, 0, 0, 
     150, 75, 37, 18, 9, 4, 2, 1, 0, 0, 151, 75, 37, 18, 9, 4, 2, 1, 0, 0, 152, 76, 38, 19, 9, 4, 2, 1, 0, 0, 
     153, 76, 38, 19, 9, 4, 2, 1, 0, 0, 154, 77, 38, 19, 9, 4, 2, 1, 0, 0, 155, 77, 38, 19, 9, 4, 2, 1, 0, 0, 
     156, 78, 39, 19, 9, 4, 2, 1, 0, 0, 157, 78, 39, 19, 9, 4, 2, 1, 0, 0, 158, 79, 39, 19, 9, 4, 2, 1, 0, 0, 
     159, 79, 39, 19, 9, 4, 2, 1, 0, 0, 160, 80, 40, 20, 10, 5, 2, 1, 0, 0, 161, 80, 40, 20, 10, 5, 2, 1, 0, 0, 
     162, 81, 40, 20, 10, 5, 2, 1, 0, 0, 163, 81, 40, 20, 10, 5, 2, 1, 0, 0, 164, 82, 41, 20, 10, 5, 2, 1, 0, 
     0, 165, 82, 41, 20, 10, 5, 2, 1, 0, 0, 166, 83, 41, 20, 10, 5, 2, 1, 0, 0, 167, 83, 41, 20, 10, 5, 2, 1, 
     0, 0, 168, 84, 42, 21, 10, 5, 2, 1, 0, 0, 169, 84, 42, 21, 10, 5, 2, 1, 0, 0, 170, 85, 42, 21, 10, 5, 2, 
     1, 0, 0, 171, 85, 42, 21, 10, 5, 2, 1, 0, 0, 172, 86, 43, 21, 10, 5, 2, 1, 0, 0, 173, 86, 43, 21, 10, 5, 
     2, 1, 0, 0, 174, 87, 43, 21, 10, 5, 2, 1, 0, 0, 175, 87, 43, 21, 10, 5, 2, 1, 0, 0, 176, 88, 44, 22, 11, 
     5, 2, 1, 0, 0, 177, 88, 44, 22, 11, 5, 2, 1, 0, 0, 178, 89, 44, 22, 11, 5, 2, 1, 0, 0, 179, 89, 44, 22, 
     11, 5, 2, 1, 0, 0, 180, 90, 45, 22, 11, 5, 2, 1, 0, 0, 181, 90, 45, 22, 11, 5, 2, 1, 0, 0, 182, 91, 45, 
     22, 11, 5, 2, 1, 0, 0, 183, 91, 45, 22, 11, 5, 2, 1, 0, 0, 184, 92, 46, 23, 11, 5, 2, 1, 0, 0, 185, 92, 
     46, 23, 11, 5, 2, 1, 0, 0, 186, 93, 46, 23, 11, 5, 2, 1, 0, 0, 187, 93, 46, 23, 11, 5, 2, 1, 0, 0, 188, 
     94, 47, 23, 11, 5, 2, 1, 0, 0, 189, 94, 47, 23, 11, 5, 2, 1, 0, 0, 190, 95, 47, 23, 11, 5, 2, 1, 0, 0, 
     191, 95, 47, 23, 11, 5, 2, 1, 0, 0, 192, 96, 48, 24, 12, 6, 3, 1, 0, 0, 193, 96, 48, 24, 12, 6, 3, 1, 0, 
     0, 194, 97, 48, 24, 12, 6, 3, 1, 0, 0, 195, 97, 48, 24, 12, 6, 3, 1, 0, 0, 196, 98, 49, 24, 12, 6, 3, 1, 
     0, 0, 197, 98, 49, 24, 12, 6, 3, 1, 0, 0, 198, 99, 49, 24, 12, 6, 3, 1, 0, 0, 199, 99, 49, 24, 12, 6, 3, 
     1, 0, 0, 200, 100, 50, 25, 12, 6, 3, 1, 0, 0, 201, 100, 50, 25, 12, 6, 3, 1, 0, 0, 202, 101, 50, 25, 12, 
     6, 3, 1, 0, 0, 203, 101, 50, 25, 12, 6, 3, 1, 0, 0, 204, 102, 51, 25, 12, 6, 3, 1, 0, 0, 205, 102, 51, 25, 
     12, 6, 3, 1, 0, 0, 206, 103, 51, 25, 12, 6, 3, 1, 0, 0, 207, 103, 51, 25, 12, 6, 3, 1, 0, 0, 208, 104, 52, 
     26, 13, 6, 3, 1, 0, 0, 209, 104, 52, 26, 13, 6, 3, 1, 0, 0, 210, 105, 52, 26, 13, 6, 3, 1, 0, 0, 211, 105, 
     52, 26, 13, 6, 3, 1, 0, 0, 212, 106, 53, 26, 13, 6, 3, 1, 0, 0, 213, 106, 53, 26, 13, 6, 3, 1, 0, 0, 214, 
     107, 53, 26, 13, 6, 3, 1, 0, 0, 215, 107, 53, 26, 13, 6, 3, 1, 0, 0, 216, 108, 54, 27, 13, 6, 3, 1, 0, 0, 
     217, 108, 54, 27, 13, 6, 3, 1, 0, 0, 218, 109, 54, 27, 13, 6, 3, 1, 0, 0, 219, 109, 54, 27, 13, 6, 3, 1, 
     0, 0, 220, 110, 55, 27, 13, 6, 3, 1, 0, 0, 221, 110, 55, 27, 13, 6, 3, 1, 0, 0, 222, 111, 55, 27, 13, 6, 
     3, 1, 0, 0, 223, 111, 55, 27, 13, 6, 3, 1, 0, 0, 224, 112, 56, 28, 14, 7, 3, 1, 0, 0, 225, 112, 56, 28, 
     14, 7, 3, 1, 0, 0, 226, 113, 56, 28, 14, 7, 3, 1, 0, 0, 227, 113, 56, 28, 14, 7, 3, 1, 0, 0, 228, 114, 57, 
     28, 14, 7, 3, 1, 0, 0, 229, 114, 57, 28, 14, 7, 3, 1, 0, 0, 230, 115, 57, 28, 14, 7, 3, 1, 0, 0, 231, 115, 
     57, 28, 14, 7, 3, 1, 0, 0, 232, 116, 58, 29, 14, 7, 3, 1, 0, 0, 233, 116, 58, 29, 14, 7, 3, 1, 0, 0, 234, 
     117, 58, 29, 14, 7, 3, 1, 0, 0, 235, 117, 58, 29, 14, 7, 3, 1, 0, 0, 236, 118, 59, 29, 14, 7, 3, 1, 0, 0, 
     237, 118, 59, 29, 14, 7, 3, 1, 0, 0, 238, 119, 59, 29, 14, 7, 3, 1, 0, 0, 239, 119, 59, 29, 14, 7, 3, 1, 
     0, 0, 240, 120, 60, 30, 15, 7, 3, 1, 0, 0, 241, 120, 60, 30, 15, 7, 3, 1, 0, 0, 242, 121, 60, 30, 15, 7, 
     3, 1, 0, 0, 243, 121, 60, 30, 15, 7, 3, 1, 0, 0, 244, 122, 61, 30, 15, 7, 3, 1, 0, 0, 245, 122, 61, 30, 
     15, 7, 3, 1, 0, 0, 246, 123, 61, 30, 15, 7, 3, 1, 0, 0, 247, 123, 61, 30, 15, 7, 3, 1, 0, 0, 248, 124, 62, 
     31, 15, 7, 3, 1, 0, 0, 249, 124, 62, 31, 15, 7, 3, 1, 0, 0, 250, 125, 62, 31, 15, 7, 3, 1, 0, 0, 251, 125, 
     62, 31, 15, 7, 3, 1, 0, 0, 252, 126, 63, 31, 15, 7, 3, 1, 0, 0, 253, 126, 63, 31, 15, 7, 3, 1, 0, 0, 254, 
     127, 63, 31, 15, 7, 3, 1, 0, 0, 255, 127, 63, 31, 15, 7, 3, 1, 0, 0, 256, 128, 64, 32, 16, 8, 4, 2, 1, 0, 
     257, 128, 64, 32, 16, 8, 4, 2, 1, 0, 258, 129, 64, 32, 16, 8, 4, 2, 1, 0, 259, 129, 64, 32, 16, 8, 4, 2, 
     1, 0, 260, 130, 65, 32, 16, 8, 4, 2, 1, 0, 261, 130, 65, 32, 16, 8, 4, 2, 1, 0, 262, 131, 65, 32, 16, 8, 
     4, 2, 1, 0, 263, 131, 65, 32, 16, 8, 4, 2, 1, 0, 264, 132, 66, 33, 16, 8, 4, 2, 1, 0, 265, 132, 66, 33, 
     16, 8, 4, 2, 1, 0, 266, 133, 66, 33, 16, 8, 4, 2, 1, 0, 267, 133, 66, 33, 16, 8, 4, 2, 1, 0, 268, 134, 67, 
     33, 16, 8, 4, 2, 1, 0, 269, 134, 67, 33, 16, 8, 4, 2, 1, 0, 270, 135, 67, 33, 16, 8, 4, 2, 1, 0, 271, 135, 
     67, 33, 16, 8, 4, 2, 1, 0, 272, 136, 68, 34, 17, 8, 4, 2, 1, 0, 273, 136, 68, 34, 17, 8, 4, 2, 1, 0, 274, 
     137, 68, 34, 17, 8, 4, 2, 1, 0, 275, 137, 68, 34, 17, 8, 4, 2, 1, 0, 276, 138, 69, 34, 17, 8, 4, 2, 1, 0, 
     277, 138, 69, 34, 17, 8, 4, 2, 1, 0, 278, 139, 69, 34, 17, 8, 4, 2, 1, 0, 279, 139, 69, 34, 17, 8, 4, 2, 
     1, 0, 280, 140, 70, 35, 17, 8, 4, 2, 1, 0, 281, 140, 70, 35, 17, 8, 4, 2, 1, 0, 282, 141, 70, 35, 17, 8, 
     4, 2, 1, 0, 283, 141, 70, 35, 17, 8, 4, 2, 1, 0, 284, 142, 71, 35, 17, 8, 4, 2, 1, 0, 285, 142, 71, 35, 
     17, 8, 4, 2, 1, 0, 286, 143, 71, 35, 17, 8, 4, 2, 1, 0, 287, 143, 71, 35, 17, 8, 4, 2, 1, 0, 288, 144, 72, 
     36, 18, 9, 4, 2, 1, 0, 289, 144, 72, 36, 18, 9, 4, 2, 1, 0, 290, 145, 72, 36, 18, 9, 4, 2, 1, 0, 291, 145, 
     72, 36, 18, 9, 4, 2, 1, 0, 292, 146, 73, 36, 18, 9, 4, 2, 1, 0, 293, 146, 73, 36, 18, 9, 4, 2, 1, 0, 294, 
     147, 73, 36, 18, 9, 4, 2, 1, 0, 295, 147, 73, 36, 18, 9, 4, 2, 1, 0, 296, 148, 74, 37, 18, 9, 4, 2, 1, 0, 
     297, 148, 74, 37, 18, 9, 4, 2, 1, 0, 298, 149, 74, 37, 18, 9, 4, 2, 1, 0, 299, 149, 74, 37, 18, 9, 4, 2,
     1, 0, 300, 150, 75, 37, 18, 9, 4, 2, 1, 0);

is @got.elems, @exp.elems, "Right shift cross operator produces correct number of values";
my $i = 0;
while +@exp {
    my $elems = min(+@exp, 32);
    is @got.splice(0, $elems), @exp.splice(0, $elems), "Right shift is two's complement, {$i*32}..{$i++*32+$elems}";
}
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/sign.t����������������������������������������������������������������0000664�0001750�0001750�00000004171�12224265625�016302� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 35;

# L<S32::Numeric/Real/"=item sign">

=begin pod

Basic tests for the sign() builtin

=end pod

is(0.sign, 0, 'got the right sign for 0');
is(-100.sign, -1, 'got the right sign for -100');
is(100.sign, 1, 'got the right sign for 100');
is((3/2).sign, 1, 'got the right sign for 3/2');
is((-3/2).sign, -1, 'got the right sign for -3/2');
is(1.5e0.sign, 1, 'got the right sign for 1.5e1');
is(-1.5e0.sign, -1, 'got the right sign for -1.5e1');

isa_ok(0.sign, Int, 'got the right type for 0');
isa_ok(-100.sign, Int, 'got the right type for -100');
isa_ok(100.sign, Int, 'got the right type for 100');
isa_ok((3/2).sign, Int, 'got the right type for 3/2');
isa_ok((-3/2).sign, Int, 'got the right type for -3/2');
isa_ok(1.5e0.sign, Int, 'got the right type for 1.5e1');
isa_ok(-1.5e0.sign, Int, 'got the right type for -1.5e1');

is(sign(0), 0, 'got the right sign for 0');
is(sign(-100), -1, 'got the right sign for -100');
is(sign(100), 1, 'got the right sign for 100');
is(sign(1.5), 1, 'got the right sign for 1.5');
is(sign(-1.5), -1, 'got the right sign for -1.5');
is(sign(1.5e1), 1, 'got the right sign for 1.5e1');
is(sign(-1.5e1), -1, 'got the right sign for -1.5e1');

isa_ok(sign(0), Int, 'got the right type for 0');
isa_ok(sign(-100), Int, 'got the right type for -100');
isa_ok(sign(100), Int, 'got the right type for 100');
isa_ok(sign(1.5), Int, 'got the right type for 1.5');
isa_ok(sign(-1.5), Int, 'got the right type for -1.5');
isa_ok(sign(1.5e1), Int, 'got the right type for 1.5e1');
isa_ok(sign(-1.5e1), Int, 'got the right type for -1.5e1');

is(sign(Inf), 1, 'got correct sign for +Inf');
is(sign(-Inf), -1, 'got correct sign for -Inf');
isa_ok(sign(Inf), Int, 'got correct type for +Inf');
isa_ok(sign(-Inf), Int, 'got correct type for -Inf');
#?rakudo todo "Nom does not yet have a NaN framework in place"
#?niecza todo
#?pugs todo
is(sign(NaN),NaN, 'sign of NaN is NaN');

#?niecza todo
#?pugs skip 'Int'
nok sign(Int).defined, 'sign(Int) is undefined';
#?rakudo skip "Test is kind of doubtful IMO -- colomon"
#?niecza skip '#90'
#?pugs todo
nok sign(3+4i).defined, 'sign(Complex) fails';

done;

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/sqrt.t����������������������������������������������������������������0000664�0001750�0001750�00000002352�12224265625�016332� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 18;

# L<S32::Numeric/Real/"=item sqrt">

=begin pod

Basic tests for the sqrt() builtin

=end pod

is_approx(sqrt(2), 1.41421356, 'got the square root of 2');
is_approx(sqrt(5) * sqrt(5), 5,   'got the square root of 5');
is_approx(sqrt(42) * sqrt(42), 42, 'got the square root of 42');
is_approx(sqrt(1/42) * sqrt(1/42), 1/42, 'got the square root of 1/42');
is_approx(sqrt(1e2),10, 'got square root of 1e2');

is_approx(2.sqrt, 1.41421356, 'got the square root of 2');
is_approx(5.sqrt * sqrt(5), 5,   'got the square root of 5');
is_approx(42.sqrt * sqrt(42), 42, 'got the square root of 42');
is_approx(1/42.sqrt * sqrt(1/42), 1/42, 'got the square root of 1/42');
is_approx(1e2.sqrt, 10, 'got square root of 1e2');

is(sqrt(-1), NaN, 'sqrt(-1) is NaN');
is(sqrt(NaN), NaN, 'sqrt(NaN) is NaN');
is(sqrt(Inf), Inf, 'sqrt(Inf) is Inf');
is(sqrt(-Inf), NaN, 'sqrt(-Inf) is NaN');

is(sqrt(-0.0e0), -0.0e0, 'sqrt preserves sign of Num zero');

# The spec specifies a branch cut in the complex plane of -pi <= theta <= pi
is_approx(sqrt(-1 +0i), 1i, 'got the square root of -1+0i');

is_approx(sqrt(1i), (1+1i)/sqrt(2), 'got the square root of 1i');
is_approx(sqrt(-1i), (1-1i)/sqrt(2), 'got the square root of -1i');

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/stringify.t�����������������������������������������������������������0000664�0001750�0001750�00000006321�12224265625�017357� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Numeric/Complex/"=item gist">

#?DOES 4
sub Complex_str_test($value, $str_nucleus) {
    #?pugs todo
    is ~$value, $str_nucleus, "~<$str_nucleus>";
    #?pugs skip 'coercion'
    is $value.Str, $str_nucleus, "<$str_nucleus>.Str";
    #?pugs skip '.gist'
    is $value.gist, $str_nucleus, "<$str_nucleus>.gist";
    #?rakudo todo 'Complex.perl'
    #?pugs todo
    is $value.perl, "<$str_nucleus>", "<$str_nucleus>.perl";
}

# basic syntactic correctness - sign flags, lack of space
Complex_str_test (3 + 4i), '3+4i';
Complex_str_test (3 - 4i), '3-4i';
Complex_str_test (-3 + 4i), '-3+4i';
# use proper Num formatting - fractionalComplex_str_testm
Complex_str_test (3.5 + 4i), '3.5+4i';
Complex_str_test (3 + 4.5i), '3+4.5i';
# infinities
Complex_str_test (Inf + 3i), 'Inf+3i';
#?pugs skip 'parsefail'
Complex_str_test (0 + Inf\i), '0+Inf\i';
Complex_str_test (-Inf + 3i), '-Inf+3i';
#?pugs skip 'parsefail'
Complex_str_test (0 - Inf\i), '0-Inf\i';
Complex_str_test (NaN + 3i), 'NaN+3i';
#?pugs skip 'parsefail'
Complex_str_test (0 + NaN\i), '0+NaN\i';

# quick check that type objects stringify correctly - this has been a problem
# for Niecza in the past

#?pugs skip 'gist'
is Complex.gist, '(Complex)', 'Complex.gist';
#?pugs todo
is Complex.perl, 'Complex', 'Complex.perl';
# XXX Should ~Complex and Complex.Str return something specific?  For now
# just make sure they don't die
lives_ok { ~Complex }, '~Complex does not die';
#?pugs skip 'coercion'
lives_ok { Complex.Str }, 'Complex.Str does not die';

# L<S32::Numeric/Rat/"=item gist">

#?DOES 4
sub Rat_str_test($value, $str_nucleus, $str, $perl = $str) {
    #?pugs 2 skip 'coercion'
    is ~$value, $str, "~<$str_nucleus>";
    is $value.Str, $str, "<$str_nucleus>.Str";
    #?pugs skip '.gist'
    is $value.gist, $str, "<$str_nucleus>.gist";
    #?pugs todo
    is $value.perl, $perl, "<$str_nucleus>.perl";
    
    # FatRat tests
    is ~$value.FatRat, $str, "~<$str_nucleus>.FatRat";
    is $value.FatRat.Str, $str, "<$str_nucleus>.FatRat.Str";
    is $value.FatRat.gist, $str, "<$str_nucleus>.FatRat.gist";
}

# basic format test
Rat_str_test 1/2, '1/2', '0.5';
Rat_str_test -1/2, '-1/2', '-0.5';
# 0/1 and 1/1 are Rats too!
Rat_str_test 0/2, '0/1', '0', '0.0';
Rat_str_test 1/1, '1/1', '1', '1.0';
Rat_str_test 13/39, '1/3', '0.333333', '<1/3>';
Rat_str_test 1000001/10000, '1000001/10000', '100.0001';
Rat_str_test -1000001/10000, '-1000001/10000', '-100.0001';
Rat_str_test 555555555555555555555555555555555555555555555/5,
             '555555555555555555555555555555555555555555555/5',
             '111111111111111111111111111111111111111111111',
             '111111111111111111111111111111111111111111111.0';
# Bignum sanity
#?rakudo skip 'big stuff'
Rat_str_test (4.5 ** 60), 
             '1797010299914431210413179829509605039731475627537851106401/1152921504606846976',
             '1558657976916843360832062017400788597510.058834953945635510598466400011830046423710882663726806640625';

#?pugs skip '.gist'
is Rat.gist, '(Rat)', 'Rat.gist';
#?pugs todo
is Rat.perl, 'Rat', 'Rat.perl';
lives_ok { ~Rat }, '~Rat does not die';
lives_ok { Rat.Str }, 'Rat.Str does not die';

# TODO: FatRat, Num (once better specced), Int (maybe, but hard to mess up)

# vim: ft=perl6
done;
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-num/unpolar.t�������������������������������������������������������������0000664�0001750�0001750�00000005217�12224265625�017024� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 199;

# L<S32::Numeric/Numeric/=item cis>
my $pi = 312689/99532;

{
    is_approx(cis(0),        1 + 0i,       "cis(0)     == 1");
    is_approx(cis($pi),      -1 + 0i,      "cis(pi)    == -1");
    is_approx(cis($pi / 2),  1i,           "cis(pi/2)  == i");
    is_approx(cis(3*$pi / 2),-1i,          "cis(3pi/2) == -i");
}

# Test that 1.unpolar == cis
# L<S32::Numeric/Numeric/=item cis>
# L<S32::Numeric/Numeric/=item unpolar>

{
    for 1...20 -> $i {
        my $angle = 2 * $pi * $i / 20;
        is_approx(cis($i), 1.unpolar($i), "cis(x) == 1.unpolar(x) No. $i");
        is_approx($i.cis, 1.unpolar($i), "x.cis == 1.unpolar(x) No. $i");
        is_approx($i.Rat.cis, 1.unpolar($i), "x.Rat.cis == 1.unpolar(x) No. $i");
        is_approx($i.Num.cis, 1.unpolar($i), "x.Num.cis == 1.unpolar(x) No. $i");
    }
}

# L<S32::Numeric/Numeric/=item abs>
# L<S32::Numeric/Numeric/=item unpolar>
#
# Test that unpolar() doesn't change the absolute value

{
    my $counter = 1;
    for 1...10 -> $abs {
        for 1...10 -> $a {
            my $angle = 2 * $pi * $a / 10;
            is_approx($abs.unpolar($angle).abs, $abs,
                      "unpolar doesn't change the absolute value (No. $counter)");
            $counter++;
        }
    }
}

# L<S32::Numeric/Numeric/=item unpolar>
{
    # Basic tests for unpolar()
    my $s = 2 * sqrt(2);

    is_approx(4.unpolar(0),         4,     "4.unpolar(0)    == 4");
    is_approx(4.unpolar($pi/4),     $s + ($s)i ,"4.unpolar(pi/4) == 2+2i");
    is_approx(4.unpolar($pi/2),     4i,    "4.unpolar(pi/2) == 4i");
    is_approx(4.unpolar(3.Num*$pi/4),   -$s + ($s)i,"4.unpolar(3*pi/4) == -2+2i");
    is_approx(4.unpolar($pi),       -4,    "4.unpolar(pi)   == -4");
}

{
    # Basic tests for unpolar()
    my $s = 2 * sqrt(2);

    is_approx(4.Rat.unpolar(0),         4,     "4.Rat.unpolar(0)    == 4");
    is_approx(4.Rat.unpolar($pi/4),     $s + ($s)i ,"4.Rat.unpolar(pi/4) == 2+2i");
    is_approx(4.Rat.unpolar($pi/2),     4i,    "4.Rat.unpolar(pi/2) == 4i");
    is_approx(4.Rat.unpolar(3.Num*$pi/4),   -$s + ($s)i,"4.Rat.unpolar(3*pi/4) == -2+2i");
    is_approx(4.Rat.unpolar($pi),       -4,    "4.Rat.unpolar(pi)   == -4");
}

{
    # Basic tests for unpolar()
    my $s = 2 * sqrt(2);

    is_approx(4.Num.unpolar(0),         4,     "4.Num.unpolar(0)    == 4");
    is_approx(4.Num.unpolar($pi/4),     $s + ($s)i ,"4.Num.unpolar(pi/4) == 2+2i");
    is_approx(4.Num.unpolar($pi/2),     4i,    "4.Num.unpolar(pi/2) == 4i");
    is_approx(4.Num.unpolar(3.Num*$pi/4),   -$s + ($s)i,"4.Num.unpolar(3*pi/4) == -2+2i");
    is_approx(4.Num.unpolar($pi),       -4,    "4.Num.unpolar(pi)   == -4");
}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-scalar/defined.t����������������������������������������������������������0000664�0001750�0001750�00000010477�12224265625�017414� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 56;

# L<S32::Basics/Mu/=item defined>

=begin pod

Tests for the defined() builtin

=end pod

#?pugs skip 'Mu'
ok(!defined(Mu), 'Mu is not defined');
ok(!defined(Int), 'Int is not defined');
ok(!defined(Num), 'Num is not defined');
ok(!defined(Str), 'Str is not defined');

ok(defined(1),   'numeric literal 1 is defined');
ok(defined(""),  'empty string is defined');
ok(defined("a"), '"a" is defined');
ok(defined(0),   'numeric literal 0 is defined');
ok(defined(()),  'empty Parcel is defined');
ok(defined([]),  'empty Array is defined');
ok(defined({}),  'empty Hash is defined');

my $foo;
ok(!defined($foo), 'unassigned variable $foo is undefined');

$foo = 1;
ok(defined($foo), 'variable $foo is now defined (as numeric literal 1)');

$foo = "";
ok(defined($foo), 'variable $foo is now defined (as a empty string)');

#?pugs emit #
$foo = Nil;
#?pugs skip "Nil"
ok(!defined($foo), 'variable $foo is now undefined again');

$foo = "a";
ok(defined($foo), 'variable $foo is now defined (as string "a")');

#?pugs emit #
$foo = Mu;
#?pugs skip 'Mu'
ok(!defined($foo), 'variable $foo is now undefined again');

$foo = "b";
ok(defined($foo), 'variable $foo is now defined (as string "b")');

$foo = 0;
ok(defined($foo), 'variable $foo is now defined (as numeric literal 0)');

{
    undefine($foo);
    ok(!defined($foo), 'undefine $foo works');
}

# containers

my @bax;
ok(defined(@bax), 'unassigned variable @bax is defined');

@bax = 3, 4, 5;
ok(defined(@bax), 'unassigned variable @bax is defined');

#?pugs emit #
@bax = Nil;
#?pugs skip 'Nil'
ok(defined(@bax), 'variable @bax is defined after assigning Nil');

# try the invocant syntax

{
    my Mu $foo;
    ok(!$foo.defined, 'unassigned variable $foo is undefined');

    $foo = 1;
    ok($foo.defined, 'variable $foo is now defined (as numeric literal 1)');

    $foo = "";
    ok($foo.defined, 'variable $foo is now defined (as a empty string)');

    #?pugs emit #
    $foo = Nil;
    #?pugs skip 'Nil'
    ok(!$foo.defined, 'variable $foo is now undefined again');

    $foo = "a";
    ok($foo.defined, 'variable $foo is now defined (as string "a")');

    #?pugs emit #
    $foo = Mu;
    #?pugs skip 'Mu'
    ok(!$foo.defined, 'variable $foo is now undefined again');

    $foo = "b";
    ok($foo.defined, 'variable $foo is now defined (as string "b")');

    $foo = 0;
    ok($foo.defined, 'variable $foo is now defined (as numeric literal 0)');

{
    undefine($foo);
    ok(!$foo.defined, 'undefine $foo works');
}
}

# RT #81352
# Ensure that we always get Bools
#?pugs skip "isa_ok"
{
    isa_ok defined(Mu), Bool, 'defined(Mu) returns a Bool';
    isa_ok Mu.defined, Bool, 'Mu.defined returns a Bool';
    isa_ok defined(Int), Bool, 'defined(Int) returns a Bool';
    isa_ok Int.defined, Bool, 'Int.defined returns a Bool';
    isa_ok defined(1), Bool, 'defined(1) returns a Bool';
    isa_ok 1.defined, Bool, '1.defined returns a Bool';
    isa_ok defined("a"), Bool, 'defined("a") returns a Bool';
    isa_ok "a".defined, Bool, '"a".defined returns a Bool';
    isa_ok defined(()), Bool, 'defined(()) returns a Bool';
    isa_ok ().defined, Bool, '().defined returns a Bool';
    isa_ok defined({}), Bool, 'defined({}) returns a Bool';
    isa_ok {}.defined, Bool, '{}.defined returns a Bool';

    my $bar;
    isa_ok defined($bar), Bool, 'defined($bar) with $bar unset returns a Bool';
    isa_ok $bar.defined, Bool, '$bar.defined with $bar unset returns a Bool';
    $bar = "";
    isa_ok defined($bar), Bool, 'defined($bar) with $bar eq "" returns a Bool';
    isa_ok $bar.defined, Bool, '$bar.defined with $bar eq "" returns a Bool';
    $bar = 7;
    isa_ok defined($bar), Bool, 'defined($bar) with $bar == 7 returns a Bool';
    isa_ok $bar.defined, Bool, '$bar.defined with $bar == 7 returns a Bool';
    $bar = Mu;
    isa_ok defined($bar), Bool, 'defined($bar) with $bar set to Mu returns a Bool';
    isa_ok $bar.defined, Bool, '$bar.defined with $bar set to Mu returns a Bool';
}

# While porting a Perl 5 solution to QoTW regular #24, I noticed the following bug:
#   my %a = (a => 1);
#   defined %a{"b"}; # true!
my %a = (a => 1);
ok defined(%a{"a"}),        "defined on a hash with parens (1)";
ok !defined(%a{"b"}),       "defined on a hash with parens (2)";

# RT #76448
ok defined('a' => 5) ~~ Bool, 'defined is a listop, not a prefix op';
ok &defined, '&defined is available';

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-scalar/perl.t�������������������������������������������������������������0000664�0001750�0001750�00000001525�12224265625�016752� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

# simple array
{
    my $a = 1;
    is $a.perl, '1',
      'can we serialize a simple scalar';
    my $ra = eval($a.perl);
    is_deeply $ra, $a, 'can we roundtrip simple scalar';
    ok $ra.VAR.of =:= Mu, 'make sure any value can be stored';
} #3

#?pugs   skip "cannot roundtrip scalars with constrained values"
#?niecza skip "cannot roundtrip scalars with constrained values"
# array with constrained values
{
    my Int $a = 1;
    #?rakudo todo "cannot roundtrip constrained scalars yet"
    is $a.perl, 'Int(1)',
      'can we serialize a scalar with constrained values';
    my $ra = eval($a.perl);
    is_deeply $ra, $a, 'can we roundtrip scalar constrained values';
    #?rakudo todo "cannot roundtrip constrained scalars yet"
    ok $ra.VAR.of =:= Int, 'make sure roundtripped values are Int';
} #3

#vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-scalar/undef.t������������������������������������������������������������0000664�0001750�0001750�00000023441�12227737244�017116� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
#?pugs emit #
BEGIN { @*INC.push('t/spec/packages/') };
#?pugs emit #
use Test::Util;

=begin pod

'Mu' and 'undefine' tests

This test file contains two sections: a port of the perl5 'undef.t' tests, and
perl6-specific tests.

=end pod

# Note: See thread "Undef issues" by Adrian Taylor on p6l
# L<http://groups.google.com/groups?threadm=20050601002444.GB32060@wall.org>
#   On Tue, May 24, 2005 at 10:53:59PM +1000, Stuart Cook wrote:
#   : I'm not sure whether this behaviour is supposed to be changing.
#   
#   It is.  I think we decided to make the value undef, and the function
#   undefine().  (But these days most values of undef really ought to
#   be constructed and returned (or thrown) using fail().)
#   
#   Larry

plan 86;

our $GLOBAL;

# L<S32::Basics/Mu/=item defined>

ok(!defined(Mu), "Mu is not defined");

{
    my $a;
    ok(!defined($a), "uninitialized lexicals are undefined");

    ok(!defined($GLOBAL), "uninitialized package vars are undefined");

    $a += 1;
    ok(defined($a), "initialized var is defined");
    #?niecza todo
    #?pugs skip 'is_run'
    is_run( 'my $a; $a += 1', { err => '', out => '', status => 0 },
            'increment of undefined variable does not warn' );

    undefine $a;
    ok(!defined($a), "undefine($a) does");

    $a = "hi";
    ok(defined($a), "string");

    my $b;
    $a = $b;
    ok(!defined($a), "assigning another undefined lexical");

    $a = $GLOBAL;
    ok(!defined($a), "assigning another undefined global");
}

# L<S32::Basics/Mu/"=item undefine">
{
    my @ary = "arg1";
    my $a = @ary.pop;
    ok(defined($a), "pop from array");
    $a = @ary.pop;
    ok(!defined($a), "pop from empty array");

    @ary = "arg1";
    $a = @ary.shift;
    ok(defined($a), "shift from array");
    $a = @ary.shift;
    ok(!defined($a), "shift from empty array");

    my %hash = ( bar => 'baz', quux => 'quuz' );
    ok(defined(%hash<bar>), "hash subscript");
    ok(!defined(%hash<bargho>), "non-existent hash subscript");

    undefine %hash<bar>;
    ok(!defined(%hash<bar>), "undefine hash subscript");

    %hash<bar> = "baz";
    #?pugs emit #
    %hash<bar>:delete;
    #?pugs 3 skip ':delete'
    ok(!defined(%hash<bar>), "delete hash subscript");

    ok(defined(@ary), "aggregate array defined");
    ok(defined(%hash), "aggregate hash defined");

    undefine(@ary);
#?pugs todo 'bug'
#?rakudo todo 'definedness of array'
#?niecza todo 'definedness of array'
    ok(!defined(@ary), "undefine array");

    #?niecza emit #
    undefine(%hash);
#?pugs todo 'bug'
#?rakudo todo 'definedness of hash'
#?niecza todo 'definedness of hash'
    ok(!defined(%hash), "undefine hash");

    @ary = (1);
    ok(defined(@ary), "define array again");
    %hash = (1,1);
    ok(defined(%hash), "define hash again");
}

#?rakudo skip 'access to &your_sub'
#?niecza skip 'huh?'
{
    sub a_sub { "møøse" }

    ok(defined(&a_sub), "defined sub");
#?pugs todo 'parsefail'
    ok(eval('defined(%«$?PACKAGE\::»<&a_sub>)'), "defined sub (symbol table)");

#?pugs todo 'feature'
    ok(eval('!defined(&a_subwoofer)'), "undefined sub");
#?pugs todo 'feature'
    ok(eval('!defined(%«$?PACKAGE\::»<&a_subwoofer>)'), "undefined sub (symbol table)");
    
    dies_ok { undefine &a_sub }, 'die trying to undefine a sub';
    ok defined &a_sub, 'sub is still defined after attempt to undefine';
}

# TODO: find a read-only value to try and assign to, since we don't
# have rules right now to play around with (the p5 version used $1)
#eval { "constant" = "something else"; };
#is($!, "Modification of a read", "readonly write yields exception");

# skipped tests for tied things

# skipped test for attempt to undef a bareword -- no barewords here.

# TODO: p5 "bugid 3096
# undefing a hash may free objects with destructors that then try to
# modify the hash. To them, the hash should appear empty."


# Test LHS assignment to undef:
# XXX shouldn't that be * instead of undef?
# yes, this chunk should move to a different file --Larry

#?pugs skip "Can't modify constant item: VNum Infinity"
{
    my $interesting;
    (*, *, $interesting) = (1,2,3);
    is($interesting, 3, "Undef on LHS of list assignment");

    (*, $interesting, *) = (1,2,3);
    is($interesting, 2, "Undef on LHS of list assignment");

    ($interesting, *, *) = (1,2,3);
    is($interesting, 1, "Undef on LHS of list assignment");

    sub two_elements() { (1,2) };
    (*,$interesting) = two_elements();
    is($interesting, 2, "Undef on LHS of function assignment");

    ($interesting, *) = two_elements();
    is($interesting, 1, "Undef on LHS of function assignment");
}

=begin pod

Perl6-specific tests

=end pod

#?niecza skip 'fun with undefine'
{
    # aggregate references

    my @ary = (<a b c d e>);
    my $ary_r = @ary; # ref
    isa_ok($ary_r, Array);
    ok(defined($ary_r), "array reference");

    undefine @ary;
    #?pugs todo
    ok(!+$ary_r, "undefine array referent");

    #?pugs todo
    is(+$ary_r, 0, "dangling array reference");

    my %hash = (1, 2, 3, 4);
    my $hash_r = %hash;
    #?pugs todo
    isa_ok($hash_r, "Hash");
    ok(defined($hash_r), "hash reference");
    undefine %hash;
    ok(defined($hash_r), "undefine hash referent:");
    #?pugs todo
    is(+$hash_r.keys, 0, "dangling hash reference");
}

#?niecza skip 'push does not vivify'
{
    my Array $an_ary;
    ok(!defined($an_ary), "my Array");
    nok( defined($an_ary[0]) , "my Array subscript - Mu");
    $an_ary.push("blergh");
    ok(defined($an_ary.pop), "push");
    nok(defined($an_ary.pop), "comes to shove");
}

{
    my Hash $a_hash;

    nok(defined($a_hash), "my Hash");
    nok(defined($a_hash<blergh>), "my Hash subscript - Mu");
    nok(defined($a_hash<blergh>), "my Hash subscript - Mu, no autovivification happened");

    $a_hash<blergh> = 1;
    #?pugs 2 skip ':delete'
    ok(defined($a_hash<blergh>:delete), "delete");
    nok(defined($a_hash<blergh>:delete), " - once only");
}


{
    class Dog {};
    my Dog $spot;

    ok(!defined($spot), "Unelaborated mutt");
    $spot .= new;
    ok(defined($spot), " - now real");
}

# rules
# TODO. refer to S05
# L<S05/Match objects/"they will all be undefined" closure
#                                 "let keyword">

# - unmatched alternative should bind to undef
#?rakudo skip 'Cannot use bind operator with this left-hand side'
#?niecza skip 'unspeclike use of %MY::'
#?DOES 10
{
    my ($num, $alpha);
    my ($rx1, $rx2);   #OK not used
    eval '
        $rx1 = rx
        / [ (\d+)      { let $<num>   := $0 }
        | (<alpha>+) { let $<alpha> := $1 }
        ]
        /;
        $rx2 = rx
        / [ $<num>  := (\d+)
        | $<alpha>:= (<alpha>+)
        ]
        /;
    ';
    for (<rx1 rx2>) {
        # I want symbolic lookups because I need the rx names for test results.

        eval '"1" ~~ %MY::{$_}';
    #?pugs todo 'unimpl'
        ok(defined($num), '{$_}: successful hypothetical');
        ok(!defined($alpha), '{$_}: failed hypothetical');

        eval '"A" ~~ %MY::{$_}';
        ok(!defined($num), '{$_}: failed hypothetical (2nd go)');
    #?pugs todo 'unimpl'
        ok(defined($alpha), '{$_}: successful hypothetical (2nd go)');
    }

    # - binding to hash keys only would leave values undefined
    eval '"a=b\nc=d\n" ~~ / $<matches> := [ (\w) = \N+ ]* /';
    #?pugs todo 'unimpl'
    ok(eval('$<matches> ~~ all(<a b>)'), "match keys exist");

    #ok(!defined($<matches><a>) && !defined($<matches><b>), "match values don't");
    #?pugs todo 'unimpl'
    ok(0 , "match values don't");
}

#?DOES 1
{
    # - $0, $1 etc. should all be undefined after a failed match
    #   (except for special circumstances)
        "abcde" ~~ /(.)(.)(.)/;
        "abcde" ~~ /(\d)/;
    ok((!try { grep { defined($_) }, ($0, $1, $2, $3, $4, $5) }),
            "all submatches undefined after failed match") or
        diag("match state: " ~ eval '$/');

    # XXX write me: "special circumstances"
}


# subroutines
{
    sub bar ($bar, $baz?, :$quux) {
        is($bar, "BAR", "defined param"); # sanity

        # L<S06/Optional parameters/Missing optional arguments>
        ok(!defined($baz), "unspecified optional param");

        # L<S06/Named parameters/Named parameters are optional>
        ok(!defined($quux), "unspecified optional param");
    }

    bar("BAR");

}

# autoloading
# L<S10/Autoloading>

# Currently waiting on
# - packages
# - symtable hash
# - autoloading itself

# Extra tests added due to apparent bugs
is((Any) + 1, 1, 'Any + 1');
is(1 + (Any), 1, '1 + Any');
is((Any) * 2, 0, 'Any * 2');
is(2 * (Any), 0, '2 * Any');
is((Any) xx 2, [Any, Any], 'Any xx 2');
is((Any) * (Any), 0, 'Any * Any');

# L<http://colabti.de/irclogger/irclogger_log/perl6?date=2006-09-12,Tue&sel=145#l186>
# See log above.  From IRC, TimToady says that both of these
# should be false.  (At time of writing, @(Mu,) is true.)
#?pugs todo 'feature', :depends<@() imposing context and not [] constructor>;
#?rakudo 2 todo 'todo: lists, defined, truthness'
#?niecza 2 todo 'huh?'
is ?(@(Mu,)), Bool::False, '?(@(Mu,)) is false';
is ?(list(Mu,)), Bool::False, '?(@(Mu,)) is false';

#?niecza todo 'dubious'
lives_ok { uc(eval("")) }, 'can use eval("") in further expressions';

{
    sub lie { Bool::False }
    ok lie() ~~ Bool, 'sub returns a bool';
    dies_ok { undefine lie }, 'attempt to undefine returned Bool type dies';
    ok lie() ~~ Bool, 'sub still returns a bool';
}

{
    sub def is rw { my $x = [] }   #OK not used
    ok def() ~~ Array, 'sub returns array';
    lives_ok { undefine def }, 'attempt to undefine returned array lives';
    ok def() ~~ Array, 'sub still returns array';

    dies_ok { undefine &def }, 'attempt to undefine sub dies';
    ok defined(&def), 'attempt to undefine sub fails';
    ok def() ~~ Array, 'can still call sub after attempt to undefine it';
}

# RT #69238
{
    sub foo { my $a = "baz"; undefine $a; undefine $a; $a; }
    ok !defined(foo()), 'can undefine $a twice without any troubles';
}

done;

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/append.t��������������������������������������������������������������0000664�0001750�0001750�00000001206�12224265625�016616� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# String appending with ~ operator
# L<S03/Changes to Perl 5 operators/string concatenation becomes stitching>

plan 7;

# Again, mostly stolen from Perl 5

my $a = 'ab' ~ 'c';
is($a, 'abc', '~ two literals correctly');

my $b = 'def';

my $c = $a ~ $b;
is($c, 'abcdef', '~ two variables correctly');

$c ~= "xyz";
is($c, 'abcdefxyz', '~= a literal string correctly');

my $d = $a;
$d ~= $b;
is($d, 'abcdef', '~= variable correctly');

is('' ~ '', '', 'Concatenating two empty strings');
is($d ~ '', $d, 'Concatenente non-empty and empty string');
is('' ~ $d, $d, 'Concatenente empty and non-empty string');

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/bool.t����������������������������������������������������������������0000664�0001750�0001750�00000000746�12224265625�016312� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 12;

nok ?'', "?'' is false";
isa_ok ?'', Bool, "?'' is Bool";
ok ?'hello', "?'hello' is true";
isa_ok ?'hello', Bool, "?'hello' is Bool";
nok ?'0', "?'0' is false";
isa_ok ?'0', Bool, "?'0' is Bool";

nok ''.Bool, "''.Bool is false";
isa_ok ''.Bool, Bool, "''.Bool is Bool";
ok 'hello'.Bool, "'hello'.Bool is true";
isa_ok 'hello'.Bool, Bool, "'hello'.Bool is Bool";
nok '0'.Bool, "'0'.Bool is false";
isa_ok '0'.Bool, Bool, "'0'.Bool is Bool";

# vim: ft=perl6
��������������������������rakudo-2013.12/t/spec/S32-str/capitalize.t����������������������������������������������������������0000664�0001750�0001750�00000003754�12224265625�017506� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 17;

# L<S32::Str/Str/wordcase>

#?rakudo.parrot skip 'related to RT #117889'
is wordcase(""),             "",               "wordcase('') works";
is wordcase("puGS Is cOOl!"), "Pugs Is Cool!", "wordcase('...') works";
is "puGS Is cOOl!".wordcase,  "Pugs Is Cool!", "'...'.wordcase works";
#?niecza 2 todo "wordcase somewhat stupid right now"
is "don't sit under the apple tree".wordcase, "Don't Sit Under The Apple Tree", "wordcase works properly with apostrophes";
is "tir-na nog'th".wordcase, "Tir-na Nog'th", "wordcase works properly with apostrophes and dashes";

my $a = "";
#?rakudo.parrot skip 'related to RT #117889'
is wordcase($a),             "",               "wordcase empty string";
$a = "puGS Is cOOl!";
is wordcase($a),             "Pugs Is Cool!",  "wordcase string works";
is $a,                         "puGS Is cOOl!",  "original string not touched";
is $a.wordcase,              "Pugs Is Cool!",  "wordcase string works";
is $a,                         "puGS Is cOOl!",  "original string not touched";
is "ab cD Ef".wordcase,      "Ab Cd Ef",       "works on ordinary string";


{
    $_ = "puGS Is cOOl!";
    is .wordcase, "Pugs Is Cool!", 'wordcase() uses \$_ as default';
}

# Non-ASCII chars:
is wordcase("äöü abcä"), "Äöü Abcä", "wordcase() works on non-ASCII chars";#

#?rakudo 2 todo 'graphemes results wrong'
#?niecza 2 todo 'charspec'
#?pugs todo
is wordcase("a\c[COMBINING DIAERESIS]üö abcä"), "Äöü Abcä", 'wordcase on string with grapheme precomposed';
#?pugs todo
is wordcase("a\c[COMBINING DOT ABOVE, COMBINING DOT BELOW] bc"),
    "A\c[COMBINING DOT BELOW, COMBINING DOT ABOVE] Bc",
    "wordcase on string with grapheme without precomposed";
    
# rest of the tests are moved from uc.t
is ~(0.wordcase), ~0, '.wordcase on Int';

#?pugs todo
{
    role A {
        has $.thing = 3;
    }
    my $str = "('Nothing much' but A).wordcase eq 'Nothing much'.wordcase";
    ok eval($str), $str;
}

# TODO: add tests for wordcase arguments

# vim: ft=perl6
��������������������rakudo-2013.12/t/spec/S32-str/chomp.t���������������������������������������������������������������0000664�0001750�0001750�00000011471�12224265625�016462� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 39;

=begin pod

Basic tests for the chomp() builtin

=end pod

# L<S32::Str/Str/=item chomp>

# Also see L<"http://use.perl.org/~autrijus/journal/25351">
#   &chomp and &wrap are now nondestructive; chomp returns the chomped part,
#   which can be defined by the filehandle that obtains the default string at
#   the first place. To get destructive behaviour, use the .= form.

# testing \n newlines
{
    my $foo = "foo\n";
    chomp($foo);
    is($foo, "foo\n", 'our variable was not yet chomped');
    $foo .= chomp;
    is($foo, 'foo', 'our variable is chomped correctly');
    $foo .= chomp;
    is($foo, 'foo', 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\n\n";
    $foo .= chomp;
    is($foo, "foo\n", 'our variable is chomped correctly');
    $foo .= chomp;
    is($foo, 'foo', 'our variable is chomped again correctly');
    $foo .= chomp;
    is($foo, 'foo', 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\nbar\n";
    $foo .= chomp;
    is($foo, "foo\nbar", 'our variable is chomped correctly');
    $foo .= chomp;
    is($foo, "foo\nbar", 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\n ";
    $foo .= chomp;
    is($foo, "foo\n ", 'our variable is chomped with no effect');
}

{
    my $foo = "foo\n\n";
    my $chomped = $foo.chomp;
    is($foo, "foo\n\n", ".chomp has no effect on the original string");
    is($chomped, "foo\n", ".chomp returns correctly chomped value");

    $chomped = $chomped.chomp;
    is($chomped, "foo", ".chomp returns correctly chomped value again");
}

# testing \r newlines
{
    my $foo = "foo\r";
    chomp($foo);
    is($foo, "foo\r", 'our variable was not yet chomped');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\r\r";
    $foo .= chomp;
    #?pugs todo
    is($foo, "foo\r", 'our variable is chomped correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped again correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\rbar\r";
    $foo .= chomp;
    #?pugs todo
    is($foo, "foo\rbar", 'our variable is chomped correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, "foo\rbar", 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\r ";
    $foo .= chomp;
    is($foo, "foo\r ", 'our variable is chomped with no effect');
}

{
    my $foo = "foo\r\r";
    my $chomped = $foo.chomp;
    is($foo, "foo\r\r", ".chomp has no effect on the original string");
    #?pugs todo
    is($chomped, "foo\r", ".chomp returns correctly chomped value");

    $chomped = $chomped.chomp;
    #?pugs todo
    is($chomped, "foo", ".chomp returns correctly chomped value again");
}

# testing \r\n newlines
{
    my $foo = "foo\r\n";
    chomp($foo);
    is($foo, "foo\r\n", 'our variable was not yet chomped');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\r\n\r\n";
    $foo .= chomp;
    #?pugs todo
    is($foo, "foo\r\n", 'our variable is chomped correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped again correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, 'foo', 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\r\nbar\r\n";
    $foo .= chomp;
    #?pugs todo
    is($foo, "foo\r\nbar", 'our variable is chomped correctly');
    $foo .= chomp;
    #?pugs todo
    is($foo, "foo\r\nbar", 'our variable is chomped again with no effect');
}

{
    my $foo = "foo\r\n ";
    $foo .= chomp;
    is($foo, "foo\r\n ", 'our variable is chomped with no effect');
}

{
    my $foo = "foo\r\n\r\n";
    my $chomped = $foo.chomp;
    is($foo, "foo\r\n\r\n", ".chomp has no effect on the original string");
    #?pugs todo
    is($chomped, "foo\r\n", ".chomp returns correctly chomped value");

    $chomped = $chomped.chomp;
    #?pugs todo
    is($chomped, "foo", ".chomp returns correctly chomped value again");
}

#testing strings with less than 2 characters
{
    my $foo = "\n";
    my $bar = "\r";
    my $baz = "";

    my $chomped = $foo.chomp;
    is($chomped, "", ".chomp works on string with just a newline");

    $chomped = $bar.chomp;
    #?pugs todo
    is($chomped, "", ".chomp works on string with just a carriage return");

    $chomped = $baz.chomp;
    is($chomped, "", ".chomp doesn't affect empty string");

    # \r\n newlines not tested because that's never less than 2 characters.
}
=begin pod

Basic tests for the chomp() builtin working on an array of strings

=end pod


# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/chop.t����������������������������������������������������������������0000664�0001750�0001750�00000001413�12224265625�016300� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item chop">

plan 6;

#
# Tests already covered by the specs
#

my $str = "foo";
is(chop($str), "fo", "o removed");
is($str, "foo", "original string unchanged");

is($str.chop, "fo", "o removed");
is($str, "foo", "original string unchanged");

is(chop("bar"), "ba", "chop on string literal");
is(chop(""), "", "chop on empty string literal");

# TODO: catch warning, what should be the return value ?
# my $undef_scalar;
# chop($undef_scalar)


# See L<"http://use.perl.org/~autrijus/journal/25351">:
#   &chomp and &wrap are now nondestructive; chomp returns the chomped part,
#   which can be defined by the filehandle that obtains the default string at
#   the first place. To get destructive behaviour, use the .= form.

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/comb.t����������������������������������������������������������������0000664�0001750�0001750�00000007217�12224265625�016277� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 41;

# L<S32::Str/Str/=item comb>

# comb Str
is "".comb, (), 'comb on empty string';
is "a".comb, <a>, 'default matcher on single character';
is "abcd".comb, <a b c d>, 'default matcher and limit';

is "a\tb".comb, ('a', "\t", 'b'), 'comb on string with \t';
is "a\nb".comb, ('a', "\n", 'b'), 'comb on string with \n';

is "äbcd".comb, <ä b c d>, 'comb on string with non-ASCII letter';

#?rakudo 2 todo 'graphemes not implemented'
#?niecza 2 todo 'charspec'
is "a\c[COMBINING DIAERESIS]b".comb, ("ä", "b",), 'comb on string with grapheme precomposed';
is( "a\c[COMBINING DOT ABOVE, COMBINING DOT BELOW]b".comb,
    ("a\c[COMBINING DOT BELOW, COMBINING DOT ABOVE]", "b", ),
    "comb on string with grapheme non-precomposed");


#?pugs skip "todo: Str.comb"
{
    my Str $hair = "Th3r3 4r3 s0m3 numb3rs 1n th1s str1ng";
    is $hair.comb(/\d+/), <3 3 4 3 0 3 3 1 1 1>, 'no limit returns all matches';
    is $hair.comb(/\d+/, -10), (), 'negative limit returns no matches';
    is $hair.comb(/\d+/, 0), (), 'limit of 0 returns no matches';
    is $hair.comb(/\d+/, 1), <3>, 'limit of 1 returns 1 match';
    is $hair.comb(/\d+/, 3), <3 3 4>, 'limit of 3 returns 3 matches';
    is $hair.comb(/\d+/, 1000000000), <3 3 4 3 0 3 3 1 1 1>, 'limit of 1 billion returns all matches quickly';
}

{
    is "a ab bc ad ba".comb(/«a\S*/), <a ab ad>,
        'match for any a* words';
    is "a ab bc ad ba".comb(/\S*a\S*/), <a ab ad ba>,
        'match for any *a* words';
}

{
    is "a ab bc ad ba".comb(/<< a\S*/), <a ab ad>,
        'match for any a* words';
    is "a ab bc ad ba".comb(/\S*a\S*/), <a ab ad ba>,
        'match for any *a* words';
}

#?pugs todo 'feature'
is "a ab bc ad ba".comb(/\S*a\S*/, 2), <a ab>, 'matcher and limit';

is "forty-two".comb().join('|'), 'f|o|r|t|y|-|t|w|o', q{Str.comb(/./)};

ok("forty-two".comb() ~~ Positional, '.comb() returns something Positional' );

# comb a list

#?pugs todo 'feature'
#?rakudo skip 'cannot call match, no signature matches'
#?niecza skip ':Perl5'
is (<a ab>, <bc ad ba>).comb(m:Perl5/\S*a\S*/), <a ab ad ba>,
     'comb a list';

# needed: comb a filehandle

{
    my @l = 'a23 b c58'.comb(/\w(\d+)/);
    is @l.join('|'), 'a23|c58', 'basic comb-without-matches sanity';
    isa_ok(@l[0], Str, 'first item is a Str');
    isa_ok(@l[1], Str, 'second item is a Str');
}

{
    my @l = 'a23 b c58'.comb(/\w(\d+)/, :match);
    is @l.join('|'), 'a23|c58', 'basic comb-with-matches sanity';
    isa_ok(@l[0], Match, 'first item is a Match');
    isa_ok(@l[1], Match, 'second item is a Match');
    is @l[0].from, 0, '.from of the first item is correct';
    is @l[0].to, 3, '.to of the first item is correct';
    is @l[1].from, 6, '.from of the second item is correct';
    is @l[1].to, 9, '.to of the second item is correct';
}

# RT #66340
#?niecza skip 'Huh?'
{
    my $expected_reason = rx:s/none of these signatures match/;

    try { 'RT 66340'.comb( 1 ) };
    ok $! ~~ Exception, '.comb(1) dies';
    ok "$!" ~~ $expected_reason, '.comb(1) dies for the expected reason';

    my $calls = 0;
    try { 'RT 66340'.comb( { $calls++ } ) };
    is $calls, 0, 'code passed to .comb is not called';
    ok $! ~~ Exception, '.comb({...}) dies';
    ok "$!" ~~ $expected_reason, '.comb({...}) dies for the expected reason';
}

{
    is comb( /./ , "abcd"), <a b c d>, 'Subroutine form default limit';
    is comb(/./ , "abcd" , 2 ), <a b>, 'Subroutine form with supplied limit';
    is comb(/\d+/ , "Th3r3 4r3 s0m3 numb3rs 1n th1s str1ng"), <3 3 4 3 0 3 3 1 1 1>, 'Subroutine form with no limit returns all matches';
    is comb(/\d+/ , "Th3r3 4r3 s0m3 numb3rs 1n th1s str1ng" , 2), <3 3>, 'Subroutine form with limit';
}

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/encode.t��������������������������������������������������������������0000664�0001750�0001750�00000003513�12241704255�016603� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 22;


# L<S32::Containers/Buf>

ok 'ab'.encode('ASCII') ~~ blob8, '$str.encode returns a blob8';
ok ('ab'.encode('ASCII') eqv blob8.new(97, 98)),  'encoding to ASCII';
is 'ab'.encode('ASCII').elems, 2, 'right length of Buf';
ok ('ö'.encode('UTF-8') eqv utf8.new(195, 182)), 'encoding to UTF-8';
is 'ab'.encode('UTF-8').elems, 2, 'right length of Buf';
is 'ö'.encode('UTF-8')[0], 195, 'indexing a utf8 gives correct value (1)';
is 'ö'.encode('UTF-8')[1], 182, 'indexing a utf8 gives correct value (1)';

is 'abc'.encode()[0], 97, 'can index one element in a Buf';
is_deeply 'abc'.encode()[1, 2], (98, 99), 'can slice-index a Buf';

# verified with Perl 5:
# perl -CS -Mutf8 -MUnicode::Normalize -e 'print NFD("ä")' | hexdump -C
#?rakudo skip 'We do not handle NDF yet'
ok ('ä'.encode('UTF-8', 'D') eqv Buf.new(:16<61>, :16<cc>, :16<88>)),
                'encoding to UTF-8, with NFD';

ok ('ä'.encode('UTF-8') eqv utf8.new(:16<c3>, :16<a4>)),
                'encoding ä utf8 gives correct numbers';

ok Buf.new(195, 182).decode ~~ Str, '.decode returns a Str';
is Buf.new(195, 182).decode, 'ö', 'decoding a Buf with UTF-8';
is Buf.new(246).decode('ISO-8859-1'), 'ö', 'decoding a Buf with Latin-1';

ok Buf ~~ Stringy, 'Buf does Stringy';
ok Buf ~~ Positional, 'Buf does Positional';

is 'abc'.encode('ascii').list.join(','), '97,98,99', 'Buf.list gives list of codepoints';

{
    my $temp;

    ok $temp = "\x1F63E".encode('UTF-16'), 'encode a string to UTF-16 surrogate pair';
    ok $temp = utf16.new($temp),           'creating utf16 Buf from a surrogate pair';
    is $temp[0], 0xD83D,                   'indexing a utf16 gives correct value';
    is $temp[1], 0xDE3E,                   'indexing a utf16 gives correct value';
    is $temp.decode(), "\x1F63E",          'decoding utf16 Buf to original value';
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/flip.t����������������������������������������������������������������0000664�0001750�0001750�00000002252�12224265625�016303� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/=item flip>

plan 13;

# As a function :
is( flip('Pugs'), 'sguP', "as a function");

# As a method :
is( "".flip, "", "empty string" );
is( 'Hello World !'.flip, '! dlroW olleH', "literal" );

# On a variable ?
my Str $a = 'Hello World !';
is( $a.flip, '! dlroW olleH', "with a Str variable" );
is( $a, 'Hello World !', "flip should not be in-place" );
is( $a .= flip, '! dlroW olleH', "after a .=flip" );

# Multiple iterations (don't work in 6.2.12) :
is( 'Hello World !'.flip.flip, 'Hello World !',
        "two flip in a row." );

# flip with unicode :
is( '䀻«'.flip,   '«»€ä', "some unicode characters" );

#?niecza 2 todo 'graphemes not implemented'
#?rakudo 2 todo 'graphemes not implemented'
#?pugs   2 skip 'graphemes not implemented'
is( "a\c[COMBINING DIAERESIS]b".flip, 'bä', "grapheme precomposed" );
is( "a\c[COMBINING DOT ABOVE, COMBINING DOT BELOW]b".flip,
    "ba\c[COMBINING DOT ABOVE, COMBINING DOT BELOW]",
    "grapheme without precomposed");

is 234.flip, '432', '.flip on non-string';
is flip(123), '321', 'flip() on non-strings';
{
    my $x = 'abc';
    $x.=flip;
    is $x, 'cba', 'in-place flip';
}


# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/indent.t��������������������������������������������������������������0000664�0001750�0001750�00000007560�12224265625�016641� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::Str/Str/"=item indent">

plan 62;

# TODO: Rakudo doesn't have full support for constants, so we have to assume a
# hardcoded 8 instead of $?TABSTOP for now.
my $tab = 8;

# Basic indentation

for 1..4 -> $i {
    is  'quack'.indent($i),
        ' ' x $i ~ 'quack',
        "Simple .indent($i)";
}

for 1..4 -> $i {
    is  "\x[2001] !".indent($i).ords.perl,
        ("\x[2001] " ~ (' ' x $i) ~ '!').ords.perl,
        "New indent goes after existing - .indent($i)";
}


# Same-whitespace-character indent

for 1..4 -> $i {
    for (' ', "\x[2000]") -> $prefix {
        is  ($prefix ~ 'quack').indent($i).perl,
            ($prefix x ($i + 1) ~ 'quack').perl,
            "Same space - .indent($i) prefix={$prefix.ord.fmt('"\\x[%x]"')}";
    }
}

is  "\tquack".indent($tab),
    "\t\tquack",
    'Samespace indent should work for a full $?TABSTOP with \\t';

for 1..$tab -> $i {
    for (' ', "\t", "\x[2000]") -> $prefix {
        is  ($prefix ~ ' ' ~ 'quack').indent($i).perl,
            ($prefix ~ ' ' ~ (' ' x $i) ~ 'quack').perl,
            "Mixed space - .indent($i) prefix={$prefix.ord.fmt('"\\x[%x]"')}";
    }
}


# Simple outdentation

is  '   quack'.indent(-2),
    ' quack',
    'Simple outdent';

is  "\t quack".indent(-1),
    "\tquack",
    'Simple outdent with tab (no explosion)';

is  '   quack'.indent(-4),
    'quack',
    'Excess outdent test for correct output';

# TODO: need a better way of detecting warn() calls, also need a test that it
# should only warn once per .indent call
given 'Excess outdent test for warning' -> $test {
'   quack'.indent(-4);
    flunk $test;
    CONTROL { default { pass $test; } }
}

# Whatever-star
#?niecza skip 'todo'
is ''.indent(*), '', 'indent(*) on empty string';

is  "  quack\n meow\n   helicopter fish".indent(*).perl,
    " quack\nmeow\n  helicopter fish".perl,
    'Whatever* outdent with at least 1 common indent';

is  " quack\nmeow\n  helicopter fish".indent(*).perl,
    " quack\nmeow\n  helicopter fish".perl,
    'Whatever* outdent with one line flush left already';

#?niecza todo
is "  quack\n\n    meow\n".indent(*),
   "quack\n\n  meow\n",
   ".indent(*) ignores empty lines";


# Tab expansion

is  "\t!".indent(-1),
    ' ' x ($tab - 1) ~ '!',
    'Tab explosion on outdent';

is  "\t\t!".indent(-1),
    "\t" ~ ' ' x ($tab - 1) ~ '!',
    'Test that tabs explode from the right';

ok  ([eq] ((' ' Xx 0..$tab - 1) X~ "\t")».indent(-4)),
    'Check that varying amounts of space before a tabstop explode in a visually consistent way';

is  "  \t!".indent(-1),
    ' ' x ($tab - 1) ~ '!',
    'Spaces before a hard tab should be coalesced into the tabstop when exploding';

is  "  \t\t!".indent(-1),
    "  \t" ~ ' ' x ($tab - 1) ~ '!',
    'Test that space-tab-tab outdent works as intended';

is  " \t \t quack".indent(-2),
    " \t" ~ (' ' x $tab - 1) ~ 'quack',
    'Check that mixed spaces and tabs outdent correctly';

is  "\tquack\n\t meow".indent($tab),
    "\t\tquack\n\t {' ' x $tab}meow",
    'Multiline indent test with tab-space indent';

is  "\ta\n b".indent(1).perl,
    "\ta\n b".lines».indent(1).join("\n").perl,
    'Multiline indent test with mixed line beginnings';

is  "\tquack\nmeow".indent($tab),
    "\t\tquack\n{' ' x $tab}meow",
    'Multiline $?TABSTOP-width indent with an unindented line and a tab-indented line';


# Misc
is  "\ta\n b".indent(0),
    "\ta\n b",
    '.indent(0) should be a no-op';

#?niecza todo
is "a\n\nb\n".indent(2).perl,
   "  a\n\n  b\n".perl,
   ".indent ignores empty lines";

#?niecza skip "weird scalar input"
#?rakudo skip 'coercion to Int'
is  "\ta\n b".indent(1).indent(16).indent(0).indent(*).perl,
    "\ta\n b".indent(True).indent('0x10').indent('0e0').indent(*).perl,
    '.indent accepts weird scalar input and coerces it to Int when necessary';

is  " \t a\n \t b\n".indent(1).perl,
    " \t  a\n \t  b\n".perl,
    'Indentation should not be appended after a trailing \n';
������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/index.t���������������������������������������������������������������0000664�0001750�0001750�00000005423�12224265625�016463� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item index">

plan 38;

# Type of return value
#?rakudo 2 skip 'StrPos not implemented'
#?niecza 2 skip 'StrPos'
#?pugs   2 skip 'StrPos'
isa_ok('abc'.index('b'), StrPos);
isa_ok('abc'.index('d'), StrPos);
#?pugs todo
ok(!'abc'.index('d'), 'failure object from index() evaluates to false');

# Simple - with just a single char

is(index("Hello World", "H"), 0, "One char, at beginning");
is(index("Hello World", "l"), 2, "One char, in the middle");
is(index("Hello World", "d"), 10, "One char, in the end");
#?pugs todo
ok(!defined(index("Hello World", "x")), "One char, no match");

is(index("Hello World", "l", 0), 2, "One char, find first match, pos = 0");
is(index("Hello World", "l", 2), 2, "- 1. match again, pos @ match");
is(index("Hello World", "l", 3), 3, "- 2. match");
is(index("Hello World", "l", 4), 9, "- 3. match");
#?pugs todo
ok(!defined(index("Hello World", "l", 10)), "- no more matches");

# Simple - with a string

is(index("Hello World", "Hello"), 0, "Substr, at beginning");
is(index("Hello World", "o W"), 4, "Substr, in the middle");
is(index("Hello World", "World"), 6, "Substr, at the end");
#?pugs todo
ok(!defined(index("Hello World", "low")), "Substr, no match");
is(index("Hello World", "Hello World"), 0, "Substr eq Str");

# Empty strings

is(index("Hello World", ""), 0, "Substr is empty");
is(index("", ""), 0, "Both strings are empty");
#?pugs todo
ok(!defined(index("", "Hello")), "Only main-string is empty");
is(index("Hello", "", 3), 3, "Substr is empty, pos within str");
is(index("Hello", "", 5), 5, "Substr is empty, pos at end of str");
is(index("Hello", "", 999), 5, "Substr is empty, pos > length of str");

# More difficult strings

is(index("ababcabcd", "abcd"), 5, "Start-of-substr matches several times");

is(index("uuúuúuùù", "úuù"), 4, "Accented chars");
is(index("Ümlaut", "Ü"), 0, "Umlaut");


#  call directly with the .notation

is("Hello".index("l"), 2, ".index on string");

# work on variables

my $a = "word";
is($a.index("o"), 1, ".index on scalar variable");

my @a = <Hello World>;
is(index(@a[0], "l"), 2, "on array element");
is(@a[0].index("l"), 2, ".index on array element");

# index on junctions, maybe this should be moved to t/junctions/ ?

#?pugs skip 'autothreading?'
{
    my $j = ("Hello"|"World");
    ok(index($j, "l") == 2, "index on junction");
    ok(index($j, "l") == 3, "index on junction");
    ok($j.index("l")  == 2, ".index on junction");
    ok($j.index("l")  == 3, ".index on junction");
}

ok 1234.index(3) == 2, '.index on non-strings (here: Int)';

{
    my $s = '1023';
    is $s.substr($s.index('0')), '023', 'Str.index("0") works';
    is $s.substr($s.index(0)),   '023', 'Str.index(0) works';
}

# RT #73122
is index("uuúuúuùù", "úuù"), 4, 'index works for non-ascii';

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/lc.t������������������������������������������������������������������0000664�0001750�0001750�00000002261�12224265625�015747� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 13;

# L<S32::Str/Str/lc>

is(lc("hello world"), "hello world", "lowercasing string which is already lowercase");
is(lc("Hello World"), "hello world", "simple lc test");
is(lc(""), "", "empty string");
is(lc("ÅÄÖ"), "åäö", "some finnish non-ascii chars");
is(lc("ÄÖÜ"), "äöü", "lc of German Umlauts");
is(lc("ÓÒÚÙ"), "óòúù", "accented chars");
is(lc('A'..'C'), "a b c", "lowercasing char-range");

{
    $_ = "Hello World";
    my $x = .lc;
    is($x, "hello world", 'lc uses $_ as default');
}

{ # test invocant syntax for lc
    my $x = "Hello World";
    is($x.lc, "hello world", '$x.lc works');
    is($x, 'Hello World', 'Invocant unchanged');
    is("Hello World".lc, "hello world", '"Hello World".lc works');
}

is("ÁÉÍÖÜÓŰŐÚ".lc, "áéíöüóűőú", ".lc on Hungarian vowels");

# https://en.wikipedia.org/wiki/Title_case#Special_cases
# "The Greek letter Σ has two different lowercase forms: "ς" in word-final
# position and "σ" elsewhere."

#?niecza todo 'advanced Unicode wizardry'
#?pugs   todo 'advanced Unicode wizardry'
is 'ΣΣΣ'.lc, 'σσς', 'lower-casing of greek Sigma respects word-final special case';

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/length.t��������������������������������������������������������������0000664�0001750�0001750�00000005361�12224265625�016636� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::Str/Str/=item length>

=begin pod

Various length tests (though "length" should not be used)

Don't mismatch "length" with the "width" property for Unicode characters.

L<"http://www.unicode.org/unicode/reports/tr11/">

=end pod

plan 46;

eval_dies_ok('"moose".length', 'Str.length properly not implemented');

# string literals, for sanity

# L<S32::Str/Str/=item chars>

# Precedence tests
#?niecza 2 skip '"abcdef" > 4 makes niecza unhappy'
ok (chars "abcdef" > 4),     "chars() has the right precedence (1)";
is (chars("abcdef" > 4)), 0, "chars() has the right precedence (2)";

# and the real tests.

# Please add test strings in your favorite script, especially if
# it is boustrophedonic or otherwise interesting.
my @stringy = <@stringy>;
my @data = (
    # string            octets codepoints grapheme chars
    "",                      0,        0,         0,  0,
    "moose",                 5,        5,         5,  5,
    "møøse",                 7,        5,         5,  5,
    "C:\\Program Files",    16,       16,        16, 16,
    ~@stringy,               8,        8,         8,  8,
    "\x020ac \\x020ac",     11,        9,         9,  9,
    "בדיקה",                10,        5,         5,  5,
    "בדיקה 123",            14,        9,         9,  9,
    "rántottcsirke",        14,        13,       13, 13,
    "aáeéiíoóöőuúüű",       23,        14,       14, 14,
    "AÁEÉIÍOÓÖŐUÚÜŰ",       23,        14,       14, 14,
    "»«",                    4,         2,        2,  2,
    ">><<",                  4,         4,        4,  4,

);
#:map { my %hash; %hash<string bytes codes graphs> = $_; \%hash };

# L<S32::Str/Str/=item chars>
# L<S32::Str/Str/=item codes>
# L<S32::Str/Str/=item graphs>

for @data -> $string, $bytes, $codes, $graphs, $chars {
    is($string.chars, $chars, "'{$string}'.chars");
    is($string.codes, $codes, "'{$string}'.codes");
    #?niecza skip ".graphs NYI"
    is($string.graphs, $graphs, "'{$string}'.graphs");
}

# test something with a codepoint above 0xFFFF to catch errors that an
# UTF-16 based implementation might make

is "\x[E0100]".codes,  1, '.codes on a >0xFFFF char'; # \c[VARIATION SELECTOR-17]
#?niecza skip ".graphs NYI"
is "\x[E0100]".graphs, 1, '.graphs on a >0xFFFF char'; # \c[VARIATION SELECTOR-17]

# test graphemes without a precomposed character in Unicode 5
#?rakudo 1 skip '.codes not implemented'
#?pugs todo
is "\c[LATIN CAPITAL LETTER A WITH DOT ABOVE, COMBINING DOT BELOW]".codes, 2, '.codes on grapheme without precomposite';
#?rakudo 1 skip '.graphs not implemented'
#?niecza skip ".graphs NYI"
#?pugs todo
is "\c[LATIN CAPITAL LETTER A WITH DOT ABOVE, COMBINING DOT BELOW]".graphs, 1, '.graphs on grapheme without precomposite';


# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/lines.t���������������������������������������������������������������0000664�0001750�0001750�00000000466�12224265625�016470� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 4;

is "a\nb\n\nc".lines.join('|'),   'a|b||c', '.lines without trailing \n';
is "a\nb\n\nc\n".lines.join('|'), 'a|b||c', '.lines with trailing \n';
is "a\nb\n\nc\n".lines(2).join('|'), 'a|b', '.lines with limit';
is lines("a\nb\nc\n").join('|'), 'a|b|c',   '&lines';

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/numeric.t�������������������������������������������������������������0000664�0001750�0001750�00000007601�12224265625�017016� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

#?DOES 2
sub check($str, $expected_type, $expected_number, $desc?) {
    my $result = +$str;
    my $description = $desc // $str;
    is $result.WHAT.gist, $expected_type.gist, "$description (type)";
    ok $result == $expected_number, "$description (value)"
        or diag(
              "got:      $result\n"
            ~ "expected: $expected_number"
        );
}

#?DOES 1
sub f($str) {
    my $num = 0; # defined
    so try { $num = +$str }
    #?niecza todo 'Failure'
    ok !$num.defined, "+$str fails";
}

check '',           Int,      0;
check '123',        Int,    123;
check ' 123',       Int,    123;
check '0000123',    Int,    123;
check '1_2_3',      Int,    123;
check '+123',       Int,    123;
check '-123',       Int,   -123;
check '3433683820292512484657849089281', Int, 3**64;
f     'a+123';
f     '123foo';
f     '123+';
f     '1__2';
f     '123_';
f     '123 and stuff';


check '0b111',      Int,      7;
check '0b1_1_1',    Int,      7;
check '+0b111',     Int,      7;
check '-0b111',     Int,     -7;
# the spec is silent about this one, but rakudo and niecza agree
check '0b_1',       Int,      1;
f     '0b112';
f     '0b';
check '0o77',       Int,     63;
check '+0o77',      Int,     63;
check '-0o77',      Int,    -63;
f     '0o8';
check '0d123',      Int,    123;
check '-0d123',     Int,    -123;
f     '0da';
check '0x123',      Int,    291;
check '-0x123',     Int,   -291;
check '0xa0',       Int,    160;
check '-0xA0',      Int,   -160;
f     '0xag';
f     '0xaf-';

{
    check ':10<42>',    Int,     42;
    check '-:10<42>',   Int,    -42;
    check '-:1_0<4_2>', Int,    -42;
    check ':36<aZ>',    Int,    395;
    check ':2<11>',     Int,      3;
    #?niecza 6 todo 'Failure'
    f     ':2<2>';
    #?rakudo skip 'NYI'
    f     ':37<8>';
    f     ':10<8_>';
    f     ':10<_8>';
    f     ':18<>';
    f     ':10<8';
}

f     '123.';
check '123.0',      Rat,    123;
check '-123.0',     Rat,    -123;
check '+123.0',     Rat,    123;
check '+1_2_3.0_0', Rat,    123;
check '3/2',        Rat,    1.5;
check '+3/2',       Rat,    1.5;
check '-3/2',       Rat,    -1.5;
#?rakudo 5 todo 'Failure'
f     '-3/-2';
f     '3/-2';
f     '+3/-2';
f     '3.0/2';
f     '3/2.0';

{
    check '-:10<4_2.3_5>', Rat, -42.35;
    check '-:8<4_2.3_5>',  Rat, -34.453125;

# from S02-literals/radix.t
    f ":2.4<01>";
    f ":10<12f>";
    f ":1b<10>";
    f ":10<>";
    f ":_2<01>";
    f ":2<_01>";
    f ":2<01_>";
    f ":_2_<_0_1_>_";
    f ":2<1.3>";
    f "0b1.1e10";
    f ":2<10dlk";
    f ":2lks01>";
}

check '123e0',      Num,    123;
check '-123e0',     Num,   -123;
check '+123e0',     Num,    123;
check '+123.0e0',   Num,    123;
check '+123.0_1e2', Num,  12301;
check '+123.0_1e0_2', Num,  12301;
check '123e-0',     Num,    123;
check '-123e+0',    Num,   -123;
check '123E0',      Num,    123;
check '1_2_3E0_0',  Num,    123;
check '-123E0',     Num,   -123;
check '+123E0',     Num,    123;
check '123E-0',     Num,    123;
check '-123E+0',    Num,   -123;
check '-123E+0_1',  Num,  -1230;
check '1230E-1',    Num,    123;
check '-12E+1',     Num,   -120;
f      '120e';
f      '120e2_';

# TODO: Nums with radix

is +"Inf",  'Inf',  'Inf';
is +"+Inf", 'Inf',  '+Inf';
is +"-Inf", '-Inf', '-Inf';
is +"NaN",  'NaN',  'NaN';

{
    check  '1+2i',                  Complex,        1+2i;
    check  '-1-2i',                 Complex,       -1-2i;
    check  '-1-2\i',                Complex,       -1-2i;
    check  '-1.0-2.0\i',            Complex,       -1-2i;
    check  '-1.0e0-2.0e0\i',        Complex,       -1-2i;
    check  '-1.0e0_0-2.0e0_0\i',    Complex,       -1-2i;
    check  '3+Inf\i',               Complex,     3+Inf\i;
    check  'Inf+2e2i',              Complex,    Inf+200i;
    f      '3+3i+4i';
    f      '3+3+4i';
}

#?rakudo todo "complex Str.Numeric"
f      '3+Infi';

# TODO: Complex with radix

# RT #100778
{
    is +Str.new, 0, 'RT #100778'
}

done;

# vim: ft=perl6 
�������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/ords.t����������������������������������������������������������������0000664�0001750�0001750�00000000644�12224265625�016323� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 6;

# L<S32::Str/Str/ords>

is ords('').elems, 0, 'ords(empty string)';
is ''.ords.elems,  0, '<empty string>.ords';
is ords('Cool()').join(', '), '67, 111, 111, 108, 40, 41',
   'ords(normal string)';
is 'Cool()'.ords.join(', '), '67, 111, 111, 108, 40, 41',
   '<normal string>.ords';
is ords(42).join(', '), '52, 50', 'ords() on integers';
is 42.ords.join(', '), '52, 50', '.ords on integers';
��������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/pack.t����������������������������������������������������������������0000664�0001750�0001750�00000002163�12224265625�016270� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item pack">

plan 6;

{
    my $buf = pack('H*', "414243");
    is_deeply $buf.contents, [:16<41>, :16<42>, :16<43>], 'H* works';
}

{
    my $buf = pack("A11 A28 A8 A*",
                   "03/23/2001", "Totals", "1235.00", "   1172.98");
    is_deeply $buf.contents,
              "03/23/2001 Totals                      1235.00    1172.98"\
                .encode.contents,
              "A works";
}

{
    my $buf = pack("C S L n N v V",
                   0x130, 0x10030, 0x100000030,
                   0x1234, 0x12345678,
                   0x1234, 0x12345678);
    is_deeply $buf.contents,
              [0x30, 0x30, 0x00, 0x30, 0x00, 0x00, 0x00,
               0x12, 0x34, 0x12, 0x34, 0x56, 0x78,
               0x34, 0x12, 0x78, 0x56, 0x34, 0x12],
              "C S L n N v V work";
}

{
  my $buf = pack('x');
  is_deeply $buf.contents, [0x00], 'x by itself works';
}

{
  my $buf = pack('x4');
  is_deeply $buf.contents, [0x00, 0x00, 0x00, 0x00], 'x with amount works';
}

{
  my $buf = pack('x*');
  is_deeply $buf.contents, [], 'x* works (as in it does nothing.)';
}

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/pos.t�����������������������������������������������������������������0000664�0001750�0001750�00000000332�12224265625�016147� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S29/Obsolete Functions/=item pos>

plan 2;

my $str = 'moose';
$str ~~ /oo/;
eval_dies_ok('$str.pos', 'Str.pos superseeded by $/.to');

#?pugs todo
is($/.to, 3, '$/.to works');

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/quotemeta.t�����������������������������������������������������������0000664�0001750�0001750�00000011273�12224265625�017360� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
# vim: filetype=perl6 :

# NOTES ON PORTING quotemeta.t FROM Perl 5.9.3
#
# 1. The original test suite did include may tests to exercise the
#    behaviour in double-quotes interpolation with \Q and \E, and their
#    interaction with other modification like \L and \U. These
#    interpolating sequences no longer exist.
#
# 2. The original test suite did not exercise the quotemeta function
#    for the whole 0-255 Unicode character set. Extending that test
#    suite to include all of these characters basically yields the
#    modified tests included here FOR THE ASCII VARIANT ONLY.
#    Tests for EBCDIC have not been (yet) extended, this is most
#    due to the fact that the Config.pm mechanism is not available
#    to date.
#
# 3. The original test suite used tr/// to count backslashes, here
#    we use a combination of split and grep to count non-backslashes,
#    which should be more intuitive.

use Test;


plan 11;

# For the moment I don't know how to handle the lack of Config.pm...
# Sorry for ebcdic users!
my %Config; # Empty means there's no 'ebcdic' key defined...

#?pugs todo 'Test Config.pm availability'
is('Config.pm', 'available', 'Config.pm availability');

# L<S32::Str/Str/quotemeta>

is(quotemeta("HeLLo World-72_1"), "HeLLo\\ World\\-72_1", "simple quotemeta test");
is(quotemeta(""), "", "empty string");

$_ = "HeLLo World-72_1";
my $x = .quotemeta;
is($x, "HeLLo\\ World\\-72_1", 'quotemeta uses $_ as default');

{ # test invocant syntax for quotemeta
    my $x = "HeLLo World-72_1";
    is($x.quotemeta, "HeLLo\\ World\\-72_1", '$x.quotemeta works');
    is("HeLLo World-72_1".quotemeta, "HeLLo\\ World\\-72_1", '"HeLLo World-72_1".quotemeta works');
}


if (%Config<ebcdic> eq 'define') {
    $_ = (129 .. 233).map({ chr($_); }).join;
    is($_.chars, 96, "quotemeta starting string");

    # 105 characters - 52 letters = 53 backslashes
    # 105 characters + 53 backslashes = 158 characters
    $_ = quotemeta $_;
    is($_.chars, 158, "quotemeta string");
    # 53 backslashed characters + 1 "original" backslash
    is($_.split('').grep({ $_ eq "\x5c" }).elems, 54, "count backslashes");
}
else {
    $_ = (0 .. 255).map({ chr($_); }).join;
    is($_.chars, 256, "quotemeta starting string");

    # Original test in Perl 5.9.3:
    # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
    # 96 characters + 33 backslashes = 129 characters
    #
    # Then added remaining 32 + 128, all escaped:
    # 129 + (32 + 128) * 2 = 449
    #
    # Total backslashed chars are 33 + 32 + 128 = 193
    # Total backslashes are 1 + 193 = 194
    $_ = quotemeta $_;
    is($_.chars, 449, "quotemeta string");
    # 33 backslashed characters + 1 "original" backslash
    is($_.split('').grep({ $_ eq "\x5c" }).elems, 194, "count backslashes");
}

# Current quotemeta implementation mimics that for Perl 5, avoiding
# to escape Unicode characters beyond 256th
is(quotemeta("\x[263a]"), "\x[263a]", "quotemeta Unicode");
is(quotemeta("\x[263a]").chars, 1, "quotemeta Unicode length");

=begin from_perl5


plan tests => 22;

if ($Config{ebcdic} eq 'define') {
    $_ = join "", map chr($_), 129..233;

    # 105 characters - 52 letters = 53 backslashes
    # 105 characters + 53 backslashes = 158 characters
    $_ = quotemeta $_;
    is(length($_), 158, "quotemeta string");
    # 104 non-backslash characters
    is(tr/\\//cd, 104, "tr count non-backslashed");
} else { # some ASCII descendant, then.
    $_ = join "", map chr($_), 32..127;

    # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
    # 96 characters + 33 backslashes = 129 characters
    $_ = quotemeta $_;
    is(length($_), 129, "quotemeta string");
    # 95 non-backslash characters
    is(tr/\\//cd, 95, "tr count non-backslashed");
}

is(length(quotemeta ""), 0, "quotemeta empty string");

is("aA\UbB\LcC\EdD", "aABBccdD", 'aA\UbB\LcC\EdD');
is("aA\LbB\UcC\EdD", "aAbbCCdD", 'aA\LbB\UcC\EdD');
is("\L\upERL", "Perl", '\L\upERL');
is("\u\LpERL", "Perl", '\u\LpERL');
is("\U\lPerl", "pERL", '\U\lPerl');
is("\l\UPerl", "pERL", '\l\UPerl');
is("\u\LpE\Q#X#\ER\EL", "Pe\\#x\\#rL", '\u\LpE\Q#X#\ER\EL');
is("\l\UPe\Q!x!\Er\El", "pE\\!X\\!Rl", '\l\UPe\Q!x!\Er\El');
is("\Q\u\LpE.X.R\EL\E.", "Pe\\.x\\.rL.", '\Q\u\LpE.X.R\EL\E.');
is("\Q\l\UPe*x*r\El\E*", "pE\\*X\\*Rl*", '\Q\l\UPe*x*r\El\E*');
is("\U\lPerl\E\E\E\E", "pERL", '\U\lPerl\E\E\E\E');
is("\l\UPerl\E\E\E\E", "pERL", '\l\UPerl\E\E\E\E');

is(quotemeta("\x{263a}"), "\x{263a}", "quotemeta Unicode");
is(length(quotemeta("\x{263a}")), 1, "quotemeta Unicode length");

$a = "foo|bar";
is("a\Q\Ec$a", "acfoo|bar", '\Q\E');
is("a\L\Ec$a", "acfoo|bar", '\L\E');
is("a\l\Ec$a", "acfoo|bar", '\l\E');
is("a\U\Ec$a", "acfoo|bar", '\U\E');
is("a\u\Ec$a", "acfoo|bar", '\u\E');

=end from_perl5
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/rindex.t��������������������������������������������������������������0000664�0001750�0001750�00000004542�12224265625�016646� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item rindex">

plan 33;

# Simple - with just a single char

is(rindex("Hello World", "H"), 0, "One char, at beginning");
is(rindex("Hello World", "l"), 9, "One char, in the middle");
is(rindex("Hello World", "d"), 10, "One char, in the end");
#?pugs todo
ok(!defined(rindex("Hello World", "x")), "One char, no match");

is(rindex("Hello World", "l", 10), 9, "One char, first match, pos @ end");
is(rindex("Hello World", "l", 9), 9, "- 1. match again, pos @ match");
is(rindex("Hello World", "l", 8), 3, "- 2. match");
is(rindex("Hello World", "l", 2), 2, "- 3. match");
#?pugs todo
ok(!defined(rindex("Hello World", "l", 1)), "- no more matches");

# Simple - with a string

is(rindex("Hello World", "Hello"), 0, "Substr, at beginning");
is(rindex("Hello World", "o W"), 4, "Substr, in the middle");
is(rindex("Hello World", "World"), 6, "Substr, at the end");
#?pugs todo
ok(!defined(rindex("Hello World", "low")), "Substr, no match");
is(rindex("Hello World", "Hello World"), 0, "Substr eq Str");

# Empty strings

is(rindex("Hello World", ""), 11, "Substr is empty");
is(rindex("", ""), 0, "Both strings are empty");
#?pugs todo
ok(!defined(rindex("", "Hello")), "Only main-string is empty");
is(rindex("Hello", "", 3), 3, "Substr is empty, pos within str");
is(rindex("Hello", "", 5), 5, "Substr is empty, pos at end of str");
is(rindex("Hello", "", 999), 5, "Substr is empty, pos > length of str");

# More difficult strings

is(rindex("abcdabcab", "abcd"), 0, "Start-of-substr matches several times");
is(rindex("uuúuúuùù", "úuù"), 4, "Accented chars");
is(rindex("Ümlaut", "Ü"), 0, "Umlaut");
is(rindex("what are these « » unicode characters for ?", "uni"), 19, "over unicode characters");

# .rindex use
is("Hello World".rindex("l"), 9, ".rindex on string");
is("Hello World".rindex(''), 11, ".rindex('') on string gives string length in bytes");

# on scalar variable
my $s = "Hello World";
is(rindex($s, "o"), 7, "rindex on scalar variable");
is($s.rindex("o"), 7, ".rindex on scalar variable");

is(rindex(uc($s), "O"), 7, "rindex on uc");
is($s.uc.rindex("O"), 7, ".uc.rindex ");

# ideas for deeper chained . calls ?
is($s.lc.tc.rindex("w"), 6, ".lc.tc.rindex");

# rindex on non-strings
ok 3459.rindex(5) == 2, 'rindex on integers';

# RT #112818
is "\x261b perl \x261a".rindex('e'), 3, 'rindex with non-latin-1 strings';

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/sameaccent.t����������������������������������������������������������0000664�0001750�0001750�00000001337�12224265625�017457� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item sameaccent">

plan 7;

is(sameaccent('ABb', 'ƗƗƗ'), 'ȺɃƀ', 'sameaccent as a function works');

# should this be an exception or a Failure instead?
is(sameaccent('AF', 'ƗƗ'), 'ȺF', 'sameaccent without matching character silently fails');

is('ABb'.sameaccent('ƗƗƗ'), 'ȺɃƀ', 'sameaccent as a method works');

is('text'.sameaccent('asdf'), 'text', 'sameaccent without a change (no accents)');
is('ȺɃƀ'.sameaccent('ƗƗƗ'), 'ȺɃƀ', 'sameaccent without a change (accents already present');

is('text'.sameaccent('this is longer'), 'text', 'sameaccent with longer base string');
is('ABCD'.sameaccent('ƗƗ'), 'ȺɃCD', 'sameaccent with longer source string');

# vim: ft=perl6
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/samecase.t������������������������������������������������������������0000664�0001750�0001750�00000001711�12224265625�017131� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item samecase">

=begin pod

Basic test for the samecase() builtin with a string (Str).

=end pod

plan 8;

# As a function
is( samecase('Perl6', 'abcdE'), 'perl6', 'as a function');

# As a method
is( ''.samecase(''), '', 'empty string' );
is( 'Hello World !'.samecase('AbCdEfGhIjKlMnOpQrStUvWxYz'), 'HeLlO WoRlD !', 'literal');


# On a variable
my Str $a = 'Just another Perl6 hacker';
is( $a.samecase('XXXXXXXXXXXXXXXXXXXXXXXXX'), 'JUST ANOTHER PERL6 HACKER', 'with a Str variable' );
is( $a.samecase('äääääääääääääääääääääääää'), 'just another perl6 hacker', 'with a Str variable and <unicode> arg');
is( $a, 'Just another Perl6 hacker', 'samecase should not be in-place' );
is( $a .= samecase('aaaaaaaaaaaaaaaaaaaaaaaa'), 'just another perl6 hacker', 'after a .= samecase(...)' );

# samecase with unicode
is( '䀻«'.samecase('xXxX'), '䀻«', 'some unicode characters' );


# vim: ft=perl6
�������������������������������������������������������rakudo-2013.12/t/spec/S32-str/split-simple.t��������������������������������������������������������0000664�0001750�0001750�00000007454�12224265625�020004� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item split">
plan 49;

=begin description

The tests in split.t are rather inaccessible for new implementations, so
here is a start from scratch that should be easier to run.

=end description

#?DOES 2
sub split_test(@splitted, @expected, Str $desc) {
    ok @splitted.elems ==  @expected.elems,
       "split created the correct number of elements for: $desc";
    is @splitted.join('|-|'), @expected.join('|-|'),
       "values matched for: $desc"
}

split_test 'a1b24f'.split(/\d+/),  <a b f>, 'Str.split(/regex/)';
split_test split(/\d+/, 'a1b24f'), <a b f>, 'split(/regex/, Str)';
split_test 'a1b'.split(1),         <a b>,   'Str.split(Any) (with Str semantics';

split_test 'a1b24f'.split(/\d+/, *),  <a b f>, 'Str.split(/regex/) (with * limit)';
split_test split(/\d+/, 'a1b24f', *), <a b f>, 'split(/regex/, Str) (with * limit)';
split_test 'a1b'.split(1, *),         <a b>,   'Str.split(Any) (with Str semantics (with * limit)';

{
    split_test 123.split(2),           <1 3>,   'Int.split(Int)';
    split_test split(2, 123),          <1 3>,   'split(Int, Int)';
}

split_test '1234'.split(/X/),          @(<1234>),  'Non-matching regex returns whole string';
split_test '1234'.split('X'),          @(<1234>),  'Non-matching string returns whole string';
split_test 'abcb'.split(/b/),   ('a', 'c', ''), 'trailing matches leave an empty string';

# Limit tests
#?DOES 4
#?niecza skip '0 or negative does not return empty list'
{
split_test 'theXbigXbang'.split(/X/, -1), (), 'Negative limit returns empty List';
split_test @('theXbigXbang'.split(/X/, 0)),  (), 'Zero limit returns empty List';
}
split_test 'ab1cd12ef'.split(/\d+/, 1), @(<ab1cd12ef>), 'Limit of 1 returns a 1 element List (with identical string)';
split_test '102030405'.split(0, 3),  <1 2 30405>, 'Split on an Integer with limit parameter works';
split_test(
    '<tag>soup</tag>'.split(/\<\/?.*?\>/, 3),
    ('','soup',''),
    'Limit of 3 returns 3 element List including empty Strings'
);
split_test(
    'ab1cd12ef'.split(/\d+/, 10),
    <ab cd ef>,
    'Limit larger than number of split values doesn\'t return extranuous elements'
);

#?DOES 4
#?niecza skip 'niecza has empty value at beginning of list'
{
split_test
    'abcdefg'.split('', 3),
    <a b cdefg>,
    'split into characters respects limit (1)';

# catch possible off-by-one errors
split_test
    'abc'.split('', 3),
    <a b c>,
    'split into characters respects limit (2)';
}

# zero-width assertions shouldn't loop
# with additional spaces
# a b 3 4 d 5 z    split on <before \d>
#    ^ ^   ^
#  => result: 'ab', '3', '4d', '5z'
#  (confirmed by perl 5)

#?DOES 2
split_test 'ab34d5z'.split(/<.before \d>/), <ab 3 4d 5z>, 'split with zero-width assertions';

# As per Larry, ''.split('') is the empty list
# http://www.nntp.perl.org/group/perl.perl6.language/2008/09/msg29730.html

#?niecza todo 'returning 2 element list'
ok (''.split('')).elems == 0, q{''.split('') returns empty list};
#?niecza todo 'returning 2 element list'
ok (split('', '')).elems == 0, q{''.split('') returns empty list};

# split with :all should return capture
{
    my @split = 'abc def ghi'.split(/(\s+)/, :all);
    ok @split.elems == 5, q{split returns captured delimiter} ;
    ok @split[1] eq ' ', q{split captured single space};
    ok @split[3] eq ' ', q{split captured multiple spaces};
}

{
    my @split = split(/\d+/, 'a4b5', :all);
    is @split.elems, 5, 'split() with :all and trailing delimiter (count)';
    is @split.join('|'), 'a|4|b|5|',
       'split(:all) and trailing delimiter (values)';
}

# RT 112868
{
    my $rt112868 = 'splitting on empty';
    ok $rt112868.split('').elems > 0, q<.split('') does something>;
    #?rakudo todo 'RT 112868'
    is $rt112868.split(''), $rt112868.split(/''/),
       q<.split('') does the same thing as .split(/''/) (RT 112868)>;
}

done;

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/split.t���������������������������������������������������������������0000664�0001750�0001750�00000014352�12237474612�016512� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32-setting-library/Str"=item split">

plan 54;

# split on empty string
#?niecza todo "split on empty string has leading empty elements"
{
    is split("", "forty-two").join(','), 'f,o,r,t,y,-,t,w,o',
      q{split "", Str};
    is "forty-two".split("").join(','), 'f,o,r,t,y,-,t,w,o',
      q{Str.split: ""};

    is split("", "forty-two", 3).join(','), 'f,o,rty-two',
      q{split "", Str};
    is "forty-two".split("",3).join(','), 'f,o,rty-two',
      q{Str.split: ""};
}

# split on a space
{
    is split(' ', 'split this string').join(','), 'split,this,string',
      q{split ' ', Str};
    is 'split this string'.split(' ').join(','), 'split,this,string',
      q{Str.split: ' '};

    is split(' ', 'split this string', 2).join(','), 'split,this string',
      q{split ' ', Str, 2};
    is 'split this string'.split(' ',2).join(','), 'split,this string',
      q{Str.split: ' ', 2};
}

# split on a single character delimiter
{
    is split('$', 'try$this$string').join(','), 'try,this,string',
      q{split '$', Str};
    is 'try$this$string'.split('$').join(','), 'try,this,string',
      q{Str.split: '$'};

    is split('$', 'try$this$string',2).join(','), 'try,this$string',
      q{split '$', Str, 2};
    is 'try$this$string'.split('$',2).join(','), 'try,this$string',
      q{Str.split: '$', 2};
}

# split on a multi-character delimiter
{
    is split(', ', "comma, separated, values").join('|'),
      'comma|separated|values', q{split ', ', Str};
    is "comma, separated, values".split(", ").join('|'),
      'comma|separated|values', q{Str.split: ', '};

    is split(', ', "comma, separated, values",2).join('|'),
      'comma|separated, values', q{split ', ', Str,2};
    is "comma, separated, values".split(", ",2).join('|'),
      'comma|separated, values', q{Str.split: ', ',2};
}

# split on a variable delimiter
{
    my $del = '::';
    is split($del, "Perl6::Camelia::Test").join(','), 'Perl6,Camelia,Test',
       q{split $del, Str};
    is 'Perl6::Camelia::Test'.split($del).join(','), 'Perl6,Camelia,Test',
       q{Str.split: $del};

    is split($del, "Perl6::Camelia::Test",2).join(','), 'Perl6,Camelia::Test',
       q{split $del, Str,2};
    is 'Perl6::Camelia::Test'.split($del,2).join(','), 'Perl6,Camelia::Test',
       q{Str.split: $del,2};
}

# split with a single char reg-exp
#?niecza skip 'rx:Perl5'
{
    is split(rx:Perl5 {,},"split,me,please").join('|'), 'split|me|please',
      'split rx:P5 {,},Str';
    is 'split,me,please'.split(rx:Perl5 {,}).join('|'), 'split|me|please',
      'Str.split: rx:P5 {,}';

    is split(rx:Perl5 {,},"split,me,please",2).join('|'), 'split|me,please',
      'split rx:P5 {,},Str,2';
    is 'split,me,please'.split(rx:Perl5 {,},2).join('|'), 'split|me,please',
      'Str.split: rx:P5 {,},2';
}

# split on regex with any whitespace
#?niecza skip 'rx:Perl5'
{
    is split(rx:Perl5 {\s+}, "Hello World    Goodbye   Mars").join(','),
      'Hello,World,Goodbye,Mars', q/split rx:Perl5 {\s+}, Str/;
    is 'Hello World    Goodbye  Mars'.split(rx:Perl5 {\s+}).join(','),
      'Hello,World,Goodbye,Mars', q/Str.split: rx:Perl5 {\s+}/;

    is split(rx:Perl5 {\s+}, "Hello World    Goodbye   Mars", 3).join(','),
      'Hello,World,Goodbye   Mars', q/split rx:Perl5 {\s+}, Str, 3/;
    is 'Hello World    Goodbye   Mars'.split(rx:Perl5 {\s+}, 3).join(','),
      'Hello,World,Goodbye   Mars', q/Str.split: rx:Perl5 {\s+}, 3/;
}

#?niecza skip 'rx:Perl5'
{
    is split(rx:Perl5 {(\s+)}, "Hello test", :all).join(','), 'Hello, ,test',
      q/split rx:Perl5 {(\s+)}, Str/;
    is "Hello test".split(rx:Perl5 {(\s+)}, :all).join(','), 'Hello, ,test',
      q/Str.split rx:Perl5 {(\s+)}/;
}

#?niecza skip 'rx:Perl5'
{
    is split(rx:Perl5 { },"this will be split").join(','), 'this,will,be,split',
      q/split(rx:Perl5 { }, Str)/;
    is "this will be split".split(rx:Perl5 { }).join(','), 'this,will,be,split',
      q/Str.split(rx:Perl5 { })/;
    is split(rx:Perl5 { },"this will be split",3).join(','),
      'this,will,be split', q/split rx:Perl5 { }, Str,3)/;
    is "this will be split".split(rx:Perl5 { },3).join(','),
      'this,will,be split', q/Str.split: rx:Perl5 { },3/;
}

#L<S32::Str/Str/"no longer has a default delimiter">
dies_ok {"  abc  def  ".split()}, q/Str.split() disallowed/;

# This one returns an empty list
#?niecza todo '2 element list'
is  "".split('').elems, 0, q/"".split()/;

# ... yet this one does not (different to p5).
# blessed by $Larry at Message-ID: <20060118191046.GB32562@wall.org>
is  "".split(':').elems, 1, q/"".split(':')/;

# using /.../
is "a.b".split(/\./).join(','), <a b>.join(','),
   q{"a.b".split(/\./)};

#?rakudo skip 'No such method null for invocant of type Cursor'
#?niecza skip 'Unable to resolve method null in class Cursor'
{
    is "abcd".split(/<null>/).join(','), <a b c d>.join(','),
       q{"abcd".split(/<null>/)};()
}

#?niecza skip 'Unable to resolve method null in class Cursor'
{
  ' ' ~~ /(\s)/;

  if $0 eq ' ' {
    is "foo bar baz".split(/<prior>/).join(','), <foo bar baz>.join(','),
       q{"foo bar baz".split(/<prior>/)};
  } else {
    skip q{' ' ~~ /\s/ did not result in ' '};
  }
}

{
    my @a = "hello world".split(/<[aeiou]>/, :all);
    is +@a, 7, "split:all resulted in seven pieces";
    isa_ok @a[1], Match, "second is a Match object";
    isa_ok @a[3], Match, "fourth is a Match object";
    isa_ok @a[5], Match, "sixth is a Match object";
    is ~@a, ~("h", "e", "ll", "o", " w", "o", "rld"), "The pieces are correct";
}

{
    my @a = "hello world".split(/(<[aeiou]>)(.)/, :all);
    is +@a, 7, "split:all resulted in seven pieces";
    is ~@a, ~("h", "el", "l", "o ", "w", "or", "ld"), "The pieces are correct";
    is @a[1][0], "e", "First capture worked";
    is @a[1][1], "l", "Second capture worked";
    is @a[3][0], "o", "Third capture worked";
    is @a[3][1], " ", "Fourth capture worked";
}

# RT #63066
{
    is 'hello-world'.split(/<.ws>/).join('|'), '|hello|-|world|',
      'zero-width delimiter (<.ws>)';
    #?niecza skip 'Unable to resolve method wb in class Cursor'
    is 'hello-world'.split(/<.wb>/).join('|'), '|hello|-|world|',
      'zero-width delimiter (<.wb>)';
    #?niecza skip 'Unable to resolve method wb in class Cursor'
    is '-a-b-c-'.split(/<.wb>/).join('|'), '-|a|-|b|-|c|-',
      'zero-width delimiter (<.wb>) (2)';
}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/sprintf.t�������������������������������������������������������������0000664�0001750�0001750�00000034335�12253134031�017031� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 149;

# L<S32::Str/Str/"identical to" "C library sprintf">

is sprintf("Hi"),                 "Hi",     "sprintf() works with zero args";
is sprintf("%%"),                 "%",      "sprintf() escapes % correctly";
is sprintf("%03d",      3),       "003",    "sprintf() works with one arg";
is sprintf("%03d %02d", 3, 1),    "003 01", "sprintf() works with two args";
is sprintf("%d %d %d",  3,1,4),   "3 1 4",  "sprintf() works with three args";
is sprintf("%d%d%d%d",  3,1,4,1), "3141",   "sprintf() works with four args";

ok(eval('sprintf("%b",1)'),                  'eval of sprintf() with %b');

is sprintf("%04b",3),             '0011',   '0-padded sprintf() with %b';
is sprintf("%4b",3),              '  11',   '" "-padded sprintf() with %b';
is sprintf("%b",30),              '11110',  'longer string, no padding';
is sprintf("%2b",30),             '11110',  'padding specified, not needed';
is sprintf("%03b",7),             '111',    '0 padding, longer string';
is sprintf("%b %b",3,3),          '11 11',  'two args %b';

is sprintf('%c', 97),             'a',      '%c test';

is sprintf('%s', 'string'),        'string', '%s test';
is sprintf('%10s', 'string'),  '    string', '%s right-justified';
is sprintf('%-10s', 'string'), 'string    ', '%s left-justified';

is sprintf('%d', 12),             '12',     'simple %d';
is sprintf('%d', -22),            '-22',    'negative %d';
is sprintf('%04d', 32),           '0032',   '0-padded %d';
is sprintf('%04d', -42),          '-042',   '0-padded negative %d';
is sprintf('%i', -22),            '-22',    'negative %i';
is sprintf('%04i', -42),          '-042',   '0-padded negative %i';
is sprintf('%4d', 32),            '  32',   'space-padded %d';
is sprintf('%4d', -42),           ' -42',   'space-padded negative %d';
is sprintf('%4i', -42),           ' -42',   'space-padded negative %i';
is sprintf('%-4i', -42),          '-42 ',   'left-justified negative %i';

is sprintf('%u', 12),             '12',     'simple %u';
is sprintf('%u', 22.01),          '22',     'decimal %u';
is sprintf('%04u', 32),           '0032',   '0-padded %u';
is sprintf('%04u', 42.6),         '0042',   '0-padded decimal %u';

is sprintf('%o', 12),             '14',     'simple %o';
is sprintf('%o', 22.01),          '26',     'decimal %o';
is sprintf('%03o', 32),           '040',    '0-padded %o';
is sprintf('%03o', 42.6),         '052',    '0-padded decimal %o';

is sprintf('%x', 0),              '0',      'simple %x';
is sprintf('%x', 12),             'c',      'simple %x';
is sprintf('%x', 22.01),          '16',     'decimal %x';
is sprintf('%03x', 32),           '020',    '0-padded %x';
is sprintf('%03x', 42.6),         '02a',    '0-padded decimal %x';
# tests for %X
is sprintf('%X', 12),             'C',      'simple %X';
is sprintf('%03X', 42.6),         '02A',    '0-padded decimal %X';

is sprintf('%d', 453973694165307953197296969697410619233826),
    "453973694165307953197296969697410619233826",
    '%d works for big ints';
is sprintf('%d', -453973694165307953197296969697410619233826),
    "-453973694165307953197296969697410619233826",
    '%d works for negative big ints';
is sprintf('%b', 453973694165307953197296969697410619233826),
    "1010011011000011011110110010010011111011100010110000111011001101110011001010011001110100101011101101011001111110001010100110101011000100010",
    '%b works for big ints';
is sprintf('%b', -453973694165307953197296969697410619233826),
    "-1010011011000011011110110010010011111011100010110000111011001101110011001010011001110100101011101101011001111110001010100110101011000100010",
    '%b works for negative big ints';
is sprintf('%o', 453973694165307953197296969697410619233826),
    "12330336622373426073156312316453553176124653042",
    '%o works for big ints';
is sprintf('%o', -453973694165307953197296969697410619233826),
    "-12330336622373426073156312316453553176124653042",
    '%o works for negative big ints';
is sprintf('%x', 453973694165307953197296969697410619233826),
    "5361bd927dc58766e6533a576b3f1535622",
    '%x works for big ints';
is sprintf('%x', -453973694165307953197296969697410619233826),
    "-5361bd927dc58766e6533a576b3f1535622",
    '%x works for negative big ints';
is sprintf('%X', 453973694165307953197296969697410619233826),
    "5361BD927DC58766E6533A576B3F1535622",
    '%X works for big ints';
is sprintf('%X', -453973694165307953197296969697410619233826),
    "-5361BD927DC58766E6533A576B3F1535622",
    '%X works for negative big ints';

is sprintf('%d', 453973694165307953197296969697410619233826 + .1),
    "453973694165307953197296969697410619233826",
    '%d works for big Rats';
is sprintf('%d', -453973694165307953197296969697410619233826 - .1),
    "-453973694165307953197296969697410619233826",
    '%d works for negative big Rats';
is sprintf('%d', (453973694165307953197296969697410619233826 + .1).FatRat),
    "453973694165307953197296969697410619233826",
    '%d works for big FatRats';
is sprintf('%d', (-453973694165307953197296969697410619233826 - .1).FatRat),
    "-453973694165307953197296969697410619233826",
    '%d works for negative big FatRats';
is sprintf('%b', 453973694165307953197296969697410619233826 + .1),
    "1010011011000011011110110010010011111011100010110000111011001101110011001010011001110100101011101101011001111110001010100110101011000100010",
    '%b works for big Rats';
is sprintf('%b', -453973694165307953197296969697410619233826 - .1),
    "-1010011011000011011110110010010011111011100010110000111011001101110011001010011001110100101011101101011001111110001010100110101011000100010",
    '%b works for negative big Rats';
is sprintf('%o', 453973694165307953197296969697410619233826 + .1),
    "12330336622373426073156312316453553176124653042",
    '%o works for big Rats';
is sprintf('%o', -453973694165307953197296969697410619233826 - .1),
    "-12330336622373426073156312316453553176124653042",
    '%o works for negative big Rats';
is sprintf('%x', 453973694165307953197296969697410619233826 + .1),
    "5361bd927dc58766e6533a576b3f1535622",
    '%x works for big Rats';
is sprintf('%x', -453973694165307953197296969697410619233826 - .1),
    "-5361bd927dc58766e6533a576b3f1535622",
    '%x works for negative big Rats';
is sprintf('%X', 453973694165307953197296969697410619233826 + .1),
    "5361BD927DC58766E6533A576B3F1535622",
    '%X works for big Rats';
is sprintf('%X', -453973694165307953197296969697410619233826 - .1),
    "-5361BD927DC58766E6533A576B3F1535622",
    '%X works for negative big Rats';

is sprintf('%5.2f', 3.1415),    ' 3.14',    '5.2 %f';
is sprintf('%5.2F', 3.1415),    ' 3.14',    '5.2 %F';
is sprintf('%5.2g', 3.1415),    '  3.1',    '5.2 %g';
is sprintf('%5.2G', 3.1415),    '  3.1',    '5.2 %G';

ok sprintf('%5.2e', 3.1415)     ~~ /^ "3.14e+" "0"? "00" $/, '5.2 %e';
ok sprintf('%5.2E', 3.1415)     ~~ /^ "3.14E+" "0"? "00" $/, '5.2 %E';
ok sprintf('%5.2g', 3.1415e30)  ~~ /^ "3.1e+" "0"? "30" $/, '5.2 %g';
ok sprintf('%5.2G', 3.1415e30)  ~~ /^ "3.1E+" "0"? "30" $/, '5.2 %G';
ok sprintf('%5.2g', 3.1415e-30) ~~ /^ "3.1e-" "0"? "30" $/, '5.2 %g';
ok sprintf('%5.2G', 3.1415e-30) ~~ /^ "3.1E-" "0"? "30" $/, '5.2 %G';

is sprintf('%20.2f', 3.1415),    '                3.14',    '20.2 %f';
is sprintf('%20.2F', 3.1415),    '                3.14',    '20.2 %F';
is sprintf('%20.2g', 3.1415),    '                 3.1',    '20.2 %g';
is sprintf('%20.2G', 3.1415),    '                 3.1',    '20.2 %G';

ok sprintf('%20.2e', 3.1415)      eq '           3.14e+000' | '            3.14e+00', '20.2 %e';
ok sprintf('%20.2E', 3.1415)      eq '           3.14E+000' | '            3.14E+00', '20.2 %E';
ok sprintf('%20.2g', 3.1415e30)   eq '            3.1e+030' | '             3.1e+30', '20.2 %g';
ok sprintf('%20.2G', 3.1415e30)   eq '            3.1E+030' | '             3.1E+30', '20.2 %G';
ok sprintf('%20.2g', 3.1415e-30)  eq '            3.1e-030' | '             3.1e-30', '20.2 %g';
ok sprintf('%20.2G', 3.1415e-30)  eq '            3.1E-030' | '             3.1E-30', '20.2 %G';

is sprintf('%20.2f', -3.1415),    '               -3.14',    'negative 20.2 %f';
is sprintf('%20.2F', -3.1415),    '               -3.14',    'negative 20.2 %F';
is sprintf('%20.2g', -3.1415),    '                -3.1',    'negative 20.2 %g';
is sprintf('%20.2G', -3.1415),    '                -3.1',    'negative 20.2 %G';

ok sprintf('%20.2e', -3.1415)     eq '          -3.14e+000' | '           -3.14e+00', 'negative 20.2 %e';
ok sprintf('%20.2E', -3.1415)     eq '          -3.14E+000' | '           -3.14E+00', 'negative 20.2 %E';
ok sprintf('%20.2g', -3.1415e30)  eq '           -3.1e+030' | '            -3.1e+30', 'negative 20.2 %g';
ok sprintf('%20.2G', -3.1415e30)  eq '           -3.1E+030' | '            -3.1E+30', 'negative 20.2 %G';
ok sprintf('%20.2g', -3.1415e-30) eq '           -3.1e-030' | '            -3.1e-30', 'negative 20.2 %g';
ok sprintf('%20.2G', -3.1415e-30) eq '           -3.1E-030' | '            -3.1E-30', 'negative 20.2 %G';

is sprintf('%020.2f', 3.1415),    '00000000000000003.14',    '020.2 %f';
is sprintf('%020.2F', 3.1415),    '00000000000000003.14',    '020.2 %F';
is sprintf('%020.2g', 3.1415),    '000000000000000003.1',    '020.2 %g';
is sprintf('%020.2G', 3.1415),    '000000000000000003.1',    '020.2 %G';

ok sprintf('%020.2e', 3.1415)     eq '000000000003.14e+000' | '0000000000003.14e+00', '020.2 %e';
ok sprintf('%020.2E', 3.1415)     eq '000000000003.14E+000' | '0000000000003.14E+00', '020.2 %E';
ok sprintf('%020.2g', 3.1415e30)  eq '0000000000003.1e+030' | '00000000000003.1e+30', '020.2 %g';
ok sprintf('%020.2G', 3.1415e30)  eq '0000000000003.1E+030' | '00000000000003.1E+30', '020.2 %G';
ok sprintf('%020.2g', 3.1415e-30) eq '0000000000003.1e-030' | '00000000000003.1e-30', '020.2 %g';
ok sprintf('%020.2G', 3.1415e-30) eq '0000000000003.1E-030' | '00000000000003.1E-30', '020.2 %G';

is sprintf('%020.2f', -3.1415),    '-0000000000000003.14',    'negative 020.2 %f';
is sprintf('%020.2F', -3.1415),    '-0000000000000003.14',    'negative 020.2 %F';
is sprintf('%020.2g', -3.1415),    '-00000000000000003.1',    'negative 020.2 %g';
is sprintf('%020.2G', -3.1415),    '-00000000000000003.1',    'negative 020.2 %G';

ok sprintf('%020.2e', -3.1415)     eq '-00000000003.14e+000' | '-000000000003.14e+00', 'negative 020.2 %e';
ok sprintf('%020.2E', -3.1415)     eq '-00000000003.14E+000' | '-000000000003.14E+00', 'negative 020.2 %E';
ok sprintf('%020.2g', -3.1415e30)  eq '-000000000003.1e+030' | '-0000000000003.1e+30', 'negative 020.2 %g';
ok sprintf('%020.2G', -3.1415e30)  eq '-000000000003.1E+030' | '-0000000000003.1E+30', 'negative 020.2 %G';
ok sprintf('%020.2g', -3.1415e-30) eq '-000000000003.1e-030' | '-0000000000003.1e-30', 'negative 020.2 %g';
ok sprintf('%020.2G', -3.1415e-30) eq '-000000000003.1E-030' | '-0000000000003.1E-30', 'negative 020.2 %G';

is sprintf('%e', 2.718281828459), sprintf('%.6e', 2.718281828459), '%e defaults to .6';
is sprintf('%E', 2.718281828459), sprintf('%.6E', 2.718281828459), '%E defaults to .6';
is sprintf('%f', 2.718281828459), sprintf('%.6f', 2.718281828459), '%f defaults to .6';
is sprintf('%g', 2.718281828459), sprintf('%.6g', 2.718281828459), '%g defaults to .6';
is sprintf('%G', 2.718281828459), sprintf('%.6G', 2.718281828459), '%G defaults to .6';

# I don't know about the wisdom of these, but this is how Perl 5 handles it
#?rakudo 10 skip "Issues with Inf"
is sprintf('%e', Inf), "inf", 'Inf properly handled %e';
is sprintf('%E', Inf), "INF", 'Inf properly handled %E';
is sprintf('%f', Inf), "inf", 'Inf properly handled %f';
is sprintf('%g', Inf), "inf", 'Inf properly handled %g';
is sprintf('%G', Inf), "INF", 'Inf properly handled %G';
is sprintf('%e', -Inf), "-inf", '-Inf properly handled %e';
is sprintf('%E', -Inf), "-INF", '-Inf properly handled %E';
is sprintf('%f', -Inf), "-inf", '-Inf properly handled %f';
is sprintf('%g', -Inf), "-inf", '-Inf properly handled %g';
is sprintf('%G', -Inf), "-INF", '-Inf properly handled %G';

# L<S32::Str/"Str"/"The special directive, %n does not work in Perl 6">
dies_ok(sub {my $x = sprintf('%n', 1234)}, '%n dies (Perl 5 compatibility)');   #OK not used
#?rakudo skip "%p doesn't yet throw exception - but should it, or just Failure?"
dies_ok(sub {my $x = sprintf('%p', 1234)}, '%p dies (Perl 5 compatibility)');   #OK not used

is sprintf('%s', NaN),              NaN,    'sprintf %s handles NaN';
is sprintf('%s', -NaN),             NaN,    'sprintf %s handles NaN';
is sprintf('%s', Inf),              Inf,    'sprintf %s handles Inf';
is sprintf('%s', -Inf),            -Inf,    'sprintf %s handles Inf';

is sprintf('%d %1$x %1$o', 12),    '12 c 14',  'positional argument specifier $';

# RT 117547
is sprintf('%10s', "☃" x 3), '       ☃☃☃', 'multi-byte characters are counted correctly for %Ns strings';

is sprintf("%x %x", 301281685344656640, 301281685344656669), '42e5e18b84c9d00 42e5e18b84c9d1d',   'RT #118601';
is sprintf("%d", 42**20),                                    '291733167875766667063796853374976', 'RT #118253';
is map({chars sprintf "[%18s]\n", "ಠ" x $_ }, 0..6),         [21, 21, 21, 21, 21, 21, 21],        'RT #117547';
#?niecza skip 'Date NYI'
is Date.new(-13_000_000_000, 1, 1),                          '-13000000000-01-01',                'RT #114760';

# RT #116280
#?rakudo.jvm skip "java.lang.NumberFormatException"
{
    #?rakudo.parrot todo 'sprintf prints numbers before NaN'
    is sprintf('%12.5f',  NaN), '         NaN', 'RT 116280';
    #?rakudo.parrot 2 skip "sprintf hangs when printing Inf/-Inf"
    #?niecza 2 todo "https://github.com/sorear/niecza/issues/181"
    is sprintf('%12.5f',  Inf), '         inf', 'RT 116280';
    is sprintf('%12.5f', -Inf), '        -inf', 'RT 116280';
}

# RT #106594, #62316, #74610
#?niecza skip 'dubious test - should be testing exception type, not string. Niecza does respond with an appropriate, but differently worded string'
{
    try sprintf("%d-%s", 42);
    is $!, 'Too many directives: found 2, but only 1 arguments after the format string', 'RT #106594, #62316, #74610';
}

# found by japhb
{
    #?rakudo todo 'buggy'
    #?niecza todo 'buggy'
    is sprintf("%.0f", 1.969), "2",     '%.0f of 1.969 should be 2';
    #?rakudo todo 'buggy'
    is sprintf("%.1f", 1.969), "2.0",   '%.1f of 1.969 should be 2.0';
    #?rakudo.jvm todo 'buggy'
    is sprintf("%.2f", 1.969), "1.97",  '%.2f of 1.969 should be 1.97';
    #?rakudo.jvm todo 'buggy'
    is sprintf("%.3f", 1.969), "1.969", '%.3f of 1.969 should be 1.969';
}

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/substr-rw.t�����������������������������������������������������������0000664�0001750�0001750�00000010036�12224265625�017320� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

sub l (Int $a) {  my $l = $a; return $l }

{
    my $str = "gorch ding";

    substr-rw($str, 0, 5) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string");

    {
        my $r = substr-rw($str, 0, 5);
        is($r, "gloop", '$r referent is eq to the substr-rwing');

        #?pugs todo 'scalarrefs are not handled correctly'
        $r = "boing";
        #?rakudo todo 'NYI'
        #?niecza todo
        is($str, "boing ding", "assignment to reference modifies original");
        is($r, "boing", '$r is consistent');

        #?pugs todo 'scalarrefs are not handled correctly'
        my $o = substr-rw($str, 3, 2);
        #?rakudo 3 todo 'NYI'
        #?niecza 3 todo
        is($o, "ng", "other ref to other lvalue");
        $r = "foo";
        #?pugs todo
        is($str, "foo ding", "lvalue ref size varies but still works");
        #?pugs todo
        is($o, " d", "other lvalue wiggled around");
    }

}

{ # as lvalue, should work
    my $str = "gorch ding";

    substr-rw($str, 0, 5) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string");
};

{ # as lvalue, using :=, should work
    my $str = "gorch ding";

    substr-rw($str, 0, 5) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string");

    my $r := substr-rw($str, 0, 5);
    is($r, "gloop", 'bound $r is eq to the substr-rwing');

    $r = "boing";
    is($str, "boing ding", "assignment to bound var modifies original");
    #?pugs todo 'bug'
    #?rakudo todo 'NYI'
    is($r, "boing", 'bound $r is consistent');

    my $o := substr-rw($str, 3, 2);
    is($o, "ng", "other bound var to other lvalue");
    $r = "foo";
    is($str, "foo ding", "lvalue ref size varies but still works");
    #?pugs todo 'bug'
    #?rakudo todo 'NYI'
    is($o, " d", "other lvalue wiggled around");
};

{
    my $str = "gorch ding";

    substr-rw($str, 0, l(5)) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string (substr-rw(Int, StrLen)).");

    {
        my $r = \substr-rw($str, 0, l(5));
        ok(WHAT($r).gist, '$r is a reference (substr-rw(Int, StrLen)).');
        is($$r, "gloop", '$r referent is eq to the substr-rwing (substr-rw(Int, StrLen)).');

    #?pugs todo 'scalarrefs are not handled correctly'
        $$r = "boing";
        #?rakudo todo 'NYI'
        is($str, "boing ding", "assignment to reference modifies original (substr-rw(Int, StrLen)).");
        is($$r, "boing", '$r is consistent (substr-rw(Int, StrLen)).');

    #?pugs todo 'scalarrefs are not handled correctly'
        my $o = \substr-rw($str, 3, l(2));
        #?rakudo 3 todo 'NYI'
        is($$o, "ng", "other ref to other lvalue (substr-rw(Int, StrLen)).");
        $$r = "foo";
        #?pugs todo
        is($str, "foo ding", "lvalue ref size varies but still works (substr-rw(Int, StrLen)).");
        #?pugs todo
        is($$o, " d", "other lvalue wiggled around (substr-rw(Int, StrLen)).");
    }

}

{ # as lvalue, should work
    my $str = "gorch ding";

    substr-rw($str, 0, l(5)) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string (substr-rw(Int, StrLen)).");
};

{ # as lvalue, using :=, should work
    my $str = "gorch ding";

    substr-rw($str, 0, l(5)) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string (substr-rw(Int, StrLen)).");

    my $r := substr-rw($str, 0, l(5));
    is($r, "gloop", 'bound $r is eq to the substr-rwing (substr-rw(Int, StrLen)).');

    $r = "boing";
    is($str, "boing ding", "assignment to bound var modifies original (substr-rw(Int, StrLen)).");
    #?pugs todo 'bug'
    #?rakudo todo 'NYI'
    is($r, "boing", 'bound $r is consistent (substr-rw(Int, StrLen)).');

    my $o := substr-rw($str, 3, l(2));
    is($o, "ng", "other bound var to other lvalue (substr-rw(Int, StrLen)).");
    $r = "foo";
    is($str, "foo ding", "lvalue ref size varies but still works (substr-rw(Int, StrLen)).");
    #?pugs todo 'bug'
    #?rakudo todo 'NYI'
    is($o, " d", "other lvalue wiggled around (substr-rw(Int, StrLen)).");
};

done;
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/substr.t��������������������������������������������������������������0000664�0001750�0001750�00000024504�12224265625�016677� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 92;

# L<S32::Str/Str/=item substr>

{ # read only
    my $str = "foobar";

    is(substr($str, 0, 0), '', 'Empty string with 0 as thrid arg');
    is(substr($str, 3, 0), '', 'Empty string with 0 as thrid arg');
    is(substr($str, 0, 1), "f", "first char");
    #?pugs todo
    is(substr($str, *-1), "r", "last char");
    #?pugs todo
    is(substr($str, *-4, 2), "ob", "counted from the end");
    is(substr($str, 1, 2), "oo", "arbitrary middle");
    is(substr($str, 3), "bar", "length omitted");
    is(substr($str, 3, 10), "bar", "length goes past end");
    ok(!defined(substr($str, 20, 5)), "substr outside of string");
    #?pugs todo
    ok(!defined(substr($str, *-100, 10)), "... on the negative side");

    #?pugs todo
    is(substr($str, 0, *-2), "foob", "from beginning, with negative length");
    #?pugs todo
    is(substr($str, 2, *-2), "ob", "in middle, with negative length");
    is(substr($str, 3, *-3), "", "negative length - gives empty string");
    #?pugs todo
    is(substr($str, *-4, *-1), "oba", "start from the end and negative length");

    is($str, "foobar", "original string still not changed");
};

#?pugs skip 'more discussion needed'
#?rakudo skip 'too many args'
{ # replacement
    my $str = "foobar";

    substr($str, 2, 1, "i");
    is($str, "foibar", "fourth arg to substr replaced part");

    substr($str, *-1, 1, "blah");
    is($str, "foibablah", "longer replacement expands string");

    substr($str, 1, 3, "");
    is($str, "fablah", "shorter replacement shrunk it");

    substr($str, 1, *-1, "aye");
    is($str, "fayeh", "replacement with negative length");
};

{ # misc
    my $str = "hello foo and bar";
    is(substr($str, 6, 3), "foo", "substr");
    is($str.substr(6, 3), "foo", ".substr");
    is(substr("hello foo bar", 6, 3), "foo", "substr on literal string");
    is("hello foo bar".substr(6, 3), "foo", ".substr on literal string");
    is("hello foo bar".substr(6, 3).uc, "FOO", ".substr.uc on literal string");
    is("hello foo bar and baz".substr(6, 10).wordcase, "Foo Bar An", ".substr.wordcase on literal string");
    is("hello »« foo".substr(6, 2), "»«", ".substr on unicode string");
    is("שיעבוד כבר".substr(4, 4), "וד כ", ".substr on Hebrew text");
}

#?pugs skip 'chrs'
#?rakudo.jvm skip 'java.nio.charset.MalformedInputException'
{ # codepoints greater than 0xFFFF
    my $str = join '', 0x10426.chr, 0x10427.chr;
    is $str.codes, 2, "Sanity check string";
    #?niecza 2 todo "substr bug"
    is substr($str, 0, 1), 0x10426.chr, "Taking first char of Deseret string";
    is substr($str, 1, 1), 0x10427.chr, "Taking second char of Deseret string";
}

sub l (Int $a) {  my $l = $a; return $l }

#Substr with StrLen
{ # read only
    my $str = "foobar";

    is(substr($str, 0, l(0)), '', 'Empty string with 0 as thrid arg (substr(Int, StrLen)).');
    is(substr($str, 3, l(0)), '', 'Empty string with 0 as thrid arg (substr(Int, StrLen)).');
    is(substr($str, 0, l(1)), "f", "first char (substr(Int, StrLen)).");
    #?pugs todo
    is(substr($str, *-1, l(1)), "r", "last char (substr(Int, StrLen)).");
    #?pugs todo
    is(substr($str, *-4, l(2)), "ob", "counted from the end (substr(Int, StrLen)).");
    is(substr($str, 1, l(2)), "oo", "arbitrary middle (substr(Int, StrLen)).");
    is(substr($str, 3, l(6)), "bar", "length goes past end (substr(Int, StrLen)).");
    ok(!defined(substr($str, 20, l(5))), "substr outside of string (substr(Int, StrLen)).");
    #?pugs todo
    ok(!defined(substr($str, *-100, l(5))), "... on the negative side (substr(Int, StrLen)).");

    is($str, "foobar", "original string still not changed (substr(Int, StrLen)).");
};

#?pugs skip 'more discussion needed'
#?rakudo skip 'too many args'
{ # replacement
    my $str = "foobar";

    substr($str, 2, l(1), "i");
    is($str, "foibar", "fourth arg to substr replaced part (substr(Int, StrLen)).");

    substr($str, *-1, l(1), "blah");
    is($str, "foibablah", "longer replacement expands string (substr(Int, StrLen)).");

    substr($str, 1, l(3), "");
    is($str, "fablah", "shorter replacement shrunk it (substr(Int, StrLen)).");
};


{ # misc
    my $str = "hello foo and bar";

    is(substr($str, 6, l(3)), "foo", "substr (substr(Int, StrLen)).");
    is($str.substr(6, l(3)), "foo", ".substr (substr(Int, StrLen)).");
    is(substr("hello foo bar", 6, l(3)), "foo", "substr on literal string (substr(Int, StrLen)).");
    is("hello foo bar".substr(6, l(3)), "foo", ".substr on literal string (substr(Int, StrLen)).");
    is("hello foo bar".substr(6, l(3)).uc, "FOO", ".substr.uc on literal string (substr(Int, StrLen)).");
    is("hello foo bar and baz".substr(6, l(10)).wordcase, "Foo Bar An", ".substr.wordcase on literal string (substr(Int, StrLen)).");
    is("hello »« foo".substr(6, l(2)), "»«", ".substr on unicode string (substr(Int, StrLen)).");
    is("שיעבוד כבר".substr(4, l(4)), "וד כ", ".substr on Hebrew text (substr(Int, StrLen)).");
}

sub p (Int $a) {  my $p = $a; return $p }

#Substr with StrPos
#?rakudo skip 'No support for StrPos'
#?niecza skip 'StrPos tests broken'
{ # read only
    my $str = "foobar";
    is(substr($str, 0, p(0)), '', 'Empty string with 0 as thrid arg (substr(Int, StrPos)).');
    #?pugs todo
    is(substr($str, 3, p(3)), '', 'Empty string with 0 as thrid arg (substr(Int, StrPos)).');
    is(substr($str, 0, p(1)), "f", "first char (substr(Int, StrPos)).");

    #?pugs todo
    is(substr($str, 1, p(3)), "oo", "arbitrary middle (substr(Int, StrPos)).");
    is(substr("IMAGINATIVE => Insane Mimicries of Amazingly Gorgeous, Incomplete Networks, Axiomatic Theorems, and Immortally Vivacious Ecstasy", 1, p(2)), "MA", "substr works with named argument (substr(Int, StrPos)).");
    is(substr($str, 3, p(6)), "bar", "length goes past end (substr(Int, StrPos)).");
    ok(!defined(substr($str, 20, p(5))), "substr outside of string (substr(Int, StrPos)).");
    #?pugs todo
    ok(!defined(substr($str, *-100, p(5))), "... on the negative side (substr(Int, StrPos)).");

    is($str, "foobar", "original string still not changed (substr(Int, StrPos)).");
};

#?pugs skip 'more discussion needed'
#?rakudo skip 'No support for StrPos'
#?niecza skip 'StrPos tests broken'
{ # replacement
    my $str = "foobar";
    substr($str, 2, p(1), "i");
    is($str, "foibar", "fourth arg to substr replaced part (substr(Int, StrPos)).");

    substr($str, 2, p(1), "a");
    is($str, "foabar", "substr with replacement works with named argument (substr(Int, StrPos)).");

    substr($str, *-1, p(1), "blah");
    is($str, "foibablah", "longer replacement expands string (substr(Int, StrPos)).");

    substr($str, 1, p(3), "");
    is($str, "fablah", "shorter replacement shrunk it (substr(Int, StrPos)).");
};

# as lvalue, XXX: not sure this should work, as that'd be action at distance:
#   my $substr = \substr($str, ...);
#   ...;
#   some_func $substr; # manipulates $substr
#   # $str altered!
# But one could think that's the wanted behaviour, so I leave the test in.
#?rakudo skip 'No support for StrPos'
#?niecza skip 'StrPos tests broken'
{
    my $str = "gorch ding";

    substr($str, 0, p(5)) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string (substr(Int, StrPos)).");

    my $r = \substr($str, 0, p(5));
    ok(WHAT($r).gist, '$r is a reference (substr(Int, StrPos)).');
    is($$r, "gloop", '$r referent is eq to the substring (substr(Int, StrPos)).');

#?pugs todo 'scalarrefs are not handled correctly'
    $$r = "boing";
    is($str, "boing ding", "assignment to reference modifies original (substr(Int, StrPos)).");
    is($$r, "boing", '$r is consistent (substr(Int, StrPos)).');

#?pugs todo 'scalarrefs are not handled correctly'
    my $o = \substr($str, 3, p(2));
    is($$o, "ng", "other ref to other lvalue (substr(Int, StrPos)).");
    $$r = "foo";
    #?pugs todo
    is($str, "foo ding", "lvalue ref size varies but still works (substr(Int, StrPos)).");
    #?pugs todo
    is($$o, " d", "other lvalue wiggled around (substr(Int, StrPos)).");

};

#?rakudo skip 'lvalue substr'
#?niecza skip 'StrPos tests broken'
{ # as lvalue, should work
    my $str = "gorch ding";

    substr($str, 0, p(5)) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string (substr(Int, StrPos)).");
};

#?rakudo skip 'No support for StrPos'
#?niecza skip 'StrPos tests broken'
{ # as lvalue, using :=, should work
    my $str = "gorch ding";

    substr($str, 0, p(5)) = "gloop";
    is($str, "gloop ding", "lvalue assignment modified original string (substr(Int, StrPos)).");

    my $r := substr($str, 0, p(5));
    is($r, "gloop", 'bound $r is eq to the substring (substr(Int, StrPos)).');

    $r = "boing";
    is($str, "boing ding", "assignment to bound var modifies original (substr(Int, StrPos)).");
    #?pugs todo 'bug'
    is($r, "boing", 'bound $r is consistent (substr(Int, StrPos)).');

    my $o := substr($str, 3, p(2));
    is($o, "ng", "other bound var to other lvalue (substr(Int, StrPos)).");
    $r = "foo";
    is($str, "foo ding", "lvalue ref size varies but still works (substr(Int, StrPos)).");
    #?pugs todo 'bug'
    is($o, " d", "other lvalue wiggled around (substr(Int, StrPos)).");
};

{ # misc
    my $str = "hello foo and bar";
    is(substr($str, 6, p(3)), "foo", "substr (substr(Int, StrPos)).");
    is($str.substr(6, p(3)), "foo", ".substr (substr(Int, StrPos)).");
    is(substr("hello foo bar", 6, p(3)), "foo", "substr on literal string (substr(Int, StrPos)).");
    is("hello foo bar".substr(6, p(3)), "foo", ".substr on literal string (substr(Int, StrPos)).");
    is("hello foo bar".substr(6, p(3)).uc, "FOO", ".substr.uc on literal string (substr(Int, StrPos)).");
    is("hello foo bar and baz".substr(6, p(10)).wordcase, "Foo Bar An", ".substr.wordcase on literal string (substr(Int, StrPos)).");
    is("hello »« foo".substr(6, p(2)), "»«", ".substr on unicode string (substr(Int, StrPos)).");
    is("שיעבוד כבר".substr(4, p(4)), "וד כ", ".substr on Hebrew text (substr(Int, StrPos)).");
}

#?niecza todo
#?pugs todo
eval_dies_ok 'substr(Any, 0)', 'substr needs Cool as argument';

# RT 76682
#?pugs skip 'Failure NYI'
#?niecza skip "'Failure' used at line 244"
{
    is "foo".substr(4), Failure, 'substr with start beyond end of string is Failure'
}

# RT 115086
#?niecza todo
#?pugs todo
{
    is "abcd".substr(2, Inf), 'cd', 'substr to Inf'
}

#?pugs todo
{
    is 123456789.substr(*-3), '789', 'substr with Int and WhateverCode arg';

}

# vim: ft=perl6
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/tclc.t����������������������������������������������������������������0000664�0001750�0001750�00000001021�12224265625�016267� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 6;

is tclc('aBcD'),        'Abcd',         'tclc sub form on mixed-case latin string';
is 'aBcD'.tclc,         'Abcd',         'method form';
#?rakudo.jvm todo "nigh"
is 'ßß'.tclc,           'Ssß',          'tclc and German sharp s';
is tclc('ljenčariti'),   'Ljenčariti',    'lj => Lj (in one character)';
is 'Ångstrom'.tclc,     'Ångstrom',     'Å remains Å';
#?rakudo.parrot todo 'unknown tclc problem'
is "\x1044E TEST".tclc, "\x10426 test", 'tclc works on codepoints greater than 0xffff';

���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/tc.t������������������������������������������������������������������0000664�0001750�0001750�00000001305�12224265625�015755� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 9;

# L<S32::Str/Str/ucfirst>

is tc("hello world"), "Hello world", "simple";
is tc(""),            "",            "empty string";
is tc("üüüü"),        "Üüüü",        "umlaut";
is tc("óóóó"),        "Óóóó",        "accented chars";
#?pugs todo
is tc('ßß'),          'Ssß',         'sharp s => Ss';
#?pugs todo
is tc('lj'),           'Lj',           'lj => Lj (in one character)';
is 'abc'.tc,          'Abc',         'method form of title case';
#?rakudo todo 'leaving the rest alone'
is 'aBcD'.tc,         'ABcD',        'tc only modifies first character';
is "\x1044E\x10427".tc, "\x10426\x10427", 'tc works on codepoints greater than 0xffff';


# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/trim.t����������������������������������������������������������������0000664�0001750�0001750�00000010122�12224265625�016317� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

# L<S32::Str/Str/=item trim>

plan 36;

=begin pod

Basic tests for the trim() builtin

=end pod

# Currently this is unspecced, but active discussion on mailing lists is
# occurring, with Larry agreeing that this should be here.

{
    my $foo = "foo  \n";
    #?pugs emit #
    trim($foo);
    #?pugs skip 'sub NYI'
    is($foo, "foo  \n", 'our variable was not yet trimmed');
    $foo .= trim;
    is($foo, 'foo', 'our variable is trimmed correctly');
    $foo =  "\t   \t  \tfoo   \t\t  \t \n";
    $foo .= trim;
    is($foo, 'foo', 'our variable is trimmed again with no effect');
}

{
    is(''.trim, '', 'trimming an empty string gives an empty string');
}

{
    is('a'.trim, 'a', 'trimming one character string, no spaces, works');
    is(' a'.trim, 'a', 'trimming one character string preceded by space works');
    is('a '.trim, 'a', 'trimming one character string followed by space works');
    is(' a '.trim, 'a', 'trimming one character string surrounded by spaces works');
}

{
    my $foo = " foo bar ";
    $foo .= trim;
    is($foo, "foo bar", 'our variable is trimmed correctly');
    $foo .= trim;
    is($foo, "foo bar", 'our variable is trimmed again with no effect');
}

{
    my $foo = "foo\n ";
    $foo .= trim;
    $foo .= trim;
    $foo .= trim;
    is($foo, "foo", 'our variable can be trimmed multiple times');
}

{
    my $foo = "foo\n\n";
    my $trimmed = $foo.trim;
    is($foo, "foo\n\n", ".trim has no effect on the original string");
    is($trimmed, "foo", ".trim returns correctly trimmed value");

    $trimmed = $trimmed.trim;
    is($trimmed, "foo", ".trim returns correctly trimmed value again");
}

#
# trim-leading
#

{
    my $foo = "   foo  \n";
    #?pugs emit #
    trim-leading($foo);
    #?pugs skip 'sub NYI'
    is($foo, "   foo  \n", 'trim-leading does not trim a variable in-place');
    $foo .= trim-leading;
    is($foo, "foo  \n", 'trim-leading works correctly');
    $foo =  "\t   \t  \tfoo   \t\t  \t \n";
    $foo .= trim-leading;
    is($foo, "foo   \t\t  \t \n", 'our variable is trimmed again with no effect');
}

{
    is(''.trim-leading, '', 'trim-leading on an empty string gives an empty string');
    is(' '.trim-leading, '', 'trim-leading on an one-space string gives an empty string');
    is("\n".trim-leading, '', 'trim-leading on newline string gives an empty string');
    is('  '.trim-leading, '', 'trim-leading on a two-space string gives an empty string');
}

{
    my $foo = " foo bar ";
    $foo .= trim-leading;
    is($foo, "foo bar ", 'our variable is trimmed correctly');
    $foo .= trim-leading;
    is($foo, "foo bar ", 'our variable is trimmed again with no effect');
}

{
    my $foo = "\n foo\n ";
    $foo .= trim-leading;
    $foo .= trim-leading;
    $foo .= trim-leading;
    is($foo, "foo\n ", 'our variable can be trimmed multiple times');
}

#
# trim-trailing
#

{
    my $foo = "   foo  \n";
    #?pugs emit #
    trim-trailing($foo);
    #?pugs skip 'sub NYI'
    is($foo, "   foo  \n", 'trim-trailing does not trim a variable in-place');
    $foo .= trim-trailing;
    is($foo, "   foo", 'trim-trailing works correctly');
    $foo =  "\t   \t  \tfoo   \t\t  \t \n";
    $foo .= trim-trailing;
    is($foo, "\t   \t  \tfoo", 'our variable is trimmed again with no effect');
}

{
    is(''.trim-trailing, '', 'trim-trailing on an empty string gives an empty string');
    is(' '.trim-trailing, '', 'trim-trailing on an one-space string gives an empty string');
    is("\n".trim-trailing, '', 'trim-trailing on newline string gives an empty string');
    is('  '.trim-trailing, '', 'trim-trailing on a two-space string gives an empty string');
}

{
    my $foo = " foo bar ";
    $foo .= trim-trailing;
    is($foo, " foo bar", 'our variable is trimmed correctly');
    $foo .= trim-trailing;
    is($foo, " foo bar", 'our variable is trimmed again with no effect');
}

{
    my $foo = "\n foo\n ";
    $foo .= trim-trailing;
    $foo .= trim-trailing;
    $foo .= trim-trailing;
    is($foo, "\n foo", 'our variable can be trimmed multiple times');
}

#?pugs todo
{
    ok ' ab ' ~~ /.*/, 'regex sanity';
    is $/.trim, 'ab', 'Match.trim';
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/uc.t������������������������������������������������������������������0000664�0001750�0001750�00000003072�12224265625�015761� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 18;

# L<S32::Str/"Str"/=item uc>

is(uc("Hello World"), "HELLO WORLD", "simple");
is(uc(""), "", "empty string");
{
    is(uc("åäö"), "ÅÄÖ", "some finnish non-ascii chars");
    is(uc("äöü"), "ÄÖÜ", "uc of German Umlauts");
    is(uc("óòúù"), "ÓÒÚÙ", "accented chars");
}
is(uc(lc('HELL..')), 'HELL..', "uc/lc test");

{
    $_ = "Hello World";
    my $x = .uc;
    is $x, "HELLO WORLD", 'uc uses the default $_';
}

{
    my $x = "Hello World";
    is $x.uc, "HELLO WORLD", '$x.uc works';
    is "Hello World".uc, "HELLO WORLD", '"Hello World".uc works';
}

## Bug: GERMAN SHARP S ("ß") should uc() to "SS", but it doesn't
## Compare with: perl -we 'use utf8; print uc "ß"'
#
# XXX newest Unicode release has an upper-case ß codepoint - please
# clarify if this should be used instead. Commenting the test so far.
#
# Unicode 5.1.0 SpecialCasing.txt has 00DF -> 0053 0053
# nothing maps to 1E9E, the new "capital sharp s"
# so I think this is right -rhr
#?niecza todo 'German language weirdness'
#?pugs todo
is(uc("ß"), "SS", "uc() of non-ascii chars may result in two chars");

{
    is("áéíöüóűőú".uc, "ÁÉÍÖÜÓŰŐÚ", ".uc on Hungarian vowels");
}

is ~(0.uc),         ~0, '.uc on Int';
is ~(0.tc),         ~0, '.tc on Int';
is ~(0.lc),         ~0, '.lc on Int';

#?DOES 4
#?rakudo skip 'but RoleName'
#?pugs todo
{
    role A {
        has $.thing = 3;
    }
    for <uc lc tc lcfirst> -> $meth {
        my $str = "('Nothing much' but A).$meth eq 'Nothing much'.$meth";
        ok eval($str), $str;
    }
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/unpack.t��������������������������������������������������������������0000664�0001750�0001750�00000002346�12224265625�016636� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Str/Str/"=item pack">

plan 12;

{
    my $hexstring = Buf.new(:16<41>, :16<42>, :16<43>).unpack("H*");
    is $hexstring, "414243", 'H* works';
}

{
    my $buf
        = "03/23/2001 Totals                      1235.00    1172.98".encode;
    my ($date, $totals, $tot_income, $tot_expend)
        = $buf.unpack("A10 x A6 x19 A10 x A*");

    is $date,       "03/23/2001",  'field 1 (A11) works';
    is $totals,     "Totals",      'field 2 (A28) works';
    is $tot_income, "   1235.00",  'field 3 (A8) works';
    is $tot_expend, "   1172.98",  'field 4 (A*) works';
}

{
    my $buf = Buf.new(0x30, 0x30, 0x00, 0x30, 0x00, 0x00, 0x00,
                      0x12, 0x34, 0x12, 0x34, 0x56, 0x78,
                      0x34, 0x12, 0x78, 0x56, 0x34, 0x12);
    my ($char, $short, $long,
        $bigend_short, $bigend_long, $lilend_short, $lilend_long)
        = $buf.unpack("C S L n N v V");

    is $char,         0x30,       'C works';
    is $short,        0x30,       'S works';
    is $long,         0x30,       'L works';
    is $bigend_short, 0x1234,     'n works';
    is $bigend_long,  0x12345678, 'N works';
    is $lilend_short, 0x1234,     'v works';
    is $lilend_long,  0x12345678, 'V works';
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-str/words.t���������������������������������������������������������������0000664�0001750�0001750�00000002501�12241704255�016500� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

use Test;

plan 13;

# L<S32::Str/Str/=item words>

# words on Str
is "".words, (), 'words on empty string';
is "a".words, <a>, 'words on single character';
is "a bc d".words, <a bc d>, 'default matcher and limit';
is " a bc d ".words, <a bc d>, 'default matcher and limit (leading/trailing ws)';
is "a  bc  d".words, <a bc d>, 'words on string with double spaces';

is "a\tbc\td".words, <a bc d>, 'words on string with \t';
is "a\nbc\nd".words, <a bc d>, 'words on string with \n';

is "a\c[NO-BREAK SPACE]bc d".words, <a bc d>, 'words on string with (U+00A0 NO-BREAK SPACE)';
is "ä bc d".words, <ä bc d>, 'words on string with non-ASCII letter';

#?rakudo 2 skip 'graphemes not implemented'
#?niecza 2 todo 'charspec'
is "a\c[COMBINING DIAERESIS] bc d".words, ("ä", "bc", "d"), 'words on string with grapheme precomposed';
is( "a\c[COMBINING DOT ABOVE, COMBINING DOT BELOW] bc d".words,
    ("a\c[COMBINING DOT BELOW, COMBINING DOT ABOVE]", "bc", "d"),
    "words on string with grapheme without precomposed");

{
    my @list =  'split this string'.words;
    is @list.join('|'), 'split|this|string', 'Str.words';
}

# RT #120517
#?niecza todo 'extra .list on the lhs'
{
    my $RT120517 = "FOO";
    is qq:ww/$RT120517 "BAR BAZ"/.perl, qq:ww/FOO "BAR BAZ"/.perl, "interpolated variable .perl's like a literal"
}

# vim: ft=perl6
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-temporal/calendar.t�������������������������������������������������������0000664�0001750�0001750�00000030233�12224265625�020135� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������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
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-temporal/Date.t�����������������������������������������������������������0000664�0001750�0001750�00000011416�12237474612�017245� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Temporal/C<Date>>

plan 72;

# construction
{
    lives_ok { Date.new('2010-01-01') }, 'Date.new("2010-01-01")';
    lives_ok { Date.new(2010, 1, 1) }, 'List constructor';
    lives_ok { Date.new(:year(2010), :month(1), :day(1)) }, 'named arguments';
    lives_ok { Date.today }, 'Date.today';
    lives_ok { 
        my $dt = DateTime.new(:year(2010),:month(06), :day(04));   #OK octal
        Date.new($dt); 
    }, 'Date.new from DateTime';

    dies_ok { Date.new('malformed') }, 'obviously malformed string';
    dies_ok { Date.new('2010-00-23') }, 'dies on zero-based months';
    dies_ok { Date.new('2010-13-23') }, 'dies on month 13';
    dies_ok { Date.new('2010-01-00') }, 'dies on zero-based days';
    dies_ok { Date.new('2010-01-32') }, 'dies on day of month 32';
    dies_ok { Date.new('1999-02-29') }, 'dies on 29 February 1999';
    dies_ok { Date.new('1900-02-29') }, 'dies on 29 February 1900';
    lives_ok { Date.new('2000-02-29') }, '...but not 29 February 2000';

    isa_ok Date.new(2010, 01, 01), Date, 'Date.new() returns a Date';  #OK octal

    my $date = Date.new('1999-01-29');
    dies_ok { $date.clone(month => 2) }, 'dies on 29 February 1999 (Date.clone)';
    lives_ok { $date.clone(:month(2), :year(2000)) }, '..but not 29 February 2000 (Date.clone)';
}

# RT 112376, stringification
is ~Date.new(:year(2010), :month(3), :day(5)), '2010-03-05',
    'normal Date strinfies sanely';

# accessors

{
    my $d;

    ok ($d = Date.new('2000-02-28')), 'creation' or die "Something's very wrong";
    is $d.year, 2000,    'year';
    is $d.month,   2,    'month';
    is $d.day,    28,    'day';

    is $d.day-of-week,             1, 'Day of week';

    #is $d.is-leap-year,      Bool::True, 'leap year';
    is $d.days-in-month,          29, 'days in month';
}

# arithmetics

sub d($x) { Date.new($x); }
{
    is d('2010-04-12').succ, '2010-04-13', 'simple .succ';
    is d('2010-04-12').pred, '2010-04-11', 'simple .pred';

    is d('2000-02-28').succ, '2000-02-29', '.succ with leap year (1)';
    is d('2000-02-28').pred, '2000-02-27', '.pred with leap year (1)';

    is d('2000-02-29').succ, '2000-03-01', '.succ with leap year (2)';
    is d('2000-02-29').pred, '2000-02-28', '.pred with leap year (2)';
    is d('2000-03-01').pred, '2000-02-29', '.pred with leap year (3)';
}

# arithmetic operators
{
    is d('2000-02-28') + 7,  '2000-03-06', '+7';
    is d('2000-03-06') - 14, '2000-02-21', '-14';

    is d('2000-02-28') - d('2000-02-21'), 7, 'Difference of two dates';

    is d('2000-02-21') + 0, d('2000-02-21'), '+0';
    is d('2000-02-21') + -3, d('2000-02-21') - 3, '+ -3 == - 3';

    my ($a, $b, $c);
    # $a < $b < $c;
    $a = d('1963-07-02');
    $b = d('1964-02-01');
    $c = d('1964-02-02');

    ok  $a == $a, '== (+)';
    nok $a == $b, '== (-)';

    ok  $a != $c, '!= (+)';
    nok $a != $a, '!= (-)';

    ok  $b <= $b, '<= (+)';
    ok  $b <= $c, '<= (+)';
    nok $b <= $a, '<= (-)';

    nok $a <  $a, '<  (-)';
    ok  $a <  $b, '<  (+)';
    nok $b <  $a, '<  (-)';

    ok  $a >= $a, '>= (+)';
    ok  $b >= $a, '>= (+)';
    nok $b >= $c, '>= (-)';

    nok $a >  $a, '> (-)';
    ok  $b >  $a, '> (+)';
    nok $a >  $b, '> (-)';

    is $a cmp $a, Order::Same, 'cmp ( 0)';
    is $a cmp $b, Order::Less, 'cmp (-1)';
    is $c cmp $a, Order::More, 'cmp (+1)';


    is $a <=> $a, Order::Same, '<=> ( 0)';
    is $a <=> $b, Order::Less, '<=> (-1)';
    is $c <=> $a, Order::More, '<=> (+1)';
}

ok d('2011-01-14') ~~ d('2011-01-14'), 'Can smartmatch Date objects';

{
    is d('2013-12-23').delta(1, day), d('2013-12-24'), 'adding 1 day';
    is d('2014-01-31').delta(1, day), d('2014-02-01'), 'adding 1 day, overflowing to February';
    is d('2014-02-28').delta(2, days), d('2014-03-02'), 'adding 2 days, overflowing to March';
    is d('2013-12-23').delta(1, week), d('2013-12-30'), 'adding 1 week';
    is d('2014-01-31').delta(1, week), d('2014-02-07'), 'adding 1 week, overflowing to February';
    is d('2014-02-28').delta(2, weeks), d('2014-03-14'), 'adding 2 weeks, overflowing to March';
    is d('2014-12-30').delta(3, weeks), d('2015-01-20'), 'adding 3 weeks, overflowing to years';
    is d('2013-12-24').delta(-1, day), d('2013-12-23'), 'subtracting 1 day';
    is d('2014-02-01').delta(-1, day), d('2014-01-31'), 'subtracting 1 day, overflowing from February';
    is d('2014-03-02').delta(-2, days), d('2014-02-28'), 'subtracting 2 days, overflowing from March';
    is d('2013-12-30').delta(-1, week), d('2013-12-23'), 'subtracting 1 week';
    is d('2014-02-07').delta(-1, week), d('2014-01-31'), 'subtracting 1 week, overflowing from February';
    is d('2014-03-14').delta(-2, weeks), d('2014-02-28'), 'subtracting 2 weeks, overflowing from March';
    is d('2015-01-20').delta(-3, weeks), d('2014-12-30'), 'subtracting 3 weeks, overflowing to years';
}

done;
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-temporal/DateTime-Instant-Duration.t��������������������������������������0000664�0001750�0001750�00000013070�12224265625�023261� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 33;

=begin pod

DateTime is the only means of constructing arbitrary Instants,
so we test some of the properties of Instants and Durations here
rather than in S02/instants-and-duration.t.

=end pod

sub dtp($year, $month, $day, $hour, $minute, $second) {
    DateTime.new(:$year, :$month, :$day, :$hour, :$minute, :$second)
}

sub dtpi($year, $month, $day, $hour, $minute, $second) {
    DateTime.new(:$year, :$month, :$day, :$hour, :$minute, :$second).Instant
}

sub dti(*%args) { DateTime.new(|{year => 1984, %args}).Instant }

sub dsi($s) { DateTime.new($s).Instant }

sub diff(%early?, *%late) { + do dti(|%late) - dti(|%early) }

sub days($n) { $n * 24 * 60 * 60 }


# L<S32::Temporal/Accessors/'the method Instant'>

isa_ok dti, Instant, 'DateTime.Instant returns an Instant';
is dti, dti, 'Equal DateTimes yield equal Instants';
is diff, 0, 'The difference of equal Instants is 0';

ok dsi('2005-12-31T23:59:60') < dsi('2006-01-01T00:00:00'), 'DateTime.Instant counts leap seconds';
  # These seconds have equal POSIX times.

is diff(second => 5), 5, 'Instant subtraction (seconds)';
is diff(second => 2/7), 2/7, 'Instant subtraction (non-integral seconds)';
#?rakudo todo 'high-precision Instants NYI (need FatRats)'
is diff(second => 3.14159), 3.14159, 'Instant subtraction (needing high precision)';
is diff(minute => 15), 15 * 60, 'Instant subtraction (minutes)';
is diff(:hour(3), :minute(15), :second(33)),
    3*60*60 + 15*60 + 33, 'Instant subtraction (HMS)';
is diff(day => 4), days(3), 'Instant subtraction (days)';
is diff(month => 2), days(31), 'Instant subtraction (a month)';
is diff(month => 3), days(31 + 29), 'Instant subtraction (Jan and Feb, leap year)';
is diff({year => 1985}, year => 1985, month => 3), days(31 + 28), 'Instant subtraction (Jan and Feb, common year)';
is diff(:year(1985), :month(3), :day(14)),
    days(366 + 31 + 28 + 13), 'Instant subtraction (YMD)';
is +(DateTime.new('1985-03-14T13:28:22').Instant - dti),
    days(366 + 31 + 28 + 13) + 13*60*60 + 28*60 + 22, 'Instant subtraction (YMDHMS)';

{
    my $a = dtp(2004, 12, 31,   23, 57,  8.5);
    my $b = dtp(2005,  1,  1,    2, 22, 13.4);
    my $expected-diff = 60 - 8.5 + 2*60 + 2*60*60 + 22*60 + 13.4;
    is +($b.Instant() - $a.Instant), $expected-diff, 'Instant subtraction (ugly case)';
    
    $a .= clone(timezone => 35*60 - 5);
    $b .= clone(timezone => 3*60*60);
    is +($a.Instant() - $b.Instant), 0.1, 'Instant subtraction (time zones)';

    diff({:year(1997), :month(6), :day(30)},
            :year(1997), :month(7), :day(1)),
        days(1) + 1, 'Instant subtraction (June 30 leap second)';
    $a .= clone(year => 2005, timezone => 0);
    $b .= clone(year => 2006, timezone => 0);
    is +($b.Instant() - $a.Instant), $expected-diff + 1, 'Instant subtraction (December 31 leap second)';

    $a = DateTime.new('2006-01-01T12:33:58+1234');
      # In UTC, $a is 2005-12-31T23:59:58.
    $b = DateTime.new('2006-01-01T12:44:03+1244');
      # In UTC, $b is 2006-01-01T00:00:03.
    is +($b.Instant() - $a.Instant), 6, 'Instant subtraction (leap second and time zones)';

    $a .= clone(year => 1973);
    $b .= clone(year => 2008);
    is +($b.Instant() - $a.Instant), 1_104_451_227, 'Instant subtraction (thirty-year span)';
      # I got this figure by adding 22 (the number of leap seconds 
      # between the two moments) to the difference of POSIX
      # times.
}

# L<S32::Temporal/C<DateTime>/DateTime.new(now)>

is ~DateTime.new(dsi('2004-03-05T12:43:22')), '2004-03-05T12:43:22Z', 'Round-tripping DateTime.Instant (2004-03-05T12:43:22Z)';
is ~DateTime.new(dsi('2005-12-31T23:59:59')), '2005-12-31T23:59:59Z', 'Round-tripping DateTime.Instant (2005-12-31T23:59:59Z)';
is ~DateTime.new(dsi('2005-12-31T23:59:60')), '2005-12-31T23:59:60Z', 'Round-tripping DateTime.Instant (2005-12-31T23:59:60Z)';
is ~DateTime.new(dsi('2006-01-01T00:00:00')), '2006-01-01T00:00:00Z', 'Round-tripping DateTime.Instant (2006-01-01T00:00:00Z)';

is DateTime.new(dtpi 2005, 12, 31,   23, 59, 59.5).second, 59.5, 'Round-tripping DateTime.Instant (2005-12-31T23:59:59.5Z)';
is DateTime.new(dtpi 2005, 12, 31,   23, 59, 60.5).second, 60.5, 'Round-tripping DateTime.Instant (2005-12-31T23:59:60.5Z)';
is DateTime.new(dtpi 2006,  1,  1,    0,  0,  0.5).second,  0.5, 'Round-tripping DateTime.Instant (2006-01-01T00:00:00.5Z)';

#?rakudo 3 todo 'high-precision Instants NYI (need FatRats)'
is DateTime.new(dtpi 2005, 12, 31,   23, 59, 59.2).second, 59.2, 'Round-tripping DateTime.Instant (2005-12-31T23:59:59.2Z)';
is DateTime.new(dtpi 2005, 12, 31,   23, 59, 60.2).second, 60.2, 'Round-tripping DateTime.Instant (2005-12-31T23:59:60.2Z)';
is DateTime.new(dtpi 2006,  1,  1,    0,  0,  0.2).second,  0.2, 'Round-tripping DateTime.Instant (2006-01-01T00:00:00.2Z)';


{
    my $last-t = time;
    my $t;
    loop { # Loop until we reach the beginning of the next second.
        $t = time;
        last if $t > $last-t;
        $last-t = $t;
    }
    my $i = now;    # $t and $i are supposed to be within the
                    # same UTC second, but if we're unlucky they
                    # might not be.
    is ~DateTime.new($i), ~DateTime.new($t), 'DateTime.new(now)';
}

{
    my $dt = DateTime.new(dsi('1999-12-31T23:59:59'),
        timezone => -(5*60*60 + 55*60),
        formatter => { .day ~ '/' ~ .month ~ '/' ~ .year ~ ' ' ~
                       .second ~ 's' ~ .minute ~ 'm' ~ .hour ~ 'h' });
    is ~$dt, '31/12/1999 59s4m18h', 'DateTime.new(Instant) with time zone and formatter';
}

#?rakudo skip 'nom regression'
{
    my $i = dtpi 1988, 11, 22,   18, 42, 15.9;
    is $i.perl.eval, $i, 'Round-tripping Instant.perl';
}

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-temporal/DateTime.t�������������������������������������������������������0000664�0001750�0001750�00000061325�12224265625�020066� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 201;

my $orwell = DateTime.new(year => 1984);

sub dt(*%args) { DateTime.new(|{year => 1984, %args}) }
sub dtc(*%args) { $orwell.clone(|%args) }

sub ymd($year, $month, $day) { DateTime.new: :$year, :$month, :$day }
sub ymdc($year, $month, $day) { dtc :$year, :$month, :$day }

sub ds(Str $s) { DateTime.new($s) }

sub tz($tz) { ds "2005-02-04T15:25:00$tz" }

sub show-dt($dt) {
    join ' ', floor($dt.second), $dt.minute, $dt.hour,
        $dt.day, $dt.month, $dt.year, $dt.day-of-week
}

# An independent calculation to cross check the Temporal algorithms.
sub test-gmtime( Int $t is copy ) {
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday);
    $sec  = $t % 60; $t div= 60; # $t is now epoch minutes
    $min  = $t % 60; $t div= 60; # $t is now epoch hours
    $hour = $t % 24; $t div= 24; # $t is now epoch days
    # Not a sophisticated or fast algorithm, just an understandable one
    # only valid from 1970-01-01 until 2100-02-28
    $wday = ($t+3) % 7;  # 1970-01-01 was a Thursday
                         # Monday is $wday 0, unlike Perl 5.
    $year = 70; # (Unix epoch 0) == (Gregorian 1970) == (Perl year 70)
    loop ( $yday = 365; $t >= $yday; $year++ ) {
        $t -= $yday; # count off full years of 365 or 366 days
        $yday = (($year+1) % 4 == 0) ?? 366 !! 365;
    }
    $yday = $t;
    #         Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
    my @days = 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31;
    @days[1] = ($year % 4 == 0) ?? 29 !! 28;       # calibrate February
    loop ( $mon = 0; $t >= @days[$mon]; $mon++ ) {
        $t -= @days[$mon];   # count off full months of whatever days
    }
    $mday = $t + 1;
    return ($sec, $min, $hour, $mday, $mon + 1, $year + 1900, $wday + 1);
}        #   0     1      2      3       4          5             6 

# --------------------------------------------------------------------
# L<S32::Temporal/C<time>>
# --------------------------------------------------------------------

isa_ok time, Int, 'time returns an Int';

# --------------------------------------------------------------------
# L<S32::Temporal/C<DateTime>/immutable>
# --------------------------------------------------------------------

{
    my $dt = ymd 1999, 5, 6;
    dies_ok { $dt.year = 2000 }, 'DateTimes are immutable (1)';
    dies_ok { $dt.minute = 30 }, 'DateTimes are immutable (2)';
    dies_ok { $dt.timezone = 0 }, 'DateTimes are immutable (3)';
    dies_ok { $dt.formatter = { $dt.hour } }, 'DateTimes are immutable (4)';
}

# --------------------------------------------------------------------
# Input validation
# --------------------------------------------------------------------

dies_ok { DateTime.new }, 'Must provide arguments to DateTime';

# L<S32::Temporal/C<DateTime>/outside of the ranges specified>

lives_ok { dt month => 1 }, 'DateTime accepts January';
dies_ok  { dt month => 0 }, 'DateTime rejects month 0';
dies_ok  { dt month => -1 }, 'DateTime rejects month -1';
lives_ok { dt month => 12 }, 'DateTime accepts December';
dies_ok  { dt month => 13 }, 'DateTime rejects month 13';
lives_ok { dt month => 1, day => 31 }, 'DateTime accepts January 31';
dies_ok  { dt month => 1, day => 32 }, 'DateTime rejects January 32';
lives_ok { dt month => 6, day => 30 }, 'DateTime accepts June 30';
dies_ok  { dt month => 6, day => 31 }, 'DateTime rejects June 31';
dies_ok  { dt month => 2, day => 30 }, 'DateTime rejects February 30';
lives_ok { ymd 1996, 2, 29 }, 'DateTime accepts 29 Feb 1996';
dies_ok  { ymd 1995, 2, 29 }, 'DateTime rejects 29 Feb 1995';
lives_ok { ymd 2000, 2, 29 }, 'DateTime accepts 29 Feb 2000';
lives_ok { ymdc 2000, 2, 29 }, 'DateTime accepts 29 Feb 2000 (clone)';
lives_ok { ds '2000-02-29T22:33:44' }, 'DateTime accepts 29 Feb 2000 (ISO)';
dies_ok  { ymd 1900, 2, 29 }, 'DateTime rejects 29 Feb 1900';
dies_ok  { ymdc 1900, 2, 29 }, 'DateTime rejects 29 Feb 1900 (clone)';
dies_ok  { ds '1900-02-29T22:33:44' }, 'DateTime rejects 29 Feb 1900 (ISO)';
lives_ok { dt hour => 0 }, 'DateTime accepts hour 0';
dies_ok  { dt hour => -1 }, 'DateTime rejects hour 0';
lives_ok { dt hour => 23 }, 'DateTime accepts hour 23';
dies_ok  { dt hour => 24 }, 'DateTime rejects hour 24';
lives_ok { dt minute => 0 }, 'DateTime accepts minute 0';
dies_ok  { dt minute => -1 }, 'DateTime rejects minute -1';
lives_ok { dt minute => 59 }, 'DateTime accepts minute 59';
lives_ok { dtc minute => 59 }, 'DateTime accepts minute 59 (clone)';
lives_ok { ds '1999-01-01T00:59:22' }, 'DateTime accepts minute 59 (ISO)';
lives_ok { DateTime.new: date => Date.new(1999, 1, 1), minute => 59 }, 'DateTime accepts minute 59 (with Date)';
dies_ok  { dt minute => 60 }, 'DateTime rejects minute 60';
dies_ok  { dtc minute => 60 }, 'DateTime rejects minute 60 (clone)';
dies_ok  { ds '1999-01-01T00:60:22' }, 'DateTime rejects minute 60 (ISO)';
dies_ok  { dt date => Date.new(1999, 1, 1), minute => 60 }, 'DateTime rejects minute 60 (with Date)';
lives_ok { dt second => 0 }, 'DateTime accepts second 0';
lives_ok { dt second => 1/2 }, 'DateTime accepts second 1/2';
dies_ok  { dt second => -1 }, 'DateTime rejects second -1';
dies_ok  { dt second => -1/2 }, 'DateTime rejects second -1/2';
lives_ok { dt second => 59.5 }, 'DateTime accepts second 59.5';
lives_ok { dtc second => 59.5 }, 'DateTime accepts second 59.5 (clone)';
dies_ok  { dt second => 62 }, 'DateTime rejects second 62';
dies_ok  { dtc second => 62 }, 'DateTime rejects second 62 (clone)';
dies_ok  { ds '1999-01-01T12:10:62' }, 'DateTime rejects second 62 (ISO)';
dies_ok  { dt date => Date.new(1999, 1, 1), second => 62 }, 'DateTime rejects second 62 (with Date)';

# Validate leap seconds.

dies_ok  { ds '1999-01-01T12:10:60' }, 'Leap-second validation: Wrong time and date';
dies_ok  { ds '1999-01-01T23:59:60' }, 'Leap-second validation: Wrong date';
dies_ok  { ds '1999-06-30T23:59:60' }, 'Leap-second validation: Wrong year (1)';
dies_ok  { ds '1999-12-31T23:59:60' }, 'Leap-second validation: Wrong year (2)';
dies_ok  { ds '1998-06-30T23:59:60' }, 'Leap-second validation: Wrong; June 30 on a year with a leap second in December 31';
dies_ok  { ds '1998-12-31T23:58:60' }, 'Leap-second validation: Wrong minute';
dies_ok  { ds '1998-12-31T22:59:60' }, 'Leap-second validation: Wrong hour';
lives_ok { ds '1998-12-31T23:59:60' }, 'Leap-second validation: Okay; December 31';
dies_ok  { ds '1997-12-31T23:59:60' }, 'Leap-second validation: Wrong; December 31 on a year with a leap second in June 30';
dies_ok  { dt year => 1997, month => 12, day => 31,
              hour => 23, minute => 59, second => 60.9 }, 'Leap-second validation: Wrong; December 31 on a year with a leap second in June 30 (second 60.9)';
lives_ok { ds '1997-06-30T23:59:60' }, 'Leap-second validation: Okay; June 30';
lives_ok { dt year => 1997, month => 6, day => 30,
              hour => 23, minute => 59, second => 60.9 }, 'Leap-second validation: Okay; June 30 (second 60.9)';
dies_ok  { ds '1997-06-30T23:59:61' }, 'Leap-second validation: Wrong; there are no seconds 61 (in the 20th century, anyway).';

dies_ok  { ds '1998-12-31T23:59:60+0200' }, 'Leap-second validation: Wrong because of TZ; December 31';
lives_ok { ds '1999-01-01T01:59:60+0200' }, 'Leap-second validation: Okay because of TZ; January 1';
dies_ok  { ds '1997-06-30T23:59:60-0200' }, 'Leap-second validation: Wrong because of TZ; June 30';
lives_ok { ds '1997-06-30T21:59:60-0200' }, 'Leap-second validation: Okay because of TZ; June 30';
dies_ok  { dt year => 1998, month => 12, day => 31,
              hour => 23, minute => 59, second => 60.9,
              timezone => 2*60*60 }, 'Leap-second validation: Wrong because of TZ; December 31 (second 60.9)';
lives_ok { dt year => 1999, month => 1, day => 1,
              hour => 1, minute => 59, second => 60.9,
              timezone => 2*60*60 }, 'Leap-second validation: Okay because of TZ; January 1 (second 60.9)';

# --------------------------------------------------------------------
# DateTime.new(Int)
# --------------------------------------------------------------------

# L<S32::Temporal/C<DateTime>/DateTime.new(time)>

is show-dt(DateTime.new(0)), '0 0 0 1 1 1970 4', 'DateTime at beginning of Unix epoch';
is show-dt(DateTime.new(946684799)), '59 59 23 31 12 1999 5', 'from POSIX at 1999-12-31T23:59:59Z';
  # last second of previous millennium, FSVO 'millennium'.
is show-dt(DateTime.new(946684800)), '0 0 0 1 1 2000 6', 'from POSIX at 2000-01-01T00:00:00Z';
  # one second later, sing Auld Lang Syne.

# compare dates for a series of times earlier and later than "now", so
# that every test run will use different values
# and test round-tripping with .perl while we're at it
{
    my $t = time;
    my $t1 = $t;
    my $t2 = $t;
    # the offset changes all time components and causes overflow/underflow
    my $offset = ((((7*31+1)*24+10)*60+21)*60+21);
    for 1, 2, 3 {
        $t1 -= $offset;
        my $dt = DateTime.new($t1);
        is show-dt($dt), join(' ', test-gmtime $t1), "crosscheck $dt";
        is show-dt($dt), show-dt(eval $dt.perl), ".perl round-tripping with $dt";
        $t2 += $offset;
        $dt = DateTime.new($t2);
        is show-dt($dt), join(' ', test-gmtime $t2), "crosscheck $dt";
        is show-dt($dt), show-dt(eval $dt.perl), ".perl round-tripping with $dt";
    }
}

{
    my $dt = DateTime.new(946684799,
        timezone => -(5*60*60 + 55*60),
        formatter => { .day ~ '/' ~ .month ~ '/' ~ .year ~ ' ' ~
                       .second ~ 's' ~ .minute ~ 'm' ~ .hour ~ 'h' });
    is ~$dt, '31/12/1999 59s4m18h', 'DateTime.new(Int) with time zone and formatter';
}

# L<S32::Temporal/C<DateTime>/'Ambiguous POSIX times'>

is show-dt(DateTime.new(915148800)), '0 0 0 1 1 1999 5', 'from POSIX at 1999-01-01T00:00:00Z';
  # 915148800 is also the POSIX time of the leap second
  # 1998-12-31T23:59:60.
is show-dt(DateTime.new(425865600)), '0 0 0 1 7 1983 5', 'from POSIX at 1983-07-01T00:00:00Z';
  # 425865600 is also the POSIX time of the leap second
  # 1983-06-30T23:59:60.

# --------------------------------------------------------------------
# L<S32::Temporal/C<DateTime>/'A shorter way to send in date'>
# DateTime.new(Str)
# --------------------------------------------------------------------

is ds('2009-12-31T22:33:44Z'), '2009-12-31T22:33:44Z', 'round-tripping ISO 8601 (Z)';
is ds('2009-12-31T22:33:44+0000'), '2009-12-31T22:33:44Z', 'round-tripping ISO 8601 (+0000 to Z)';
is ds('2009-12-31T22:33:44+1100'), '2009-12-31T22:33:44+1100', 'round-tripping ISO 8601 (+1100)';
is ds('2009-12-31T22:33:44'), '2009-12-31T22:33:44Z', 'DateTime.new(Str) defaults to UTC';
is DateTime.new('2009-12-31T22:33:44',
        timezone => 12*60*60 + 34*60),
    '2009-12-31T22:33:44+1234', 'DateTime.new(Str) with :timezone';
is DateTime.new('2009-12-31T22:33:44',
        formatter => { ($^dt.hour % 12) ~ 'ish' } ),
    '10ish', 'DateTime.new(Str) with formatter';

# --------------------------------------------------------------------
# L<S32::Temporal/C<DateTime>/'truncated-to'>
# --------------------------------------------------------------------

{
    my $moon-landing = dt    # Although the seconds part is fictional.
       year => 1969, month => 7, day => 20,
       hour => 8, minute => 17, second => 32.4;
    my $dt = $moon-landing.truncated-to(second);
    is $dt.second, 32, 'DateTime.truncated-to(second)';
    $dt = $moon-landing.truncated-to(minute);
    is ~$dt, '1969-07-20T08:17:00Z', 'DateTime.truncated-to(minute)';
    $dt = $moon-landing.truncated-to(hour);
    is ~$dt, '1969-07-20T08:00:00Z', 'DateTime.truncated-to(hour)';
    $dt = $moon-landing.truncated-to(day);
    is ~$dt, '1969-07-20T00:00:00Z', 'DateTime.truncate-to(day)';
}

# --------------------------------------------------------------------
# L<S32::Temporal/C<DateTime>/'one additional constructor: now'>
# --------------------------------------------------------------------

{
    my $t = time;
    1 while time == $t; # loop until the next second
    $t = time;
    my $dt1 = DateTime.new($t);
    my $dt2 = DateTime.now.utc;        # $dt1 and $dt2 might differ very occasionally
    is show-dt($dt1), show-dt($dt2), 'DateTime.now uses current time';

    $t = time;
    1 while time == $t;
    $t = time;
    $dt1 = DateTime.new($t);
    $dt2 = DateTime.now(
        timezone => 22*60*60,
        formatter => { ~($^x.hour) });
    is ~$dt2, ~(($dt1.hour + 22) % 24), 'DateTime.now with time zone and formatter';
}

# --------------------------------------------------------------------
# L<S32::Temporal/Accessors/'the method posix'>
# --------------------------------------------------------------------

{
    is dt(year => 1970).posix, 0, 'DateTime.posix (1970-01-01T00:00:00Z)';
    my $dt = dt
        year => 1970, month  => 1, day => 1,
        hour =>    1, minute => 1, second => 1;
    is $dt.posix, 3661, 'DateTime.posix (1970-01-01T01:01:01Z)';
    $dt = dt
        year => 1970, month  => 1, day => 1,
        hour =>    1, minute => 1, second => 1,
        timezone => -1*60*60 -1*60;
    is $dt.posix, 7321, 'DateTime.posix (1970-01-01T01:01:01-0101)';
    # round-trip test for the current time
    my $t = time;
    my @t = test-gmtime $t;
    $dt = dt
        year => @t[5], month => @t[4], day => @t[3],
        hour => @t[2], minute => @t[1], second => @t[0];
    is $dt.posix, $t, "at $dt, POSIX is {$dt.posix}";
}

# --------------------------------------------------------------------
# L<S32::Temporal/Accessors/'The method whole-second'>
# --------------------------------------------------------------------

is dt(second => 22).whole-second, 22, 'DateTime.whole-second (22)';
is dt(second => 22.1).whole-second, 22, 'DateTime.whole-second (22.1)';
is dt(second => 15.9).whole-second, 15, 'DateTime.whole-second (15.9)';
is dt(second => 0).whole-second, 0, 'DateTime.whole-second (0)';
is dt(second => 0.9).whole-second, 0, 'DateTime.whole-second (0.9)';
is ds('1997-06-30T23:59:60Z').whole-second, 60, 'DateTime.whole-second (60)';

{
    my $dt = dt year => 1997, month => 6, day => 30,
                hour => 23, minute => 59, second => 60.5;
    is $dt.whole-second, 60, 'DateTime.whole-second (60.5)';
}

# --------------------------------------------------------------------
# L<S32::Temporal/Accessors/'The Date method'>
# --------------------------------------------------------------------

{
    my $dt = ymd 2010, 6, 4;
    my $date;
    lives_ok { $date = $dt.Date(); }, 'DateTime.Date';
    isa_ok $date, Date, 'Date object is correct class';
    is $date.year, 2010, 'Date year';
    is $date.month, 6, 'Date month';
    is $date.day, 4, 'Date day';
}

# --------------------------------------------------------------------
# L<S32::Temporal/Accessors/'The method offset'>
# --------------------------------------------------------------------

is tz(    'Z').offset,      0, 'DateTime.offset (Z)';
is tz('+0000').offset,      0, 'DateTime.offset (+0000)';
is tz('-0000').offset,      0, 'DateTime.offset (-0000)';
is tz('+0015').offset,    900, 'DateTime.offset (+0015)';
is tz('-0015').offset,   -900, 'DateTime.offset (-0015)';
is tz('+0700').offset,  25200, 'DateTime.offset (+0700)';
is tz('-0700').offset, -25200, 'DateTime.offset (-0700)';
is tz('+1433').offset,  52380, 'DateTime.offset (+1433)';
is tz('-1433').offset, -52380, 'DateTime.offset (-1433)';
is dt(timezone => 3661).offset, 3661, 'DateTime.offset (1 hour, 1 minute, 1 second)';

# --------------------------------------------------------------------
# L<S32::Temporal/C<DateTime>/in-timezone>
# --------------------------------------------------------------------

{
    sub with-tz($dt, $hours, $minutes=0, $seconds=0) {
        $dt.in-timezone($hours*60*60 + $minutes*60 + $seconds);
    }
    sub hms($dt) {
        $dt.hour ~ ',' ~ $dt.minute ~ ',' ~ $dt.second
    }

    my $dt = with-tz(tz('+0200'), 4);
    is ~$dt, '2005-02-04T17:25:00+0400', 'DateTime.in-timezone (adding hours)';
    $dt = with-tz(tz('+0000'), -1);
    is ~$dt, '2005-02-04T14:25:00-0100', 'DateTime.in-timezone (subtracting hours)';
    $dt = with-tz(tz('-0100'), 0);
    is ~$dt, '2005-02-04T16:25:00Z', 'DateTime.in-timezone (-0100 to UTC)';
    $dt = tz('-0100').utc;
    is ~$dt, '2005-02-04T16:25:00Z', 'DateTime.utc (from -0100)';
    $dt = with-tz(tz('+0100'), -1);
    is ~$dt, '2005-02-04T13:25:00-0100', 'DateTime.in-timezone (+ hours to - hours)';
    $dt = with-tz(tz('-0200'), -5);
    is ~$dt, '2005-02-04T12:25:00-0500', 'DateTime.in-timezone (decreasing negative hours)';
    $dt = with-tz(tz('+0000'), 0, -13);
    is ~$dt, '2005-02-04T15:12:00-0013', 'DateTime.in-timezone (negative minutes)';
    $dt = with-tz(tz('+0000'), 0, 0, -5);
    is hms($dt), '15,24,55', 'DateTime.in-timezone (negative seconds)';
    $dt = with-tz(tz('+0000'), 0, -27);
    is ~$dt, '2005-02-04T14:58:00-0027', 'DateTime.in-timezone (hour rollover 1)';
    $dt = with-tz(tz('+0000'), 0, 44);
    is ~$dt, '2005-02-04T16:09:00+0044', 'DateTime.in-timezone (hour rollover 2)';
    $dt = with-tz(tz('+0311'), -2, -27);
    is ~$dt, '2005-02-04T09:47:00-0227', 'DateTime.in-timezone (hours and minutes)';
    $dt = with-tz(tz('+0311'), -2, -27, -19);
    is hms($dt), '9,46,41', 'DateTime.in-timezone (hours, minutes, and seconds)';
    $dt = with-tz(tz('+0000'), -18, -55);
    is ~$dt, '2005-02-03T20:30:00-1855', 'DateTime.in-timezone (one-day rollover)';
    $dt = with-tz(tz('-1611'), 16, 55);
    is ~$dt, '2005-02-06T00:31:00+1655', 'DateTime.in-timezone (two-day rollover)';
    $dt = with-tz(ds('2005-01-01T02:22:00+0300'), 0, 35);
    is ~$dt, '2004-12-31T23:57:00+0035', 'DateTime.in-timezone (year rollover)';

    $dt = with-tz(dt(second => 15.5), 0, 0, 5);
    #?rakudo todo 'nom regression'
    is $dt.second, 20.5, 'DateTime.in-timezone (fractional seconds)';

    $dt = dt(year => 2005, month => 1, day => 3,
             hour => 2, minute => 22, second => 4,
             timezone => 13).in-timezone(-529402);
      # A difference from UTC of 6 days, 3 hours, 3 minutes, and
      # 22 seconds.
    is show-dt($dt), '29 18 23 27 12 2004 1', 'DateTime.in-timezone (big rollover)';    

}

# --------------------------------------------------------------------
# Miscellany
# --------------------------------------------------------------------

# RT #77910
# Ensure that any method of producing a DateTime keeps attributes
# that should be Ints Ints.
{
    isa_ok dt(second => 1/3).year, Int, 'DateTime.new(...).year isa Int';
    isa_ok dt(second => 1/3).hour, Int, 'DateTime.new(...).hour isa Int';
    isa_ok dt(hour => 13, second => 1/3).hour, Int, 'DateTime.new(..., hour => 13).hour isa Int';
    isa_ok dtc(second => 1/3).year, Int, '$dt.clone(...).year isa Int';
    isa_ok dtc(second => 1/3).hour, Int, '$dt.clone(...).hour isa Int';
    isa_ok dtc(hour => 13, second => 1/3).hour, Int, '$dt.clone(..., hour => 13).hour isa Int';
    isa_ok DateTime.new(5).year, Int, 'DateTime.new(Int).year isa Int';
    isa_ok DateTime.new(5).hour, Int, 'DateTime.new(Int).hour isa Int';
    isa_ok DateTime.new(now).year, Int, 'DateTime.new(Instant).year isa Int';
    isa_ok DateTime.new(now).hour, Int, 'DateTime.new(Instant).hour isa Int';
    isa_ok ds('2005-02-04T15:25:00Z').year, Int, 'ds(Str).year isa Int';
    isa_ok ds('2005-02-04T15:25:00Z').hour, Int, 'ds(Str).hour isa Int';
    isa_ok dt.in-timezone(60*60).year, Int, 'dt.in-timezone(Int).year isa Int';
    isa_ok dt.in-timezone(60*60).hour, Int, 'dt.in-timezone(Int).hour isa Int';
    isa_ok dt.truncated-to(week).year, Int, 'dt.truncated-to(week).year isa Int';
    isa_ok dt.truncated-to(week).hour, Int, 'dt.truncated-to(week).hour isa Int';
    isa_ok DateTime.now.year, Int, 'DateTime.now.year isa Int';
    isa_ok DateTime.now.hour, Int, 'DateTime.now.hour isa Int';
}

is DateTime.now.Date, Date.today, 'coercion to Date';

{
    is ds('2013-12-23T12:34:36Z').delta(1, second),
       ds('2013-12-23T12:34:37Z'),
       'adding 1 second';

    is ds('2013-12-23T12:34:36Z').delta(10, seconds),
       ds('2013-12-23T12:34:46Z'),
       'adding 10 seconds';

    is ds('2013-12-23T12:34:56Z').delta(14, seconds),
       ds('2013-12-23T12:35:10Z'),
       'adding 14 seconds, overflowing to minutes';

    is ds('2013-12-23T12:59:56Z').delta(74, seconds),
       ds('2013-12-23T13:01:10Z'),
       'adding 74 seconds, overflowing to hours';

    is ds('2013-12-23T23:59:59Z').delta(1, second),
       ds('2013-12-24T00:00:00Z'),
       'adding 1 second, overflowing to days';

    is ds('2013-12-31T23:59:59Z').delta(1, second),
       ds('2014-01-01T00:00:00Z'),
       'adding 1 second, overflowing to years';

    is ds('2012-06-30T23:59:59Z').delta(1, second),
       ds('2012-06-30T23:59:60Z'),
       'delting to a leap second';

    is ds('2008-12-31T23:59:60Z').delta(1, second),
       ds('2009-01-01T00:00:00Z'),
       'delting from a leap second';

    is ds('2013-12-23T12:34:36Z').delta(1, minute),
       ds('2013-12-23T12:35:36Z'),
       'adding 1 minute';

    is ds('2013-12-23T12:34:36Z').delta(10, minutes),
       ds('2013-12-23T12:44:36Z'),
       'adding 10 minutes';

    is ds('2013-12-23T12:56:34Z').delta(14, minutes),
       ds('2013-12-23T13:10:34Z'),
       'adding 14 minutes, overflowing to hours';

    is ds('2013-12-23T12:34:36Z').delta(1, hour),
       ds('2013-12-23T13:34:36Z'),
       'adding 1 hour';

    is ds('2013-12-23T12:34:36Z').delta(10, hours),
       ds('2013-12-23T22:34:36Z'),
       'adding 10 hours';

    is ds('2013-12-23T12:56:34Z').delta(14, hours),
       ds('2013-12-24T02:56:34Z'),
       'adding 14 horus, overflowing to days';

    is ds('2013-12-23T12:34:36Z').delta(1, day),
       ds('2013-12-24T12:34:36Z'),
       'adding 1 day';

    is ds('2014-01-31T12:34:36Z').delta(1, day),
       ds('2014-02-01T12:34:36Z'),
       'adding 1 day, overflowing to February';

    is ds('2014-02-28T12:56:34Z').delta(2, days),
       ds('2014-03-02T12:56:34Z'),
       'adding 2 days, overflowing to March';

    is ds('2008-12-31T23:59:60Z').delta(1, day),
       ds('2009-01-02T00:00:00Z'),
       'adding a day to a leap second';

    is ds('1972-12-31T23:59:60Z').delta(1, year),
       ds('1973-12-31T23:59:60Z'),
       'adding a year to a leap second, landing on another leap second';

    is ds('2013-12-23T12:34:36Z').delta(1, week),
       ds('2013-12-30T12:34:36Z'),
       'adding 1 week';

    is ds('2014-01-31T12:34:36Z').delta(1, week),
       ds('2014-02-07T12:34:36Z'),
       'adding 1 week, overflowing to February';

    is ds('2014-02-28T12:56:34Z').delta(2, weeks),
       ds('2014-03-14T12:56:34Z'),
       'adding 2 weeks, overflowing to March';

    is ds('2014-12-30T12:56:34Z').delta(3, weeks),
       ds('2015-01-20T12:56:34Z'),
       'adding 3 weeks, overflowing to years';

    is ds('2013-12-23T12:34:37Z').delta(-1, second),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 1 second';

    is ds('2013-12-23T12:34:46Z').delta(-10, seconds),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 10 seconds';

    is ds('2013-12-23T12:35:10Z').delta(-14, seconds),
       ds('2013-12-23T12:34:56Z'),
       'subtracting 14 seconds, overflowing to minutes';

    is ds('2013-12-23T13:01:10Z').delta(-74, seconds),
       ds('2013-12-23T12:59:56Z'),
       'subtracting 74 seconds, overflowing to hours';

    is ds('2013-12-24T00:00:00Z').delta(-1, second),
       ds('2013-12-23T23:59:59Z'),
       'subtracting 1 second, overflowing to days';

    is ds('2014-01-01T00:00:00Z').delta(-1, second),
       ds('2013-12-31T23:59:59Z'),
       'subtracting 1 second, overflowing to years';

    is ds('2013-12-23T12:35:36Z').delta(-1, minute),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 1 minute';

    is ds('2013-12-23T12:44:36Z').delta(-10, minutes),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 10 minutes';

    is ds('2013-12-23T13:10:34Z').delta(-14, minutes),
       ds('2013-12-23T12:56:34Z'),
       'subtracting 14 minutes, overflowing to hours';

    is ds('2013-12-23T13:34:36Z').delta(-1, hour),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 1 hour';

    is ds('2013-12-23T22:34:36Z').delta(-10, hours),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 10 hours';

    is ds('2013-12-24T02:56:34Z').delta(-14, hours),
       ds('2013-12-23T12:56:34Z'),
       'subtracting 14 horus, overflowing to days';

    is ds('2013-12-24T12:34:36Z').delta(-1, day),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 1 day';

    is ds('2014-02-01T12:34:36Z').delta(-1, day),
       ds('2014-01-31T12:34:36Z'),
       'subtracting 1 day, overflowing to February';

    is ds('2014-03-02T12:56:34Z').delta(-2, days),
       ds('2014-02-28T12:56:34Z'),
       'subtracting 2 days, overflowing to March';

    is ds('2013-12-30T12:34:36Z').delta(-1, week),
       ds('2013-12-23T12:34:36Z'),
       'subtracting 1 week';

    is ds('2014-02-07T12:34:36Z').delta(-1, week),
       ds('2014-01-31T12:34:36Z'),
       'subtracting 1 week, overflowing to February';

    is ds('2014-03-14T12:56:34Z').delta(-2, weeks),
       ds('2014-02-28T12:56:34Z'),
       'subtracting 2 weeks, overflowing to March';

    is ds('2015-01-20T12:56:34Z').delta(-3, weeks),
       ds('2014-12-30T12:56:34Z'),
       'subtracting 3 weeks, overflowing to years';
}

done;
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-temporal/local.t����������������������������������������������������������0000664�0001750�0001750�00000007533�12224265625�017465� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Temporal/C<DateTime>/'local time zone'>

plan 25;

sub ds(Str $s) { DateTime.new: $s }

ok $*TZ.defined, '$*TZ is defined';
is DateTime.now.timezone, $*TZ, 'DateTime.now uses $*TZ';
is DateTime.new(year => 1995).local.timezone, $*TZ, 'DateTime.local uses $*TZ';

my $dt = ds('2003-08-01T02:22:00Z').local.utc;
is ~$dt, '2003-08-01T02:22:00Z', 'UTC -> local -> UTC (2003-08-01T02:22:00Z)';
$dt = ds('1984-02-29T05:55:22Z').local.utc;
is ~$dt, '1984-02-29T05:55:22Z', 'UTC -> local -> UTC (1984-02-29T05:55:22Z)';
$dt = ds('1998-12-31T23:59:60Z').local.utc;
is ~$dt, '1998-12-31T23:59:60Z', 'UTC -> local -> UTC (1998-12-31T23:59:60Z)';

unless '/etc/timezone'.IO ~~ :e and
       slurp('/etc/timezone') eq "America/New_York\n" {
    skip_rest "The local time zone may not be America/New_York.";
    exit;
}

# So that we can test .local and $*TZ more thoroughly, the
# following tests assume a specific local time zone. I picked
# America/New_York because it's sufficiently complex (it observes
# DST according to rules that have changed since the year 2000)
# and it happens to be my own time zone at the moment. —Kodi
#
# A useful reference:
# http://en.wikipedia.org/wiki/History_of_time_in_the_United_States#Start_and_end_dates_of_United_States_Daylight_Time

sub nyc-dt($year, $month, $day, $hour, $minute, $second = 0) {
    DateTime.new: :$year, :$month, :$day, :$hour, :$minute, :$second,
        timezone => $*TZ;
}

# UTC → local

$dt = ds('2007-01-02T02:22:00Z').in-timezone($*TZ);
is ~$dt, '2007-01-01T21:22:00-0500', 'DateTime.in-timezone($*TZ) (from UTC, outside of DST)';

$dt = ds('2007-01-02T02:22:00Z').local;
is ~$dt, '2007-01-01T21:22:00-0500', 'DateTime.local (from UTC, outside of DST)';
$dt = ds('2003-08-01T02:22:00Z').local;
is ~$dt, '2003-07-31T22:22:00-0400', 'DateTime.local (from UTC, during DST)';
$dt = ds('1984-04-29T06:55:00Z').local;
is ~$dt, '1984-04-29T01:55:00-0500', 'DateTime.local (from UTC, just before DST begins)';
$dt = ds('1984-04-29T07:02:00Z').local;
is ~$dt, '1984-04-29T03:02:00-0400', 'DateTime.local (from UTC, just after DST begins)';
$dt = ds('2008-11-02T05:55:00Z').local;
is ~$dt, '2008-11-02T01:55:00-0400', 'DateTime.local (from UTC, just before DST ends)';
is ~eval($dt.perl), '2008-11-02T01:55:00-0400', 'DateTime.local (from UTC, just before DST ends, .perl)';
$dt = ds('2008-11-02T06:55:00Z').local;
is ~$dt, '2008-11-02T01:55:00-0500', 'DateTime.local (from UTC, just after DST ends)';
is ~eval($dt.perl), '2008-11-02T01:55:00-0500', 'DateTime.local (from UTC, just after DST ends, .perl)';
$dt = ds('2008-11-02T08:58:00+0303').local;
is ~$dt, '2008-11-02T01:55:00-0400', 'DateTime.local (from +0303, just before DST ends)';
$dt = ds('2008-11-01T14:43:00-1612').local;
is ~$dt, '2008-11-02T01:55:00-0500', 'DateTime.local (from -1612, just after DST ends)';

# Local → UTC

$dt = nyc-dt(1995,  1, 1, 21, 22).utc;
is ~$dt, '1995-01-02T02:22:00Z', 'DateTime.utc (from local, outside of DST)';
$dt = nyc-dt(1998,  7, 31, 22, 22).utc;
is ~$dt, '1998-08-01T02:22:00Z', 'DateTime.utc (from local, during DST)';
$dt = nyc-dt(2007,  3, 11, 1, 55).utc;
is ~$dt, '2007-03-11T06:55:00Z', 'DateTime.utc (from local, just before DST starts)';
$dt = nyc-dt(2007,  3, 11, 3, 2).in-timezone: 60 * (60 * -16 - 12);
is ~$dt, '2007-03-10T14:50:00-1612', 'DateTime.in-timezone (local to -1612, just after DST starts)';
$dt = nyc-dt(1989, 10, 29, 1, 55).utc;
ok $dt eq '1989-10-29T05:55:00Z'|'1989-10-29T06:55:00Z', 'DateTime.utc (from local, ambiguous)';

# Throw leap seconds into the mix

$dt = nyc-dt(1997, 6, 30,   19, 59, 60).utc;
ok $dt eq '1997-06-30T23:59:60Z', 'DateTime.utc (from local, with leap second)';
dies_ok { nyc-dt 1997, 6, 30,   23, 59, 60 }, 'Local time zone rejects bogus leap second';
$dt = ds('1998-12-31T23:59:60Z').local;
is ~$dt, '1998-12-31T18:59:60-0500', 'DateTime.local (from UTC, with leap second)';

done;

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-temporal/time.t�����������������������������������������������������������0000664�0001750�0001750�00000011050�12224265625�017316� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

# L<S32::Temporal/C<time>>

# Based Heavily on the t/op/time.t test from Perl5.8.6
# Perhaps the testing of these builtins needs to be more rigorous
# mattc 20050316

plan 10;

#-- subs --

# Sub for evaulation valid date-time strings
# Used in place of Rules for the moment
sub is_dt (Str $datetime) returns Bool {

    my ($dow, $mon, $day, $time, $year) = split(' ', $datetime);
    my $result = 0;

    for < Sun Mon Tue Wed Thu Fri Sat > {
        if $dow eq $_ {
            $result++;
            last();
        }
    }

    for < Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec > {
        if  $mon eq $_ {
            $result++;
            last();
        }
    }

    if $day >= 1 && $day <= 31 {
        $result++;
    }

    my ($hour, $min, $sec) = split(':',$time);

    if $hour >= 0 && $hour <= 23 &&
       $min  >= 0 && $min  <= 59 &&
       $sec  >= 0 && $sec  <= 59 {
        $result++;
    }

    if $year >= 0 && $year <= 9999 {
        $result++;
    }

    return ($result == 5);
}

# Before we get started, sanity check the is_dt sub

#-- 1 --

my $gen_dt      = "Tue Mar 15 14:43:10 2005";
my $hibound_dt     = "Mon Jan 31 23:59:59 9999";
my $lowbound_dt = "Mon Jan 1 00:00:00 0";

ok(is_dt($gen_dt) &&
   is_dt($hibound_dt) &&
   is_dt($lowbound_dt) ,
   'test datetime string tester, pos cases');

#-- 2 --

my $fail_dt_1   = "Mun Mar 15 14:43:10 2005";
my $fail_dt_2   = "Mon Mxr 15 14:43:10 2005";
my $fail_dt_3   = "Mon Mar 32 14:43:10 2005";
my $fail_dt_4   = "Mon Mar 15 24:43:10 2005";
my $fail_dt_5   = "Mon Mar 15 14:60:10 2005";
my $fail_dt_6   = "Mon Mar 15 14:43:60 2005";
my $fail_dt_7   = "Mon Mar 15 14:43:10 10000";

ok(!is_dt($fail_dt_1) &&
   !is_dt($fail_dt_2) &&
   !is_dt($fail_dt_3) &&
   !is_dt($fail_dt_4) &&
   !is_dt($fail_dt_5) &&
   !is_dt($fail_dt_6) &&
   !is_dt($fail_dt_7) ,
   'test datetime string tester, neg cases');

#-- Real Tests Start --

#-- 3 --

my $beg = time;
my $now;

# Loop until $beg in the past
while (($now = time) == $beg) { sleep 1 }

ok($now > $beg && $now - $beg < 10, 'very basic time test');
ok time + 10, "'time()' may drop its parentheses";

#-- 4 --
{
    my ($beguser,$begsys);
    my ($nowuser,$nowsys);

    ($beguser,$begsys) = times;
    my $i;
    loop ($i = 0; $i < 100000; $i++) {
        ($nowuser, $nowsys) = times;
        $i = 200000 if $nowuser > $beguser && ( $nowsys >= $begsys || (!$nowsys && !$begsys));
        $now = time;
        last() if ($now - $beg > 20);
    }
    ok($i >= 200000, 'very basic times test');
}

#-- 5 --
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);
my ($xsec,$foo);

($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
($xsec,$foo) = localtime($now);

my $localyday = $yday;

#?pugs todo 'bug'
flunk("FIXME Time::Local should by numifiable");
## ?pugs: todo '?'
#ok($sec != $xsec && $mday && $year, 'localtime() list context');

#-- 6 --

#?pugs todo 'bug'
ok(is_dt({ my $str = localtime() }()), 'localtime(), scalar context');

# Ultimate implementation as of above test as Rule
#todo_ok(localtime() ~~ /^Sun|Mon|Tue|Wed|Thu|Fri|Sat\s
#                            Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec\s
#                            \d\d\s\d\d:\d\d:\d\d\s\d**{4}$
#                        /,
#                 'localtime(), scalar context');

#-- 7 --

{
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);
    my ($xsec,$foo);

    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = try { gmtime($beg) };
    ($xsec,$foo) = localtime($now);

    #?pugs todo 'bug'
    flunk("FIXME Time::Local should by numifiable");
    ## ?pugs: todo
    #ok($sec != $xsec && $mday && $year, 'gmtime() list context');

    #-- 8 --

    if ($localyday && $yday) {
        my $day_diff = $localyday - $yday;
        ok($day_diff == 0    ||
            $day_diff == 1    ||
            $day_diff == -1   ||
            $day_diff == 364  ||
            $day_diff == 365  ||
            $day_diff == -364 ||
            $day_diff == -365,
            'gmtime() and localtime() agree what day of year');
    } else {
        #?pugs todo
        ok(0, 'gmtime() and localtime() agree what day of year');
    }

    #-- 9 --

    #?pugs todo
    ok(is_dt({ my $str = try { gmtime() } }()), 'gmtime(), scalar context');

    # Ultimate implementation as of above test as Rule
    #todo_ok(gmtime() ~~ /^Sun|Mon|Tue|Wed|Thu|Fri|Sat\s
    #                      Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec\s
    #                      \d\d\s\d\d:\d\d:\d\d\s\d**{4}$
    #                    /,
    #            'gmtime(), scalar context');
}

# vim: ft=perl6
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/atan2.t��������������������������������������������������������������0000664�0001750�0001750�00000025612�12224265625�016520� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# atan2 tests

# First, test atan2 with x = 1

for @sines -> $angle
{
    next if abs(cos($angle.key())) < 1e-6;     
	my $desired-result = sin($angle.key()) / cos($angle.key());

    # Num.atan2 tests
    is_approx($desired-result.Num.atan2.tan, $desired-result, 
              "Num.atan2() - {$angle.key()}");
    is_approx($desired-result.Num.atan2(1.Num).tan, $desired-result, 
              "Num.atan2(1.Num) - {$angle.key()}");
}

# check that the proper quadrant is returned

is_approx(atan2(4, 4), pi / 4, "atan2(4, 4) is pi / 4");
is_approx(atan2(-4, 4), -pi / 4, "atan2(-4, 4) is -pi / 4");
is_approx(atan2(4, -4), 3 * pi / 4, "atan2(4, -4) is 3pi / 4");
is_approx(atan2(-4, -4), -3 * pi / 4, "atan2(-4, -4) is -3pi / 4");

{
    # Num tests
    is_approx(atan2((-0.1).Num), -0.099668652491162, "atan2(Num)");
}

{
    # Num vs Num tests
    is_approx((-100).Num.atan2((100).Num), -0.785398163397448, "Num.atan2(Num)");
    is_approx(atan2((0.1).Num, (-0.1).Num), 2.35619449019234, "atan2(Num, Num)");
}

{
    # Num vs Rat tests
    is_approx((10).Num.atan2((-10).Rat(1e-9)), 2.35619449019234, "Num.atan2(Rat)");
    is_approx(atan2((-100).Num, (-100).Rat(1e-9)), -2.35619449019234, "atan2(Num, Rat)");
}

{
    # Num vs Int tests
    is_approx((-0.1).Num.atan2((1).Int), -0.099668652491162, "Num.atan2(Int)");
    is_approx(atan2((-10).Num, (-1).Int), -1.67046497928606, "atan2(Num, Int)");
}

{
    # Num vs Str tests
    is_approx((-1).Num.atan2((0.1).Str), -1.47112767430373, "Num.atan2(Str)");
    is_approx(atan2((10).Num, (-0.1).Str), 1.58079599348156, "atan2(Num, Str)");
}

{
    # Num vs DifferentReal tests
    is_approx((-1).Num.atan2(DifferentReal.new(-10)), -3.04192400109863, "Num.atan2(DifferentReal)");
    is_approx(atan2((100).Num, DifferentReal.new(-100)), 2.35619449019234, "atan2(Num, DifferentReal)");
}

{
    # Num vs FatRat tests
    is_approx((-100).Num.atan2((10).FatRat), -1.47112767430373, "Num.atan2(FatRat)");
    is_approx(atan2((0.1).Num, (-1).FatRat), 3.04192400109863, "atan2(Num, FatRat)");
}

{
    # Rat tests
    is_approx((10).Rat(1e-9).atan2, 1.47112767430373, "Rat.atan2");
    is_approx(atan2((1).Rat(1e-9)), 0.785398163397448, "atan2(Rat)");
}

{
    # Rat vs Num tests
    is_approx((-0.1).Rat(1e-9).atan2((0.1).Num), -0.785398163397448, "Rat.atan2(Num)");
    is_approx(atan2((0.1).Rat(1e-9), (-1).Num), 3.04192400109863, "atan2(Rat, Num)");
}

{
    # Rat vs Rat tests
    is_approx((-0.1).Rat(1e-9).atan2((-0.1).Rat(1e-9)), -2.35619449019234, "Rat.atan2(Rat)");
    is_approx(atan2((10).Rat(1e-9), (-10).Rat(1e-9)), 2.35619449019234, "atan2(Rat, Rat)");
}

{
    # Rat vs Int tests
    is_approx((-0.1).Rat(1e-9).atan2((1).Int), -0.099668652491162, "Rat.atan2(Int)");
    is_approx(atan2((100).Rat(1e-9), (100).Int), 0.785398163397448, "atan2(Rat, Int)");
}

{
    # Rat vs Str tests
    is_approx((0.1).Rat(1e-9).atan2((0.1).Str), 0.785398163397448, "Rat.atan2(Str)");
    is_approx(atan2((1).Rat(1e-9), (-10).Str), 3.04192400109863, "atan2(Rat, Str)");
}

{
    # Rat vs DifferentReal tests
    is_approx((-100).Rat(1e-9).atan2(DifferentReal.new(1)), -1.56079666010823, "Rat.atan2(DifferentReal)");
    is_approx(atan2((0.1).Rat(1e-9), DifferentReal.new(1)), 0.099668652491162, "atan2(Rat, DifferentReal)");
}

{
    # Rat vs FatRat tests
    is_approx((-0.1).Rat(1e-9).atan2((1).FatRat), -0.099668652491162, "Rat.atan2(FatRat)");
    is_approx(atan2((-10).Rat(1e-9), (-100).FatRat), -3.04192400109863, "atan2(Rat, FatRat)");
}

{
    # Int tests
    is_approx((-10).Int.atan2, -1.47112767430373, "Int.atan2");
    is_approx(atan2((1).Int), 0.785398163397448, "atan2(Int)");
}

{
    # Int vs Num tests
    is_approx((-1).Int.atan2((100).Num), -0.00999966668666524, "Int.atan2(Num)");
    is_approx(atan2((-100).Int, (100).Num), -0.785398163397448, "atan2(Int, Num)");
}

{
    # Int vs Rat tests
    is_approx((10).Int.atan2((-10).Rat(1e-9)), 2.35619449019234, "Int.atan2(Rat)");
    is_approx(atan2((-10).Int, (100).Rat(1e-9)), -0.099668652491162, "atan2(Int, Rat)");
}

{
    # Int vs Int tests
    is_approx((-100).Int.atan2((1).Int), -1.56079666010823, "Int.atan2(Int)");
    is_approx(atan2((-1).Int, (-100).Int), -3.13159298690313, "atan2(Int, Int)");
}

{
    # Int vs Str tests
    is_approx((-1).Int.atan2((1).Str), -0.785398163397448, "Int.atan2(Str)");
    is_approx(atan2((-1).Int, (-0.1).Str), -1.67046497928606, "atan2(Int, Str)");
}

{
    # Int vs DifferentReal tests
    is_approx((1).Int.atan2(DifferentReal.new(-0.1)), 1.67046497928606, "Int.atan2(DifferentReal)");
    is_approx(atan2((1).Int, DifferentReal.new(10)), 0.099668652491162, "atan2(Int, DifferentReal)");
}

{
    # Int vs FatRat tests
    is_approx((-1).Int.atan2((-100).FatRat), -3.13159298690313, "Int.atan2(FatRat)");
    is_approx(atan2((-1).Int, (-0.1).FatRat), -1.67046497928606, "atan2(Int, FatRat)");
}

{
    # Str tests
    is_approx((1).Str.atan2, 0.785398163397448, "Str.atan2");
    is_approx(atan2((-1).Str), -0.785398163397448, "atan2(Str)");
}

{
    # Str vs Num tests
    is_approx((-10).Str.atan2((10).Num), -0.785398163397448, "Str.atan2(Num)");
    is_approx(atan2((0.1).Str, (1).Num), 0.099668652491162, "atan2(Str, Num)");
}

{
    # Str vs Rat tests
    is_approx((100).Str.atan2((-10).Rat(1e-9)), 1.67046497928606, "Str.atan2(Rat)");
    is_approx(atan2((0.1).Str, (-10).Rat(1e-9)), 3.13159298690313, "atan2(Str, Rat)");
}

{
    # Str vs Int tests
    is_approx((-100).Str.atan2((-100).Int), -2.35619449019234, "Str.atan2(Int)");
    is_approx(atan2((0.1).Str, (-10).Int), 3.13159298690313, "atan2(Str, Int)");
}

{
    # Str vs Str tests
    is_approx((-1).Str.atan2((0.1).Str), -1.47112767430373, "Str.atan2(Str)");
    is_approx(atan2((-10).Str, (1).Str), -1.47112767430373, "atan2(Str, Str)");
}

{
    # Str vs DifferentReal tests
    is_approx((-0.1).Str.atan2(DifferentReal.new(100)), -0.000999999666666867, "Str.atan2(DifferentReal)");
    is_approx(atan2((0.1).Str, DifferentReal.new(1)), 0.099668652491162, "atan2(Str, DifferentReal)");
}

{
    # Str vs FatRat tests
    is_approx((10).Str.atan2((-100).FatRat), 3.04192400109863, "Str.atan2(FatRat)");
    is_approx(atan2((1).Str, (-10).FatRat), 3.04192400109863, "atan2(Str, FatRat)");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(0.1).atan2, 0.099668652491162, "DifferentReal.atan2");
    is_approx(atan2(DifferentReal.new(0.1)), 0.099668652491162, "atan2(DifferentReal)");
}

{
    # DifferentReal vs Num tests
    is_approx(DifferentReal.new(-10).atan2((10).Num), -0.785398163397448, "DifferentReal.atan2(Num)");
    is_approx(atan2(DifferentReal.new(-100), (-1).Num), -1.58079599348156, "atan2(DifferentReal, Num)");
}

{
    # DifferentReal vs Rat tests
    is_approx(DifferentReal.new(1).atan2((10).Rat(1e-9)), 0.099668652491162, "DifferentReal.atan2(Rat)");
    is_approx(atan2(DifferentReal.new(-10), (-100).Rat(1e-9)), -3.04192400109863, "atan2(DifferentReal, Rat)");
}

{
    # DifferentReal vs Int tests
    is_approx(DifferentReal.new(10).atan2((-10).Int), 2.35619449019234, "DifferentReal.atan2(Int)");
    is_approx(atan2(DifferentReal.new(100), (-1).Int), 1.58079599348156, "atan2(DifferentReal, Int)");
}

{
    # DifferentReal vs Str tests
    is_approx(DifferentReal.new(-1).atan2((-100).Str), -3.13159298690313, "DifferentReal.atan2(Str)");
    is_approx(atan2(DifferentReal.new(-100), (1).Str), -1.56079666010823, "atan2(DifferentReal, Str)");
}

{
    # DifferentReal vs DifferentReal tests
    is_approx(DifferentReal.new(-10).atan2(DifferentReal.new(100)), -0.099668652491162, "DifferentReal.atan2(DifferentReal)");
    is_approx(atan2(DifferentReal.new(1), DifferentReal.new(-100)), 3.13159298690313, "atan2(DifferentReal, DifferentReal)");
}

{
    # DifferentReal vs FatRat tests
    is_approx(DifferentReal.new(1).atan2((100).FatRat), 0.00999966668666524, "DifferentReal.atan2(FatRat)");
    is_approx(atan2(DifferentReal.new(0.1), (-100).FatRat), 3.14059265392313, "atan2(DifferentReal, FatRat)");
}

{
    # FatRat tests
    is_approx((0.1).FatRat.atan2, 0.099668652491162, "FatRat.atan2");
    is_approx(atan2((-0.1).FatRat), -0.099668652491162, "atan2(FatRat)");
}

{
    # FatRat vs Num tests
    is_approx((1).FatRat.atan2((10).Num), 0.099668652491162, "FatRat.atan2(Num)");
    is_approx(atan2((0.1).FatRat, (0.1).Num), 0.785398163397448, "atan2(FatRat, Num)");
}

{
    # FatRat vs Rat tests
    is_approx((10).FatRat.atan2((-0.1).Rat(1e-9)), 1.58079599348156, "FatRat.atan2(Rat)");
    is_approx(atan2((0.1).FatRat, (1).Rat(1e-9)), 0.099668652491162, "atan2(FatRat, Rat)");
}

{
    # FatRat vs Int tests
    is_approx((10).FatRat.atan2((1).Int), 1.47112767430373, "FatRat.atan2(Int)");
    is_approx(atan2((-100).FatRat, (100).Int), -0.785398163397448, "atan2(FatRat, Int)");
}

{
    # FatRat vs Str tests
    is_approx((100).FatRat.atan2((100).Str), 0.785398163397448, "FatRat.atan2(Str)");
    is_approx(atan2((-0.1).FatRat, (100).Str), -0.000999999666666867, "atan2(FatRat, Str)");
}

{
    # FatRat vs DifferentReal tests
    is_approx((100).FatRat.atan2(DifferentReal.new(-10)), 1.67046497928606, "FatRat.atan2(DifferentReal)");
    is_approx(atan2((-10).FatRat, DifferentReal.new(-0.1)), -1.58079599348156, "atan2(FatRat, DifferentReal)");
}

{
    # FatRat vs FatRat tests
    is_approx((0.1).FatRat.atan2((-1).FatRat), 3.04192400109863, "FatRat.atan2(FatRat)");
    is_approx(atan2((0.1).FatRat, (-10).FatRat), 3.13159298690313, "atan2(FatRat, FatRat)");
}

done;

# vim: ft=perl6 nomodifiable
����������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/cosech.t�������������������������������������������������������������0000664�0001750�0001750�00000014336�12224265625�016760� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# cosech tests

for @sines -> $angle
{
    next if abs(sinh($angle.key())) < 1e-6;
    my $desired-result = 1.0 / sinh($angle.key());

    # Num.cosech tests -- very thorough
    is_approx($angle.key().cosech, $desired-result, 
              "Num.cosech - {$angle.key()}");

    # Complex.cosech tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { 1.0 / sinh($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { 1.0 / sinh($_) }($zp2);
    
    is_approx($zp0.cosech, $sz0, "Complex.cosech - $zp0");
    is_approx($zp1.cosech, $sz1, "Complex.cosech - $zp1");
    is_approx($zp2.cosech, $sz2, "Complex.cosech - $zp2");
}

#?niecza todo "Inf results wrong"
{
    is(cosech(Inf), 0, "cosech(Inf) -");
    is(cosech(-Inf), "-0", "cosech(-Inf) -");
}
        
{
    # Num tests
    is_approx(cosech((-6.28318530723787).Num), -0.00373489848806798, "cosech(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).cosech, -0.0394210493494572, "Rat.cosech - -3.92699081702367");
    is_approx(cosech((-0.523598775603156).Rat(1e-9)), -1.8253055746695, "cosech(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(cosech((0.523598775603156 + 2i).Complex), -0.202302149262384 - 0.920006877922264i, "cosech(Complex) - 0.523598775603156 + 2i");
}

{
    # Str tests
    is_approx((0.785398163404734).Str.cosech, 1.15118387090806, "Str.cosech - 0.785398163404734");
    is_approx(cosech((1.57079632680947).Str), 0.434537208087792, "cosech(Str) - 1.57079632680947");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(2.3561944902142 + 2i).cosech, -0.0772627459225851 - 0.171882832059526i, "NotComplex.cosech - 2.3561944902142 + 2i");
    is_approx(cosech(NotComplex.new(3.14159265361894 + 2i)), -0.0358119530230833 - 0.078543348553443i, "cosech(NotComplex) - 3.14159265361894 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.92699081702367).cosech, 0.0394210493494572, "DifferentReal.cosech - 3.92699081702367");
    is_approx(cosech(DifferentReal.new(4.7123889804284)), 0.0179680320529917, "cosech(DifferentReal) - 4.7123889804284");
}

{
    # FatRat tests
    is_approx((5.49778714383314).FatRat.cosech, 0.00819178720191627, "FatRat.cosech - 5.49778714383314");
    is_approx(cosech((6.28318530723787).FatRat), 0.00373489848806798, "cosech(FatRat) - 6.28318530723787");
}


# acosech tests

for @sines -> $angle
{
    next if abs(sinh($angle.key())) < 1e-6;
    my $desired-result = 1.0 / sinh($angle.key());

    # Num.acosech tests -- thorough
    is_approx($desired-result.Num.acosech.cosech, $desired-result, 
              "Num.acosech - {$angle.key()}");
    
    # Num.acosech(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.acosech.cosech, $z, 
                  "Complex.acosech - $z");
    }
}
        
{
    # Num tests
    is_approx(acosech((1.8253055746695).Num), 0.523598775603156, "acosech(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((1.15118387090806).Rat(1e-9)).acosech, 0.785398163404734, "Rat.acosech - 0.785398163404734");
    is_approx(acosech((1.8253055746695).Rat(1e-9)), 0.523598775603156, "acosech(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(acosech((0.785398163404734 + 2i).Complex), 0.186914543518615 - 0.439776333846415i, "acosech(Complex) - 0.186914543518615 - 0.439776333846415i");
}

{
    # Str tests
    is_approx(((1.8253055746695).Str).acosech, 0.523598775603156, "Str.acosech - 0.523598775603156");
    is_approx(acosech((1.15118387090806).Str), 0.785398163404734, "acosech(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).acosech, 0.137815559024863 - 0.481963452541975i, "NotComplex.acosech - 0.137815559024863 - 0.481963452541975i");
    is_approx(acosech(NotComplex.new(0.785398163404734 + 2i)), 0.186914543518615 - 0.439776333846415i, "acosech(NotComplex) - 0.186914543518615 - 0.439776333846415i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(1.8253055746695)).acosech, 0.523598775603156, "DifferentReal.acosech - 0.523598775603156");
    is_approx(acosech(DifferentReal.new(1.15118387090806)), 0.785398163404734, "acosech(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((1.8253055746695).FatRat).acosech, 0.523598775603156, "FatRat.acosech - 0.523598775603156");
    is_approx(acosech((1.15118387090806).FatRat), 0.785398163404734, "acosech(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/cosec.t��������������������������������������������������������������0000664�0001750�0001750�00000014137�12224265625�016607� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

plan 114;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# cosec tests

for @sines -> $angle
{
    next if abs(sin($angle.key())) < 1e-6;
    my $desired-result = 1.0 / sin($angle.key());

    # Num.cosec tests -- very thorough
    is_approx($angle.key().cosec, $desired-result, 
              "Num.cosec - {$angle.key()}");

    # Complex.cosec tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { 1.0 / sin($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { 1.0 / sin($_) }($zp2);
    
    is_approx($zp0.cosec, $sz0, "Complex.cosec - $zp0");
    is_approx($zp1.cosec, $sz1, "Complex.cosec - $zp1");
    is_approx($zp2.cosec, $sz2, "Complex.cosec - $zp2");
}


{
    is(cosec(Inf), NaN, "cosec(Inf) -");
    is(cosec(-Inf), NaN, "cosec(-Inf) -");
}
        
{
    # Num tests
    is_approx(cosec((-3.92699081702367).Num), 1.41421356232158, "cosec(Num) - -3.92699081702367");
}

{
    # Rat tests
    is_approx((-0.523598775603156).Rat(1e-9).cosec, -1.99999999998317, "Rat.cosec - -0.523598775603156");
    is_approx(cosec((0.523598775603156).Rat(1e-9)), 1.99999999998317, "cosec(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(cosec((0.785398163404734 + 2i).Complex), 0.194833118738127 - 0.187824499973004i, "cosec(Complex) - 0.785398163404734 + 2i");
}

{
    # Str tests
    is_approx((1.57079632680947).Str.cosec, 1, "Str.cosec - 1.57079632680947");
    is_approx(cosec((2.3561944902142).Str), 1.41421356240401, "cosec(Str) - 2.3561944902142");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(3.92699081702367 + 2i).cosec, -0.194833118743389 + 0.187824499967129i, "NotComplex.cosec - 3.92699081702367 + 2i");
    is_approx(cosec(NotComplex.new(4.7123889804284 + 2i)), -0.26580222883408 - 1.12015792238299e-11i, "cosec(NotComplex) - 4.7123889804284 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(5.49778714383314).cosec, -1.41421356244522, "DifferentReal.cosec - 5.49778714383314");
    is_approx(cosec(DifferentReal.new(6.80678408284103)), 1.99999999978126, "cosec(DifferentReal) - 6.80678408284103");
}

{
    # FatRat tests
    is_approx((10.2101761242615).FatRat.cosec, -1.41421356223915, "FatRat.cosec - 10.2101761242615");
    is_approx(cosec((-3.92699081702367).FatRat), 1.41421356232158, "cosec(FatRat) - -3.92699081702367");
}


# acosec tests

for @sines -> $angle
{
    next if abs(sin($angle.key())) < 1e-6;
    my $desired-result = 1.0 / sin($angle.key());

    # Num.acosec tests -- thorough
    is_approx($desired-result.Num.acosec.cosec, $desired-result, 
              "Num.acosec - {$angle.key()}");
    
    # Num.acosec(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.acosec.cosec, $z, 
                  "Complex.acosec - $z");
    }
}
        
{
    # Num tests
    is_approx(acosec((1.99999999998317).Num), 0.523598775603156, "acosec(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((1.41421356236279).Rat(1e-9)).acosec, 0.785398163404734, "Rat.acosec - 0.785398163404734");
    is_approx(acosec((1.99999999998317).Rat(1e-9)), 0.523598775603156, "acosec(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(acosec((0.785398163404734 + 2i).Complex), 0.156429673425433 - 0.425586400480703i, "acosec(Complex) - 0.156429673425433 - 0.425586400480703i");
}

{
    # Str tests
    is_approx(((1.99999999998317).Str).acosec, 0.523598775603156, "Str.acosec - 0.523598775603156");
    is_approx(acosec((1.41421356236279).Str), 0.785398163404734, "acosec(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).acosec, 0.11106127776165 - 0.454969900935893i, "NotComplex.acosec - 0.11106127776165 - 0.454969900935893i");
    is_approx(acosec(NotComplex.new(0.785398163404734 + 2i)), 0.156429673425433 - 0.425586400480703i, "acosec(NotComplex) - 0.156429673425433 - 0.425586400480703i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(1.99999999998317)).acosec, 0.523598775603156, "DifferentReal.acosec - 0.523598775603156");
    is_approx(acosec(DifferentReal.new(1.41421356236279)), 0.785398163404734, "acosec(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((1.99999999998317).FatRat).acosec, 0.523598775603156, "FatRat.acosec - 0.523598775603156");
    is_approx(acosec((1.41421356236279).FatRat), 0.785398163404734, "acosec(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/cosh.t���������������������������������������������������������������0000664�0001750�0001750�00000013662�12224265625�016451� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# cosh tests

for @coshes -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.cosh tests -- very thorough
    is_approx($angle.key().cosh, $desired-result, 
              "Num.cosh - {$angle.key()}");

    # Complex.cosh tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { (exp($_) + exp(-$_)) / 2 }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { (exp($_) + exp(-$_)) / 2 }($zp2);
    
    is_approx($zp0.cosh, $sz0, "Complex.cosh - $zp0");
    is_approx($zp1.cosh, $sz1, "Complex.cosh - $zp1");
    is_approx($zp2.cosh, $sz2, "Complex.cosh - $zp2");
}

#?niecza todo "Inf results wrong"
{
    is(cosh(Inf), Inf, "cosh(Inf) -");
    is(cosh(-Inf), Inf, "cosh(-Inf) -");
}
        
{
    # Num tests
    is_approx(cosh((-6.28318530723787).Num), 267.746761499354, "cosh(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).cosh, 25.3868611932849, "Rat.cosh - -3.92699081702367");
    is_approx(cosh((-0.523598775603156).Rat(1e-9)), 1.14023832107909, "cosh(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(cosh((0 + 2i).Complex), -0.416146836547142 + 0i, "cosh(Complex) - 0 + 2i");
}

{
    # Str tests
    is_approx((0.523598775603156).Str.cosh, 1.14023832107909, "Str.cosh - 0.523598775603156");
    is_approx(cosh((0.785398163404734).Str), 1.32460908925833, "cosh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(1.57079632680947 + 2i).cosh, -1.04418668623968 + 2.09256517025804i, "NotComplex.cosh - 1.57079632680947 + 2i");
    is_approx(cosh(NotComplex.new(2.3561944902142 + 2i)), -2.21504646879479 + 4.75378141873222i, "cosh(NotComplex) - 2.3561944902142 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.14159265361894).cosh, 11.5919532758581, "DifferentReal.cosh - 3.14159265361894");
    is_approx(cosh(DifferentReal.new(3.92699081702367)), 25.3868611932849, "cosh(DifferentReal) - 3.92699081702367");
}

{
    # FatRat tests
    is_approx((4.7123889804284).FatRat.cosh, 55.6633808928716, "FatRat.cosh - 4.7123889804284");
    is_approx(cosh((5.49778714383314).FatRat), 122.077579345808, "cosh(FatRat) - 5.49778714383314");
}


# acosh tests

for @coshes -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.acosh tests -- thorough
    is_approx($desired-result.Num.acosh.cosh, $desired-result, 
              "Num.acosh - {$angle.key()}");
    
    # Num.acosh(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.acosh.cosh, $z, 
                  "Complex.acosh - $z");
    }
}
        
{
    # Num tests
    is_approx(acosh((1.14023832107909).Num), 0.523598775603156, "acosh(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((1.32460908925833).Rat(1e-9)).acosh, 0.785398163404734, "Rat.acosh - 0.785398163404734");
    is_approx(acosh((1.14023832107909).Rat(1e-9)), 0.523598775603156, "acosh(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(acosh((0.785398163404734 + 2i).Complex), 1.49709293866352 + 1.22945740853541i, "acosh(Complex) - 1.49709293866352 + 1.22945740853541i");
}

{
    # Str tests
    is_approx(((1.14023832107909).Str).acosh, 0.523598775603156, "Str.acosh - 0.523598775603156");
    is_approx(acosh((1.32460908925833).Str), 0.785398163404734, "acosh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).acosh, 1.46781890096429 + 1.33960563114198i, "NotComplex.acosh - 1.46781890096429 + 1.33960563114198i");
    is_approx(acosh(NotComplex.new(0.785398163404734 + 2i)), 1.49709293866352 + 1.22945740853541i, "acosh(NotComplex) - 1.49709293866352 + 1.22945740853541i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(1.14023832107909)).acosh, 0.523598775603156, "DifferentReal.acosh - 0.523598775603156");
    is_approx(acosh(DifferentReal.new(1.32460908925833)), 0.785398163404734, "acosh(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((1.14023832107909).FatRat).acosh, 0.523598775603156, "FatRat.acosh - 0.523598775603156");
    is_approx(acosh((1.32460908925833).FatRat), 0.785398163404734, "acosh(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/cos.t����������������������������������������������������������������0000664�0001750�0001750�00000013460�12224265625�016275� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# cos tests

for @cosines -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.cos tests -- very thorough
    is_approx($angle.key().cos, $desired-result, 
              "Num.cos - {$angle.key()}");

    # Complex.cos tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { (exp($_ * 1i) + exp(-$_ * 1i)) / 2 }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { (exp($_ * 1i) + exp(-$_ * 1i)) / 2 }($zp2);
    
    is_approx($zp0.cos, $sz0, "Complex.cos - $zp0");
    is_approx($zp1.cos, $sz1, "Complex.cos - $zp1");
    is_approx($zp2.cos, $sz2, "Complex.cos - $zp2");
}


{
    is(cos(Inf), NaN, "cos(Inf) -");
    is(cos(-Inf), NaN, "cos(-Inf) -");
}
        
{
    # Num tests
    is_approx(cos((-7.85398163404734).Num), 0, "cos(Num) - -7.85398163404734");
}

{
    # Rat tests
    is_approx((-5.49778714383314).Rat(1e-9).cos, 0.707106781186548, "Rat.cos - -5.49778714383314");
    is_approx(cos((-2.09439510241262).Rat(1e-9)), -0.5, "cos(Rat) - -2.09439510241262");
}

{
    # Complex tests
    is_approx(cos((-1.57079632680947 + 2i).Complex), -5.48212707989036e-11 + 3.62686040784702i, "cos(Complex) - -1.57079632680947 + 2i");
}

{
    # Str tests
    is_approx((-1.04719755120631).Str.cos, 0.5, "Str.cos - -1.04719755120631");
    is_approx(cos((-0.785398163404734).Str), 0.707106781186548, "cos(Str) - -0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(0 + 2i).cos, 3.76219569108363 + 0i, "NotComplex.cos - 0 + 2i");
    is_approx(cos(NotComplex.new(0.785398163404734 + 2i)), 2.66027408529666 - 2.56457758882432i, "cos(NotComplex) - 0.785398163404734 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(1.57079632680947).cos, 0, "DifferentReal.cos - 1.57079632680947");
    is_approx(cos(DifferentReal.new(2.3561944902142)), -0.707106781186548, "cos(DifferentReal) - 2.3561944902142");
}

{
    # FatRat tests
    is_approx((3.14159265361894).FatRat.cos, -1, "FatRat.cos - 3.14159265361894");
    is_approx(cos((3.92699081702367).FatRat), -0.707106781186548, "cos(FatRat) - 3.92699081702367");
}


# acos tests

for @cosines -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.acos tests -- thorough
    is_approx($desired-result.Num.acos.cos, $desired-result, 
              "Num.acos - {$angle.key()}");
    
    # Num.acos(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.acos.cos, $z, 
                  "Complex.acos - $z");
    }
}
        
{
    # Num tests
    is_approx(acos((0.707106781186548).Num), 0.785398163404734, "acos(Num) - 0.785398163404734");
}

{
    # Rat tests
    is_approx(((0.707106781186548).Rat(1e-9)).acos, 0.785398163404734, "Rat.acos - 0.785398163404734");
    is_approx(acos((0.707106781186548).Rat(1e-9)), 0.785398163404734, "acos(Rat) - 0.785398163404734");
}

{
    # Complex tests
    is_approx(acos((0.785398163404734 + 2i).Complex), 1.22945740674052 - 1.49709293866352i, "acos(Complex) - 1.22945740674052 - 1.49709293866352i");
}

{
    # Str tests
    is_approx(((0.707106781186548).Str).acos, 0.785398163404734, "Str.acos - 0.785398163404734");
    is_approx(acos((0.707106781186548).Str), 0.785398163404734, "acos(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.785398163404734 + 2i)).acos, 1.22945740674052 - 1.49709293866352i, "NotComplex.acos - 1.22945740674052 - 1.49709293866352i");
    is_approx(acos(NotComplex.new(0.785398163404734 + 2i)), 1.22945740674052 - 1.49709293866352i, "acos(NotComplex) - 1.22945740674052 - 1.49709293866352i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(0.707106781186548)).acos, 0.785398163404734, "DifferentReal.acos - 0.785398163404734");
    is_approx(acos(DifferentReal.new(0.707106781186548)), 0.785398163404734, "acos(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((0.707106781186548).FatRat).acos, 0.785398163404734, "FatRat.acos - 0.785398163404734");
    is_approx(acos((0.707106781186548).FatRat), 0.785398163404734, "acos(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/cotanh.t�������������������������������������������������������������0000664�0001750�0001750�00000014366�12224265625�016773� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# cotanh tests

for @sines -> $angle
{
    next if abs(sinh($angle.key())) < 1e-6;
    my $desired-result = cosh($angle.key()) / sinh($angle.key());

    # Num.cotanh tests -- very thorough
    is_approx($angle.key().cotanh, $desired-result, 
              "Num.cotanh - {$angle.key()}");

    # Complex.cotanh tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { cosh($_) / sinh ($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { cosh($_) / sinh ($_) }($zp2);
    
    is_approx($zp0.cotanh, $sz0, "Complex.cotanh - $zp0");
    is_approx($zp1.cotanh, $sz1, "Complex.cotanh - $zp1");
    is_approx($zp2.cotanh, $sz2, "Complex.cotanh - $zp2");
}

#?niecza todo "Inf results wrong"
{
    is(cotanh(Inf), 1, "cotanh(Inf) -");
    is(cotanh(-Inf), -1, "cotanh(-Inf) -");
}
        
{
    # Num tests
    is_approx(cotanh((-6.28318530723787).Num), -1.00000697470903, "cotanh(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).cotanh, -1.0007767079283, "Rat.cotanh - -3.92699081702367");
    is_approx(cotanh((-0.523598775603156).Rat(1e-9)), -2.08128336391745, "cotanh(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(cotanh((0.523598775603156 + 2i).Complex), 0.554305939075667 + 0.335770114695529i, "cotanh(Complex) - 0.523598775603156 + 2i");
}

{
    # Str tests
    is_approx((0.785398163404734).Str.cotanh, 1.52486861881241, "Str.cotanh - 0.785398163404734");
    is_approx(cotanh((1.57079632680947).Str), 1.09033141072462, "cotanh(Str) - 1.57079632680947");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(2.3561944902142 + 2i).cotanh, 0.988233985768855 + 0.0134382542728859i, "NotComplex.cotanh - 2.3561944902142 + 2i");
    is_approx(cotanh(NotComplex.new(3.14159265361894 + 2i)), 0.997557712093238 + 0.00281967717213006i, "cotanh(NotComplex) - 3.14159265361894 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.92699081702367).cotanh, 1.0007767079283, "DifferentReal.cotanh - 3.92699081702367");
    is_approx(cotanh(DifferentReal.new(4.7123889804284)), 1.000161412061, "cotanh(DifferentReal) - 4.7123889804284");
}

{
    # FatRat tests
    is_approx((5.49778714383314).FatRat.cotanh, 1.00003355212591, "FatRat.cotanh - 5.49778714383314");
    is_approx(cotanh((6.28318530723787).FatRat), 1.00000697470903, "cotanh(FatRat) - 6.28318530723787");
}


# acotanh tests

for @sines -> $angle
{
    next if abs(sinh($angle.key())) < 1e-6;
    my $desired-result = cosh($angle.key()) / sinh($angle.key());

    # Num.acotanh tests -- thorough
    is_approx($desired-result.Num.acotanh.cotanh, $desired-result, 
              "Num.acotanh - {$angle.key()}");
    
    # Num.acotanh(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.acotanh.cotanh, $z, 
                  "Complex.acotanh - $z");
    }
}
        
{
    # Num tests
    is_approx(acotanh((2.08128336391745).Num), 0.523598775603156, "acotanh(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((1.52486861881241).Rat(1e-9)).acotanh, 0.785398163404734, "Rat.acotanh - 0.785398163404734");
    is_approx(acotanh((2.08128336391745).Rat(1e-9)), 0.523598775603156, "acotanh(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(acotanh((0.785398163404734 + 2i).Complex), 0.143655432578432 - 0.417829353993379i, "acotanh(Complex) - 0.143655432578432 - 0.417829353993379i");
}

{
    # Str tests
    is_approx(((2.08128336391745).Str).acotanh, 0.523598775603156, "Str.acotanh - 0.523598775603156");
    is_approx(acotanh((1.52486861881241).Str), 0.785398163404734, "acotanh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).acotanh, 0.100612672097949 - 0.442426473062511i, "NotComplex.acotanh - 0.100612672097949 - 0.442426473062511i");
    is_approx(acotanh(NotComplex.new(0.785398163404734 + 2i)), 0.143655432578432 - 0.417829353993379i, "acotanh(NotComplex) - 0.143655432578432 - 0.417829353993379i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(2.08128336391745)).acotanh, 0.523598775603156, "DifferentReal.acotanh - 0.523598775603156");
    is_approx(acotanh(DifferentReal.new(1.52486861881241)), 0.785398163404734, "acotanh(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((2.08128336391745).FatRat).acotanh, 0.523598775603156, "FatRat.acotanh - 0.523598775603156");
    is_approx(acotanh((1.52486861881241).FatRat), 0.785398163404734, "acotanh(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/cotan.t��������������������������������������������������������������0000664�0001750�0001750�00000014225�12224265625�016615� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# cotan tests

for @sines -> $angle
{
    next if abs(sin($angle.key())) < 1e-6;
    my $desired-result = cos($angle.key()) / sin($angle.key());

    # Num.cotan tests -- very thorough
    is_approx($angle.key().cotan, $desired-result, 
              "Num.cotan - {$angle.key()}");

    # Complex.cotan tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { cos($_) / sin($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { cos($_) / sin($_) }($zp2);
    
    is_approx($zp0.cotan, $sz0, "Complex.cotan - $zp0");
    is_approx($zp1.cotan, $sz1, "Complex.cotan - $zp1");
    is_approx($zp2.cotan, $sz2, "Complex.cotan - $zp2");
}


{
    is(cotan(Inf), NaN, "cotan(Inf) -");
    is(cotan(-Inf), NaN, "cotan(-Inf) -");
}
        
{
    # Num tests
    is_approx(cotan((-3.92699081702367).Num), -0.999999999927141, "cotan(Num) - -3.92699081702367");
}

{
    # Rat tests
    is_approx((-0.523598775603156).Rat(1e-9).cotan, -1.73205080754945, "Rat.cotan - -0.523598775603156");
    is_approx(cotan((0.523598775603156).Rat(1e-9)), 1.73205080754945, "cotan(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(cotan((0.785398163404734 + 2i).Complex), 0.0366189934736669 - 0.999329299738534i, "cotan(Complex) - 0.785398163404734 + 2i");
}

{
    # Str tests
    is_approx((1.57079632680947).Str.cotan, -1.45716159658652e-11, "Str.cotan - 1.57079632680947");
    is_approx(cotan((2.3561944902142).Str), -1.00000000004372, "cotan(Str) - 2.3561944902142");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(3.92699081702367 + 2i).cotan, 0.036618993473589 - 0.999329299736401i, "NotComplex.cotan - 3.92699081702367 + 2i");
    is_approx(cotan(NotComplex.new(4.7123889804284 + 2i)), -3.08850574993026e-12 - 0.964027580075817i, "cotan(NotComplex) - 4.7123889804284 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(5.49778714383314).cotan, -1.000000000102, "DifferentReal.cotan - 5.49778714383314");
    is_approx(cotan(DifferentReal.new(6.80678408284103)), 1.7320508073163, "cotan(DifferentReal) - 6.80678408284103");
}

{
    # FatRat tests
    is_approx((10.2101761242615).FatRat.cotan, 0.999999999810569, "FatRat.cotan - 10.2101761242615");
    is_approx(cotan((-3.92699081702367).FatRat), -0.999999999927141, "cotan(FatRat) - -3.92699081702367");
}


# acotan tests

for @sines -> $angle
{
    next if abs(sin($angle.key())) < 1e-6;
    my $desired-result = cos($angle.key()) / sin($angle.key());

    # Num.acotan tests -- thorough
    is_approx($desired-result.Num.acotan.cotan, $desired-result, 
              "Num.acotan - {$angle.key()}");
    
    # Num.acotan(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.acotan.cotan, $z, 
                  "Complex.acotan - $z");
    }
}
        
{
    # Num tests
    is_approx(acotan((1.73205080754945).Num), 0.523598775603156, "acotan(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((0.999999999985428).Rat(1e-9)).acotan, 0.785398163404734, "Rat.acotan - 0.785398163404734");
    is_approx(acotan((1.73205080754945).Rat(1e-9)), 0.523598775603156, "acotan(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(acotan((0.785398163404734 + 2i).Complex), 0.204860490024916 - 0.445759203696597i, "acotan(Complex) - 0.204860490024916 - 0.445759203696597i");
}

{
    # Str tests
    is_approx(((1.73205080754945).Str).acotan, 0.523598775603156, "Str.acotan - 0.523598775603156");
    is_approx(acotan((0.999999999985428).Str), 0.785398163404734, "acotan(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).acotan, 0.154777736124053 - 0.496236956634457i, "NotComplex.acotan - 0.154777736124053 - 0.496236956634457i");
    is_approx(acotan(NotComplex.new(0.785398163404734 + 2i)), 0.204860490024916 - 0.445759203696597i, "acotan(NotComplex) - 0.204860490024916 - 0.445759203696597i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(1.73205080754945)).acotan, 0.523598775603156, "DifferentReal.acotan - 0.523598775603156");
    is_approx(acotan(DifferentReal.new(0.999999999985428)), 0.785398163404734, "acotan(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((1.73205080754945).FatRat).acotan, 0.523598775603156, "FatRat.acotan - 0.523598775603156");
    is_approx(acotan((0.999999999985428).FatRat), 0.785398163404734, "acotan(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/e.t������������������������������������������������������������������0000664�0001750�0001750�00000000653�12224265625�015735� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 5;

=begin description

Basic tests for trigonometric functions.

=end description

# See also: L<"http://en.wikipedia.org/wiki/E_%28mathematical_constant%29"> :)
my $e = e;

is(e      , $e,    "e, as a value");
#?pugs todo
eval_dies_ok('e()', "e(), dies as a sub");
is(1 + e,   $e+1, "1+e, as a value");
is(e + 1,   $e+1, "e+1, as a value");
is(1 + e +0, $e+1, "1 + e +0, as a value");

# vim: ft=perl6
�������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/generate-tests.pl����������������������������������������������������0000664�0001750�0001750�00000041131�12224265625�020607� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;

my Str $skip;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value });

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key =>
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key =>
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

my $functions_file = "trig_functions";

sub Substitute($str, *%rules) {
    my $result = $str;
    for %rules.keys.sort(*.chars).reverse -> $key {
        $result.=subst: '$' ~ $key, %rules{$key}, :g;
    }
    return $result;
}

sub Type($num, $type) {
    my $typed-num = "($num).$type";
    given $type {
        when "Rat" {
            $typed-num = "({$num}).{$type}(1e-9)";
        }
        when "NotComplex" { 
            $typed-num = "NotComplex.new($num)";
        }
        when "DifferentReal" { 
            $typed-num = "DifferentReal.new($num)";
        }
    }
    $typed-num;
}

sub ForwardTest($str, $angle, $fun, $type, $desired-result-rule) {
    my $input_angle = $angle.key();
    my $desired-result = eval($desired-result-rule);
    given $type {
        when "Complex" | "NotComplex" { 
            $input_angle = $angle.key + 2i;  
            $desired-result = ($angle.key() + 2i)."$fun"();
        }
    }

    my $typed-angle = Type($input_angle, $type);
    my $typed-result = Type($desired-result, $type);

    Substitute($str, :$fun, :$type, :angle($input_angle), :$typed-angle,
               :$desired-result, :$typed-result);
}

sub InverseTest($str, $angle, $fun, $type, $desired-result-rule) {
    my $input_angle = $angle.key();
    my $desired-result = eval($desired-result-rule);
    given $type {
        when "Complex" | "NotComplex" { 
            $input_angle = ($angle.key() + 2i)."$fun"();
            $desired-result = ($angle.key() + 2i);
        }
    }

    my $typed-angle = Type($input_angle, $type);
    my $typed-result = Type($desired-result, $type);

    Substitute($str, :$fun, :$type, :angle($input_angle), :$typed-angle,
               :$desired-result, :$typed-result);
}

multi sub Atan2Test($str, Real $value, $type1) {
    my $desired-result = $value.atan2(1);
    my $type1-value = Type($value, $type1);
    Substitute($str, :$type1, :$desired-result, :$type1-value);
}

multi sub Atan2Test($str, Real $value1, Real $value2, $type1, $type2) {
    my $desired-result = $value1.atan2($value2);
    my $type1-value = Type($value1, $type1);
    my $type2-value = Type($value2, $type2);
    Substitute($str, :$type1, :$type2, :$desired-result, :$type1-value, :$type2-value);
}

sub grep-and-repeat(@a, $skip-rule) {
    gather loop {
        for @a -> $a {
            if $skip-rule {
                take $a unless $skip-rule.subst('$angle', $a.key()).eval;
            } else {
                take $a;
            }
        }
    }
}

class TrigFunction
{
    has $.function_name;
    has $.inverted_function_name;
    has $.angle_and_results_name;
    has $.rational_inverse_tests;
    has $.skip;
    has $.desired-result-code;
    has $.complex_check;
    has $.plus_inf;
    has $.minus_inf;
    has $.inf_fudge;
    
    multi method new(Str $function_name is copy, 
                     Str $inverted_function_name is copy;
                     Str $angle_and_results_name is copy,
                     Str $rational_inverse_tests is copy;
                     Str $skip is copy,
                     Str $desired-result-code is copy,
                     Str $complex_check is copy,
                     Str $plus_inf is copy,
                     Str $minus_inf is copy) {
        self.bless(
                   :$function_name, 
                   :$inverted_function_name, 
                   :$angle_and_results_name, 
                   :$rational_inverse_tests,
                   :$skip,
                   :$desired-result-code,
                   :$complex_check,
                   :$plus_inf,
                   :$minus_inf,
                   :inf_fudge($function_name ~~ /h/ ?? '#?niecza skip "Inf results wrong"' !! ''));
    }

    my sub notgrep(@a, Mu $condition) {
        gather for @a -> $a {
            take $a if $a ~~ $condition;
        }
    }

    method dump_forward_tests($file) {
         my $setup_block = $skip ?? "next if " ~ $.skip.subst('$angle', '$angle.key()') ~ ";" !! "";

        my $code = q[
            # $.function_name tests

            for $.angle_and_results_name -> $angle
            {
                $.setup_block
                my $desired-result = $.desired-result-code;

                # Num.$.function_name tests -- very thorough
                is_approx($angle.key().$.function_name, $desired-result, 
                          "Num.$.function_name - {$angle.key()}");

                # Complex.$.function_name tests -- also very thorough
                my Complex $zp0 = $angle.key + 0.0i;
                my Complex $sz0 = $desired-result + 0i;
                my Complex $zp1 = $angle.key + 1.0i;
                my Complex $sz1 = $.complex_check($zp1);
                my Complex $zp2 = $angle.key + 2.0i;
                my Complex $sz2 = $.complex_check($zp2);
                
                is_approx($zp0.$.function_name, $sz0, "Complex.$.function_name - $zp0");
                is_approx($zp1.$.function_name, $sz1, "Complex.$.function_name - $zp1");
                is_approx($zp2.$.function_name, $sz2, "Complex.$.function_name - $zp2");
            }
            
            $.inf_fudge
            {
                is($.function_name(Inf), $.plus_inf, "$.function_name(Inf) -");
                is($.function_name(-Inf), $.minus_inf, "$.function_name(-Inf) -");
            }
        ];
        $code.=subst: '$.function_name', $.function_name, :g;
        $code.=subst: '$.inverted_function_name', $.inverted_function_name, :g;
        $code.=subst: '$.setup_block', $setup_block, :g;
        $code.=subst: '$.desired-result-code', $.desired-result-code, :g;
        $code.=subst: '$.complex_check', $.complex_check, :g;
        $code.=subst: '$.angle_and_results_name', $.angle_and_results_name, :g;
        $code.=subst: '$.rational_inverse_tests', $.rational_inverse_tests, :g;
        $code.=subst: '$.plus_inf', $.plus_inf, :g;
        $code.=subst: '$.minus_inf', $.minus_inf, :g;
        $code.=subst: '$.inf_fudge', $.inf_fudge, :g;
        $code.=subst: / ^^ ' ' ** 12 /, '', :g;

        $file.say: $code;
        
        # next block is bordering on evil, and hopefully can be cleaned up in the near future
        my $angle_list = grep-and-repeat(eval($.angle_and_results_name), $.skip);
        my $fun = $.function_name;
        for <Num Rat Complex Str NotComplex DifferentReal FatRat> -> $type {
            $file.say: '{';
            $file.say: "    \# $type tests";
            
            unless $type eq "Num" || $type eq "Complex" {
                $file.say: ForwardTest('    is_approx($typed-angle.$fun, $desired-result, "$type.$fun - $angle");', 
                                        $angle_list.shift, $fun, $type, $.desired-result-code);
            }
            $file.say: ForwardTest('    is_approx($fun($typed-angle), $desired-result, "$fun($type) - $angle");', 
                                    $angle_list.shift, $fun, $type, $.desired-result-code);
            
            $file.say: '}';
            $file.say: "";
        }
    }
    
    method dump_inverse_tests($file) {
        my $setup_block = $skip ?? "next if " ~ $.skip.subst('$angle', '$angle.key()') ~ ";" !! "";

        my $code = q[
            # $.inverted_function_name tests

            for $.angle_and_results_name -> $angle
            {
                $.setup_block
                my $desired-result = $.desired-result-code;

                # Num.$.inverted_function_name tests -- thorough
                is_approx($desired-result.Num.$.inverted_function_name.$.function_name, $desired-result, 
                          "Num.$.inverted_function_name - {$angle.key()}");
                
                # Num.$.inverted_function_name(Complex) tests -- thorough
                for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
                    is_approx($z.$.inverted_function_name.$.function_name, $z, 
                              "Complex.$.inverted_function_name - $z");
                }
            }
        ];
        $code.=subst: '$.function_name', $.function_name, :g;
        $code.=subst: '$.inverted_function_name', $.inverted_function_name, :g;
        $code.=subst: '$.setup_block', $setup_block, :g;
        $code.=subst: '$.desired-result-code', $.desired-result-code, :g;
        $code.=subst: '$.angle_and_results_name', $.angle_and_results_name, :g;
        $code.=subst: '$.rational_inverse_tests', $.rational_inverse_tests, :g;
        $code.=subst: '$.plus_inf', $.plus_inf, :g;
        $code.=subst: '$.minus_inf', $.minus_inf, :g;
        $code.=subst: / ^^ ' ' ** 12 /, '', :g;
        
        $file.say: $code;
        
        # next block is bordering on evil, and hopefully can be cleaned up in the near future
        my $angle_list = grep-and-repeat(notgrep(eval($.angle_and_results_name), 
                                                 {0 < $_.key() < pi / 2}), $.skip);
        my $fun = $.function_name;
        my $inv = $.inverted_function_name;
        for <Num Rat Complex Str NotComplex DifferentReal FatRat> -> $type {
            $file.say: '{';
            $file.say: "    # $type tests";
            unless $type eq "Num" || $type eq "Complex" {
                $file.say: InverseTest('    is_approx(($typed-result).$fun, $angle, "$type.$fun - $angle");', 
                                        $angle_list.shift, $inv, $type, $.desired-result-code);
            }

            $file.say: InverseTest('    is_approx($fun($typed-result), $angle, "$fun($type) - $angle");', 
                                    $angle_list.shift, $inv, $type, $.desired-result-code);


            $file.say: "}";
            $file.say: "";
        }
    }
}

sub OpenAndStartOutputFile($output_file)
{
    my $file = open $output_file, :w or die "Unable to open $output_file $!\n";

    $file.say: '# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            

';
    
    return $file;
}

sub CloseOutputFile($file)
{
    # the {} afer 'vim' just generate an empty string.
    # this is to avoid the string constant being interpreted as a modeline
    # here in generate-tests.pl
    $file.say: "done;";
    $file.say: "";
    $file.say: '# vim: ft=perl6 nomodifiable';
    $file.close;
}

my $file;

my $functions = open $functions_file, :r or die "Unable to open $functions_file: $!\n";

my Str $function_name;
my Str $inverted_function_name;
my Str $angle_and_results_name;
my Str $rational_inverse_tests;
my Str $desired-result-code;
my Str $complex_check;
my Str $plus_inf;
my Str $minus_inf;
for $functions.lines {
    when /^'#'/ { } # skip comment lines
    when /Function\:\s+(.*)/ {
        $function_name = ~$0; 
        $inverted_function_name = "a$0";
        $angle_and_results_name = "";
        $rational_inverse_tests = "(-2/2, -1/2, 1/2, 2/2)";
        $skip = "";
        $desired-result-code = "";
        $complex_check = "";
        $plus_inf = "NaN";
        $minus_inf = "NaN";
        
        $file = OpenAndStartOutputFile($function_name ~ ".t");
    }
    when /skip\:\s+(.*)/ { $skip = ~$0; }
    when /desired_result\:\s+(.*)/ { $desired-result-code = ~$0; }
    when /loop_over\:\s+(.*)/ { $angle_and_results_name = ~$0; }
    when /inverted_function\:\s+(.*)/ { $inverted_function_name = ~$0; }
    when /rational_inverse_tests\:\s+(.*)/ { $rational_inverse_tests = ~$0; }
    when /complex_check\:\s+(.*)/ { $complex_check = ~$0; }
    when /plus_inf\:\s+(.*)/ { $plus_inf = ~$0; }
    when /minus_inf\:\s+(.*)/ { $minus_inf = ~$0; }
    when /End/ {
        say :$function_name.perl;
        my $tf = TrigFunction.new($function_name, $inverted_function_name, $angle_and_results_name, 
                                  $rational_inverse_tests, $skip, $desired-result-code,
                                  $complex_check, $plus_inf, $minus_inf);
        $tf.dump_forward_tests($file);
        $tf.dump_inverse_tests($file);
        CloseOutputFile($file);
    }
}

# output the atan2 file, a special case

$file = OpenAndStartOutputFile("atan2.t");
$file.say: q[
# atan2 tests

# First, test atan2 with x = 1

for @sines -> $angle
{
    next if abs(cos($angle.key())) < 1e-6;     
	my $desired-result = sin($angle.key()) / cos($angle.key());

    # Num.atan2 tests
    is_approx($desired-result.Num.atan2.tan, $desired-result, 
              "Num.atan2() - {$angle.key()}");
    is_approx($desired-result.Num.atan2(1.Num).tan, $desired-result, 
              "Num.atan2(1.Num) - {$angle.key()}");
}

# check that the proper quadrant is returned

is_approx(atan2(4, 4), pi / 4, "atan2(4, 4) is pi / 4");
is_approx(atan2(-4, 4), -pi / 4, "atan2(-4, 4) is -pi / 4");
is_approx(atan2(4, -4), 3 * pi / 4, "atan2(4, -4) is 3pi / 4");
is_approx(atan2(-4, -4), -3 * pi / 4, "atan2(-4, -4) is -3pi / 4");
];

my @values = (-100, -10, -1, -.1, .1, 1, 10, 100);

sub filter-type(@values is copy, $type) {
    given $type {
        when "Int" {
            @values.=grep({ $_ == $_.Int });
        }
    }
    @values;
}

for <Num Rat Int Str DifferentReal FatRat> -> $type1 {
    $file.say: "\{";
    $file.say: "    # $type1 tests";
    
    unless $type1 eq "Num" {
        $file.say: Atan2Test('    is_approx($type1-value.atan2, $desired-result, "$type1.atan2");', 
                             filter-type(@values, $type1).pick, $type1);
    }

    $file.say: Atan2Test('    is_approx(atan2($type1-value), $desired-result, "atan2($type1)");', 
                         filter-type(@values, $type1).pick, $type1);

    $file.say: "}";
    $file.say: "";
    
    for <Num Rat Int Str DifferentReal FatRat> -> $type2 {
        $file.say: '{';
        $file.say: "    # $type1 vs $type2 tests";
        
        $file.say: Atan2Test('    is_approx($type1-value.atan2($type2-value), $desired-result, "$type1.atan2($type2)");', 
                             filter-type(@values, $type1).pick, filter-type(@values, $type2).pick, $type1, $type2);
        $file.say: Atan2Test('    is_approx(atan2($type1-value, $type2-value), $desired-result, "atan2($type1, $type2)");', 
                             filter-type(@values, $type1).pick, filter-type(@values, $type2).pick, $type1, $type2);
        $file.say: "}";
        $file.say: "";
    }
}

CloseOutputFile($file);

# vim: ft=perl6
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/pi.t�����������������������������������������������������������������0000664�0001750�0001750�00000000536�12224265625�016121� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan 3;

=begin description

Tests for pi function.

=end description

# See also: L<"http://theory.cs.iitm.ernet.in/~arvindn/pi/"> :)
my $PI = 3.141592653589e0;

# -- pi
is_approx(pi, $PI, "pi (using constant)");
is_approx(pi, atan(1)*4, "pi checked by atan(1)*4");
is_approx(pi + 3, $PI + 3, "'pi + 3' = PI +3");

# vim: ft=perl6
������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/sech.t���������������������������������������������������������������0000664�0001750�0001750�00000014050�12224265625�016427� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# sech tests

for @cosines -> $angle
{
    next if abs(cosh($angle.key())) < 1e-6;
    my $desired-result = 1.0 / cosh($angle.key());

    # Num.sech tests -- very thorough
    is_approx($angle.key().sech, $desired-result, 
              "Num.sech - {$angle.key()}");

    # Complex.sech tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { 1.0 / cosh($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { 1.0 / cosh($_) }($zp2);
    
    is_approx($zp0.sech, $sz0, "Complex.sech - $zp0");
    is_approx($zp1.sech, $sz1, "Complex.sech - $zp1");
    is_approx($zp2.sech, $sz2, "Complex.sech - $zp2");
}

#?niecza todo "Inf results wrong"
{
    is(sech(Inf), 0, "sech(Inf) -");
    is(sech(-Inf), 0, "sech(-Inf) -");
}
        
{
    # Num tests
    is_approx(sech((-7.85398163404734).Num), 0.000776406290791195, "sech(Num) - -7.85398163404734");
}

{
    # Rat tests
    is_approx((-5.49778714383314).Rat(1e-9).sech, 0.00819151235926221, "Rat.sech - -5.49778714383314");
    is_approx(sech((-2.09439510241262).Rat(1e-9)), 0.242610328725292, "sech(Rat) - -2.09439510241262");
}

{
    # Complex tests
    is_approx(sech((-1.57079632680947 + 2i).Complex), -0.190922860876022 + 0.382612165180854i, "sech(Complex) - -1.57079632680947 + 2i");
}

{
    # Str tests
    is_approx((-1.04719755120631).Str.sech, 0.624887966291348, "Str.sech - -1.04719755120631");
    is_approx(sech((-0.785398163404734).Str), 0.754939708710524, "sech(Str) - -0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(0 + 2i).sech, -2.40299796172238 + 0i, "NotComplex.sech - 0 + 2i");
    is_approx(sech(NotComplex.new(0.785398163404734 + 2i)), -0.594148775843208 - 0.851377452397526i, "sech(NotComplex) - 0.785398163404734 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(1.57079632680947).sech, 0.398536815333061, "DifferentReal.sech - 1.57079632680947");
    is_approx(sech(DifferentReal.new(2.3561944902142)), 0.187872734233684, "sech(DifferentReal) - 2.3561944902142");
}

{
    # FatRat tests
    is_approx((3.14159265361894).FatRat.sech, 0.0862667383315497, "FatRat.sech - 3.14159265361894");
    is_approx(sech((3.92699081702367).FatRat), 0.03939045447117, "sech(FatRat) - 3.92699081702367");
}


# asech tests

for @cosines -> $angle
{
    next if abs(cosh($angle.key())) < 1e-6;
    my $desired-result = 1.0 / cosh($angle.key());

    # Num.asech tests -- thorough
    is_approx($desired-result.Num.asech.sech, $desired-result, 
              "Num.asech - {$angle.key()}");
    
    # Num.asech(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.asech.sech, $z, 
                  "Complex.asech - $z");
    }
}
        
{
    # Num tests
    is_approx(asech((0.754939708710524).Num), 0.785398163404734, "asech(Num) - 0.785398163404734");
}

{
    # Rat tests
    is_approx(((0.754939708710524).Rat(1e-9)).asech, 0.785398163404734, "Rat.asech - 0.785398163404734");
    is_approx(asech((0.754939708710524).Rat(1e-9)), 0.785398163404734, "asech(Rat) - 0.785398163404734");
}

{
    # Complex tests
    is_approx(asech((0.785398163404734 + 2i).Complex), 0.425586400480703 - 1.41436665336946i, "asech(Complex) - 0.425586400480703 - 1.41436665336946i");
}

{
    # Str tests
    is_approx(((0.754939708710524).Str).asech, 0.785398163404734, "Str.asech - 0.785398163404734");
    is_approx(asech((0.754939708710524).Str), 0.785398163404734, "asech(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.785398163404734 + 2i)).asech, 0.425586400480703 - 1.41436665336946i, "NotComplex.asech - 0.425586400480703 - 1.41436665336946i");
    is_approx(asech(NotComplex.new(0.785398163404734 + 2i)), 0.425586400480703 - 1.41436665336946i, "asech(NotComplex) - 0.425586400480703 - 1.41436665336946i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(0.754939708710524)).asech, 0.785398163404734, "DifferentReal.asech - 0.785398163404734");
    is_approx(asech(DifferentReal.new(0.754939708710524)), 0.785398163404734, "asech(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((0.754939708710524).FatRat).asech, 0.785398163404734, "FatRat.asech - 0.785398163404734");
    is_approx(asech((0.754939708710524).FatRat), 0.785398163404734, "asech(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/sec.t����������������������������������������������������������������0000664�0001750�0001750�00000013637�12224265625�016271� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# sec tests

for @cosines -> $angle
{
    next if abs(cos($angle.key())) < 1e-6;
    my $desired-result = 1.0 / cos($angle.key());

    # Num.sec tests -- very thorough
    is_approx($angle.key().sec, $desired-result, 
              "Num.sec - {$angle.key()}");

    # Complex.sec tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { 1.0 / cos($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { 1.0 / cos($_) }($zp2);
    
    is_approx($zp0.sec, $sz0, "Complex.sec - $zp0");
    is_approx($zp1.sec, $sz1, "Complex.sec - $zp1");
    is_approx($zp2.sec, $sz2, "Complex.sec - $zp2");
}


{
    is(sec(Inf), NaN, "sec(Inf) -");
    is(sec(-Inf), NaN, "sec(-Inf) -");
}
        
{
    # Num tests
    is_approx(sec((-5.49778714383314).Num), 1.41421356230097, "sec(Num) - -5.49778714383314");
}

{
    # Rat tests
    is_approx((-2.09439510241262).Rat(1e-9).sec, -1.9999999999327, "Rat.sec - -2.09439510241262");
    is_approx(sec((-1.04719755120631).Rat(1e-9)), 2.00000000003365, "sec(Rat) - -1.04719755120631");
}

{
    # Complex tests
    is_approx(sec((-0.785398163404734 + 2i).Complex), 0.194833118735496 - 0.187824499975941i, "sec(Complex) - -0.785398163404734 + 2i");
}

{
    # Str tests
    is_approx((0).Str.sec, 1, "Str.sec - 0");
    is_approx(sec((0.785398163404734).Str), 1.4142135623834, "sec(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(2.3561944902142 + 2i).sec, -0.194833118740758 + 0.187824499970067i, "NotComplex.sec - 2.3561944902142 + 2i");
    is_approx(sec(NotComplex.new(3.14159265361894 + 2i)), -0.26580222883408 - 7.46768155131297e-12i, "sec(NotComplex) - 3.14159265361894 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.92699081702367).sec, -1.41421356242461, "DifferentReal.sec - 3.92699081702367");
    is_approx(sec(DifferentReal.new(5.23598775603156)), 1.99999999983174, "sec(DifferentReal) - 5.23598775603156");
}

{
    # FatRat tests
    is_approx((8.63937979745208).FatRat.sec, -1.41421356225975, "FatRat.sec - 8.63937979745208");
    is_approx(sec((-5.49778714383314).FatRat), 1.41421356230097, "sec(FatRat) - -5.49778714383314");
}


# asec tests

for @cosines -> $angle
{
    next if abs(cos($angle.key())) < 1e-6;
    my $desired-result = 1.0 / cos($angle.key());

    # Num.asec tests -- thorough
    is_approx($desired-result.Num.asec.sec, $desired-result, 
              "Num.asec - {$angle.key()}");
    
    # Num.asec(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.asec.sec, $z, 
                  "Complex.asec - $z");
    }
}
        
{
    # Num tests
    is_approx(asec((1.4142135623834).Num), 0.785398163404734, "asec(Num) - 0.785398163404734");
}

{
    # Rat tests
    is_approx(((1.4142135623834).Rat(1e-9)).asec, 0.785398163404734, "Rat.asec - 0.785398163404734");
    is_approx(asec((1.4142135623834).Rat(1e-9)), 0.785398163404734, "asec(Rat) - 0.785398163404734");
}

{
    # Complex tests
    is_approx(asec((0.785398163404734 + 2i).Complex), 1.41436665157457 + 0.425586400480703i, "asec(Complex) - 1.41436665157457 + 0.425586400480703i");
}

{
    # Str tests
    is_approx(((1.4142135623834).Str).asec, 0.785398163404734, "Str.asec - 0.785398163404734");
    is_approx(asec((1.4142135623834).Str), 0.785398163404734, "asec(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.785398163404734 + 2i)).asec, 1.41436665157457 + 0.425586400480703i, "NotComplex.asec - 1.41436665157457 + 0.425586400480703i");
    is_approx(asec(NotComplex.new(0.785398163404734 + 2i)), 1.41436665157457 + 0.425586400480703i, "asec(NotComplex) - 1.41436665157457 + 0.425586400480703i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(1.4142135623834)).asec, 0.785398163404734, "DifferentReal.asec - 0.785398163404734");
    is_approx(asec(DifferentReal.new(1.4142135623834)), 0.785398163404734, "asec(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((1.4142135623834).FatRat).asec, 0.785398163404734, "FatRat.asec - 0.785398163404734");
    is_approx(asec((1.4142135623834).FatRat), 0.785398163404734, "asec(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
�������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/simple.t�������������������������������������������������������������0000664�0001750�0001750�00000001273�12224265625�017001� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;

plan 12;

is_approx sin(0), 0, 'sin(0)';
is_approx sin(3.1415927), 0, 'sin(pi)';
is_approx sin(6.2831853), 0, 'sin(2 pi)';

# random numbers
my $rn1 = 4.8758e0;
my $rn2 = 0.60612e0;
is_approx sin($rn1), -0.9866781036e0, 'sin(random number 1)';
is_approx sin($rn2), 0.5696829216e0, 'sin(random number 2)';

is_approx cos(0),            1, 'cos(0)';
is_approx cos(3.1415927),     -1, 'cos(pi)';
is_approx cos(6.2831853),     1, 'cos(2 pi)';
is_approx cos($rn1), 0.1626847248e0, 'cos(random number 1)';
is_approx cos($rn2), 0.8218645683e0, 'cos(random number 2)';

is_approx tan($rn1), -6.0649708e0, 'tan(random number 1)';
is_approx tan($rn2), 6.9315912e-1, 'tan(random number 2)';
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/sinh.t���������������������������������������������������������������0000664�0001750�0001750�00000013670�12224265625�016455� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# sinh tests

for @sinhes -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.sinh tests -- very thorough
    is_approx($angle.key().sinh, $desired-result, 
              "Num.sinh - {$angle.key()}");

    # Complex.sinh tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { (exp($_) - exp(-$_)) / 2 }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { (exp($_) - exp(-$_)) / 2 }($zp2);
    
    is_approx($zp0.sinh, $sz0, "Complex.sinh - $zp0");
    is_approx($zp1.sinh, $sz1, "Complex.sinh - $zp1");
    is_approx($zp2.sinh, $sz2, "Complex.sinh - $zp2");
}

#?niecza todo "Inf results wrong"
{
    is(sinh(Inf), Inf, "sinh(Inf) -");
    is(sinh(-Inf), -Inf, "sinh(-Inf) -");
}
        
{
    # Num tests
    is_approx(sinh((-6.28318530723787).Num), -267.744894056623, "sinh(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).sinh, -25.367158320299, "Rat.sinh - -3.92699081702367");
    is_approx(sinh((-0.523598775603156).Rat(1e-9)), -0.547853473893578, "sinh(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(sinh((0 + 2i).Complex), -0 + 0.909297426825682i, "sinh(Complex) - 0 + 2i");
}

{
    # Str tests
    is_approx((0.523598775603156).Str.sinh, 0.547853473893578, "Str.sinh - 0.523598775603156");
    is_approx(sinh((0.785398163404734).Str), 0.86867096149566, "sinh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(1.57079632680947 + 2i).sinh, -0.957678258159807 + 2.28158953412064i, "NotComplex.sinh - 1.57079632680947 + 2i");
    is_approx(sinh(NotComplex.new(2.3561944902142 + 2i)), -2.17560397806036 + 4.83996483329327i, "sinh(NotComplex) - 2.3561944902142 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.14159265361894).sinh, 11.5487393575956, "DifferentReal.sinh - 3.14159265361894");
    is_approx(sinh(DifferentReal.new(3.92699081702367)), 25.367158320299, "sinh(DifferentReal) - 3.92699081702367");
}

{
    # FatRat tests
    is_approx((4.7123889804284).FatRat.sinh, 55.6543976018509, "FatRat.sinh - 4.7123889804284");
    is_approx(sinh((5.49778714383314).FatRat), 122.073483520919, "sinh(FatRat) - 5.49778714383314");
}


# asinh tests

for @sinhes -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.asinh tests -- thorough
    is_approx($desired-result.Num.asinh.sinh, $desired-result, 
              "Num.asinh - {$angle.key()}");
    
    # Num.asinh(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.asinh.sinh, $z, 
                  "Complex.asinh - $z");
    }
}
        
{
    # Num tests
    is_approx(asinh((0.547853473893578).Num), 0.523598775603156, "asinh(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((0.86867096149566).Rat(1e-9)).asinh, 0.785398163404734, "Rat.asinh - 0.785398163404734");
    is_approx(asinh((0.547853473893578).Rat(1e-9)), 0.523598775603156, "asinh(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(asinh((0.785398163404734 + 2i).Complex), 1.41841325789332 + 1.15495109689711i, "asinh(Complex) - 1.41841325789332 + 1.15495109689711i");
}

{
    # Str tests
    is_approx(((0.547853473893578).Str).asinh, 0.523598775603156, "Str.asinh - 0.523598775603156");
    is_approx(asinh((0.86867096149566).Str), 0.785398163404734, "asinh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).asinh, 1.365827718396 + 1.28093108055158i, "NotComplex.asinh - 1.365827718396 + 1.28093108055158i");
    is_approx(asinh(NotComplex.new(0.785398163404734 + 2i)), 1.41841325789332 + 1.15495109689711i, "asinh(NotComplex) - 1.41841325789332 + 1.15495109689711i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(0.547853473893578)).asinh, 0.523598775603156, "DifferentReal.asinh - 0.523598775603156");
    is_approx(asinh(DifferentReal.new(0.86867096149566)), 0.785398163404734, "asinh(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((0.547853473893578).FatRat).asinh, 0.523598775603156, "FatRat.asinh - 0.523598775603156");
    is_approx(asinh((0.86867096149566).FatRat), 0.785398163404734, "asinh(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/sin.t����������������������������������������������������������������0000664�0001750�0001750�00000013346�12224265625�016305� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# sin tests

for @sines -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.sin tests -- very thorough
    is_approx($angle.key().sin, $desired-result, 
              "Num.sin - {$angle.key()}");

    # Complex.sin tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { (exp($_ * 1i) - exp(-$_ * 1i)) / 2i }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { (exp($_ * 1i) - exp(-$_ * 1i)) / 2i }($zp2);
    
    is_approx($zp0.sin, $sz0, "Complex.sin - $zp0");
    is_approx($zp1.sin, $sz1, "Complex.sin - $zp1");
    is_approx($zp2.sin, $sz2, "Complex.sin - $zp2");
}


{
    is(sin(Inf), NaN, "sin(Inf) -");
    is(sin(-Inf), NaN, "sin(-Inf) -");
}
        
{
    # Num tests
    is_approx(sin((-6.28318530723787).Num), 0, "sin(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).sin, 0.707106781186548, "Rat.sin - -3.92699081702367");
    is_approx(sin((-0.523598775603156).Rat(1e-9)), -0.5, "sin(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(sin((0 + 2i).Complex), 0 + 3.62686040784702i, "sin(Complex) - 0 + 2i");
}

{
    # Str tests
    is_approx((0.523598775603156).Str.sin, 0.5, "Str.sin - 0.523598775603156");
    is_approx(sin((0.785398163404734).Str), 0.707106781186548, "sin(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(1.57079632680947 + 2i).sin, 3.76219569108363 - 5.28492170249481e-11i, "NotComplex.sin - 1.57079632680947 + 2i");
    is_approx(sin(NotComplex.new(2.3561944902142 + 2i)), 2.6602740852579 - 2.56457758886169i, "sin(NotComplex) - 2.3561944902142 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.14159265361894).sin, 0, "DifferentReal.sin - 3.14159265361894");
    is_approx(sin(DifferentReal.new(3.92699081702367)), -0.707106781186548, "sin(DifferentReal) - 3.92699081702367");
}

{
    # FatRat tests
    is_approx((4.7123889804284).FatRat.sin, -1, "FatRat.sin - 4.7123889804284");
    is_approx(sin((5.49778714383314).FatRat), -0.707106781186548, "sin(FatRat) - 5.49778714383314");
}


# asin tests

for @sines -> $angle
{
    
    my $desired-result = $angle.value;

    # Num.asin tests -- thorough
    is_approx($desired-result.Num.asin.sin, $desired-result, 
              "Num.asin - {$angle.key()}");
    
    # Num.asin(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.asin.sin, $z, 
                  "Complex.asin - $z");
    }
}
        
{
    # Num tests
    is_approx(asin((0.5).Num), 0.523598775603156, "asin(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((0.707106781186548).Rat(1e-9)).asin, 0.785398163404734, "Rat.asin - 0.785398163404734");
    is_approx(asin((0.5).Rat(1e-9)), 0.523598775603156, "asin(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(asin((0.785398163404734 + 2i).Complex), 0.341338918259482 + 1.49709293866352i, "asin(Complex) - 0.341338918259482 + 1.49709293866352i");
}

{
    # Str tests
    is_approx(((0.5).Str).asin, 0.523598775603156, "Str.asin - 0.523598775603156");
    is_approx(asin((0.707106781186548).Str), 0.785398163404734, "asin(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).asin, 0.231190695652916 + 1.46781890096429i, "NotComplex.asin - 0.231190695652916 + 1.46781890096429i");
    is_approx(asin(NotComplex.new(0.785398163404734 + 2i)), 0.341338918259482 + 1.49709293866352i, "asin(NotComplex) - 0.341338918259482 + 1.49709293866352i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(0.5)).asin, 0.523598775603156, "DifferentReal.asin - 0.523598775603156");
    is_approx(asin(DifferentReal.new(0.707106781186548)), 0.785398163404734, "asin(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((0.5).FatRat).asin, 0.523598775603156, "FatRat.asin - 0.523598775603156");
    is_approx(asin((0.707106781186548).FatRat), 0.785398163404734, "asin(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/tanh.t���������������������������������������������������������������0000664�0001750�0001750�00000014102�12224265625�016435� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# tanh tests

for @sines -> $angle
{
    next if abs(cosh($angle.key())) < 1e-6;
    my $desired-result = sinh($angle.key()) / cosh($angle.key());

    # Num.tanh tests -- very thorough
    is_approx($angle.key().tanh, $desired-result, 
              "Num.tanh - {$angle.key()}");

    # Complex.tanh tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { sinh($_) / cosh($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { sinh($_) / cosh($_) }($zp2);
    
    is_approx($zp0.tanh, $sz0, "Complex.tanh - $zp0");
    is_approx($zp1.tanh, $sz1, "Complex.tanh - $zp1");
    is_approx($zp2.tanh, $sz2, "Complex.tanh - $zp2");
}

#?niecza todo "Inf results wrong"
{
    is(tanh(Inf), 1, "tanh(Inf) -");
    is(tanh(-Inf), -1, "tanh(-Inf) -");
}
        
{
    # Num tests
    is_approx(tanh((-6.28318530723787).Num), -0.999993025339611, "tanh(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).tanh, -0.999223894878698, "Rat.tanh - -3.92699081702367");
    is_approx(tanh((-0.523598775603156).Rat(1e-9)), -0.480472778160188, "tanh(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(tanh((0 + 2i).Complex), 0 - 2.18503986326152i, "tanh(Complex) - 0 + 2i");
}

{
    # Str tests
    is_approx((0.523598775603156).Str.tanh, 0.480472778160188, "Str.tanh - 0.523598775603156");
    is_approx(tanh((0.785398163404734).Str), 0.655794202636825, "tanh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(1.57079632680947 + 2i).tanh, 1.05580658455051 - 0.0691882492979498i, "NotComplex.tanh - 1.57079632680947 + 2i");
    is_approx(tanh(NotComplex.new(2.3561944902142 + 2i)), 1.01171902215521 - 0.0137576097040009i, "tanh(NotComplex) - 2.3561944902142 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.14159265361894).tanh, 0.996272076220967, "DifferentReal.tanh - 3.14159265361894");
    is_approx(tanh(DifferentReal.new(3.92699081702367)), 0.999223894878698, "tanh(DifferentReal) - 3.92699081702367");
}

{
    # FatRat tests
    is_approx((4.7123889804284).FatRat.tanh, 0.999838613988647, "FatRat.tanh - 4.7123889804284");
    is_approx(tanh((5.49778714383314).FatRat), 0.999966448999799, "tanh(FatRat) - 5.49778714383314");
}


# atanh tests

for @sines -> $angle
{
    next if abs(cosh($angle.key())) < 1e-6;
    my $desired-result = sinh($angle.key()) / cosh($angle.key());

    # Num.atanh tests -- thorough
    is_approx($desired-result.Num.atanh.tanh, $desired-result, 
              "Num.atanh - {$angle.key()}");
    
    # Num.atanh(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.atanh.tanh, $z, 
                  "Complex.atanh - $z");
    }
}
        
{
    # Num tests
    is_approx(atanh((0.480472778160188).Num), 0.523598775603156, "atanh(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((0.655794202636825).Rat(1e-9)).atanh, 0.785398163404734, "Rat.atanh - 0.785398163404734");
    is_approx(atanh((0.480472778160188).Rat(1e-9)), 0.523598775603156, "atanh(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(atanh((0.785398163404734 + 2i).Complex), 0.143655432578432 + 1.15296697280152i, "atanh(Complex) - 0.143655432578432 + 1.15296697280152i");
}

{
    # Str tests
    is_approx(((0.480472778160188).Str).atanh, 0.523598775603156, "Str.atanh - 0.523598775603156");
    is_approx(atanh((0.655794202636825).Str), 0.785398163404734, "atanh(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).atanh, 0.100612672097949 + 1.12836985373239i, "NotComplex.atanh - 0.100612672097949 + 1.12836985373239i");
    is_approx(atanh(NotComplex.new(0.785398163404734 + 2i)), 0.143655432578432 + 1.15296697280152i, "atanh(NotComplex) - 0.143655432578432 + 1.15296697280152i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(0.480472778160188)).atanh, 0.523598775603156, "DifferentReal.atanh - 0.523598775603156");
    is_approx(atanh(DifferentReal.new(0.655794202636825)), 0.785398163404734, "atanh(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((0.480472778160188).FatRat).atanh, 0.523598775603156, "FatRat.atanh - 0.523598775603156");
    is_approx(atanh((0.655794202636825).FatRat), 0.785398163404734, "atanh(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/tan.t����������������������������������������������������������������0000664�0001750�0001750�00000013732�12224265625�016275� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# WARNING:
# This is a generated file and should not be edited directly.
# look into generate-tests.pl instead

use v6;
use Test;

sub degrees-to-radians($x) {
    $x * (312689/99532) / 180;
}

my @sines = (
    degrees-to-radians(-360) => 0,
    degrees-to-radians(135 - 360) => 1/2*sqrt(2),
    degrees-to-radians(330 - 360) => -0.5,
    degrees-to-radians(0) => 0,
    degrees-to-radians(30) => 0.5,
    degrees-to-radians(45) => 1/2*sqrt(2),
    degrees-to-radians(90) => 1,
    degrees-to-radians(135) => 1/2*sqrt(2),
    degrees-to-radians(180) => 0,
    degrees-to-radians(225) => -1/2*sqrt(2),
    degrees-to-radians(270) => -1,
    degrees-to-radians(315) => -1/2*sqrt(2),
    degrees-to-radians(360) => 0,
    degrees-to-radians(30 + 360) => 0.5,
    degrees-to-radians(225 + 360) => -1/2*sqrt(2),
    degrees-to-radians(720) => 0
);

my @cosines = @sines.map({; $_.key - degrees-to-radians(90) => $_.value }); #OK

my @sinhes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) - exp(-$_.key)) / 2.0 });

my @coshes = @sines.grep({ $_.key < degrees-to-radians(500) }).map({; $_.key => #OK
                                                (exp($_.key) + exp(-$_.key)) / 2.0 });

class NotComplex is Cool {
    has $.value;

    multi method new(Complex $value is copy) {
        self.bless(:$value);
    }

    multi method Numeric() {
        self.value;
    }
}

class DifferentReal is Real {
    has $.value;

    multi method new($value is copy) {
        self.bless(:$value);
    }

    multi method Bridge() {
        self.value.Num;
    }
}            



# tan tests

for @sines -> $angle
{
    next if abs(cos($angle.key())) < 1e-6;
    my $desired-result = sin($angle.key()) / cos($angle.key());

    # Num.tan tests -- very thorough
    is_approx($angle.key().tan, $desired-result, 
              "Num.tan - {$angle.key()}");

    # Complex.tan tests -- also very thorough
    my Complex $zp0 = $angle.key + 0.0i;
    my Complex $sz0 = $desired-result + 0i;
    my Complex $zp1 = $angle.key + 1.0i;
    my Complex $sz1 = { sin($_) / cos($_) }($zp1);
    my Complex $zp2 = $angle.key + 2.0i;
    my Complex $sz2 = { sin($_) / cos($_) }($zp2);
    
    is_approx($zp0.tan, $sz0, "Complex.tan - $zp0");
    is_approx($zp1.tan, $sz1, "Complex.tan - $zp1");
    is_approx($zp2.tan, $sz2, "Complex.tan - $zp2");
}


{
    is(tan(Inf), NaN, "tan(Inf) -");
    is(tan(-Inf), NaN, "tan(-Inf) -");
}
        
{
    # Num tests
    is_approx(tan((-6.28318530723787).Num), -5.82864638634609e-11, "tan(Num) - -6.28318530723787");
}

{
    # Rat tests
    is_approx((-3.92699081702367).Rat(1e-9).tan, -1.00000000007286, "Rat.tan - -3.92699081702367");
    is_approx(tan((-0.523598775603156).Rat(1e-9)), -0.577350269196102, "tan(Rat) - -0.523598775603156");
}

{
    # Complex tests
    is_approx(tan((0 + 2i).Complex), 0 + 0.964027580075817i, "tan(Complex) - 0 + 2i");
}

{
    # Str tests
    is_approx((0.523598775603156).Str.tan, 0.577350269196102, "Str.tan - 0.523598775603156");
    is_approx(tan((0.785398163404734).Str), 1.00000000001457, "tan(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx(NotComplex.new(2.3561944902142 + 2i).tan, -0.0366189934736279 + 0.999329299737467i, "NotComplex.tan - 2.3561944902142 + 2i");
    is_approx(tan(NotComplex.new(3.14159265361894 + 2i)), 2.05899337486384e-12 + 0.964027580075817i, "tan(NotComplex) - 3.14159265361894 + 2i");
}

{
    # DifferentReal tests
    is_approx(DifferentReal.new(3.92699081702367).tan, 1.00000000007286, "DifferentReal.tan - 3.92699081702367");
    is_approx(tan(DifferentReal.new(5.49778714383314)), -0.999999999897998, "tan(DifferentReal) - 5.49778714383314");
}

{
    # FatRat tests
    is_approx((6.28318530723787).FatRat.tan, 5.82864638634609e-11, "FatRat.tan - 6.28318530723787");
    is_approx(tan((6.80678408284103).FatRat), 0.577350269273818, "tan(FatRat) - 6.80678408284103");
}


# atan tests

for @sines -> $angle
{
    next if abs(cos($angle.key())) < 1e-6;
    my $desired-result = sin($angle.key()) / cos($angle.key());

    # Num.atan tests -- thorough
    is_approx($desired-result.Num.atan.tan, $desired-result, 
              "Num.atan - {$angle.key()}");
    
    # Num.atan(Complex) tests -- thorough
    for ($desired-result + 0i, $desired-result + .5i, $desired-result + 2i) -> $z {
        is_approx($z.atan.tan, $z, 
                  "Complex.atan - $z");
    }
}
        
{
    # Num tests
    is_approx(atan((0.577350269196102).Num), 0.523598775603156, "atan(Num) - 0.523598775603156");
}

{
    # Rat tests
    is_approx(((1.00000000001457).Rat(1e-9)).atan, 0.785398163404734, "Rat.atan - 0.785398163404734");
    is_approx(atan((0.577350269196102).Rat(1e-9)), 0.523598775603156, "atan(Rat) - 0.523598775603156");
}

{
    # Complex tests
    is_approx(atan((0.785398163404734 + 2i).Complex), 1.36593583676998 + 0.445759203696597i, "atan(Complex) - 1.36593583676998 + 0.445759203696597i");
}

{
    # Str tests
    is_approx(((0.577350269196102).Str).atan, 0.523598775603156, "Str.atan - 0.523598775603156");
    is_approx(atan((1.00000000001457).Str), 0.785398163404734, "atan(Str) - 0.785398163404734");
}

{
    # NotComplex tests
    is_approx((NotComplex.new(0.523598775603156 + 2i)).atan, 1.41601859067084 + 0.496236956634457i, "NotComplex.atan - 1.41601859067084 + 0.496236956634457i");
    is_approx(atan(NotComplex.new(0.785398163404734 + 2i)), 1.36593583676998 + 0.445759203696597i, "atan(NotComplex) - 1.36593583676998 + 0.445759203696597i");
}

{
    # DifferentReal tests
    is_approx((DifferentReal.new(0.577350269196102)).atan, 0.523598775603156, "DifferentReal.atan - 0.523598775603156");
    is_approx(atan(DifferentReal.new(1.00000000001457)), 0.785398163404734, "atan(DifferentReal) - 0.785398163404734");
}

{
    # FatRat tests
    is_approx(((0.577350269196102).FatRat).atan, 0.523598775603156, "FatRat.atan - 0.523598775603156");
    is_approx(atan((1.00000000001457).FatRat), 0.785398163404734, "atan(FatRat) - 0.785398163404734");
}

done;

# vim: ft=perl6 nomodifiable
��������������������������������������rakudo-2013.12/t/spec/S32-trig/trig_functions�������������������������������������������������������0000664�0001750�0001750�00000004373�12224265625�020307� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Simple file to control trig test creation.

Function: sin
loop_over: @sines
desired_result: $angle.value
end-setup
complex_check: { (exp($_ * 1i) - exp(-$_ * 1i)) / 2i }
End

Function: cos
loop_over: @cosines
desired_result: $angle.value
end-setup
complex_check: { (exp($_ * 1i) + exp(-$_ * 1i)) / 2 }
End

Function: tan
loop_over: @sines
skip: abs(cos($angle)) < 1e-6
desired_result: sin($angle.key()) / cos($angle.key())
end-setup
complex_check: { sin($_) / cos($_) }
End

Function: sec
loop_over: @cosines
skip: abs(cos($angle)) < 1e-6
desired_result: 1.0 / cos($angle.key())
end-setup
rational_inverse_tests: (-3/2, -2/2, 2/2, 3/2)
complex_check: { 1.0 / cos($_) }
End

Function: cosec
loop_over: @sines
skip: abs(sin($angle)) < 1e-6
desired_result: 1.0 / sin($angle.key())
end-setup
rational_inverse_tests: (-3/2, -2/2, 2/2, 3/2)
complex_check: { 1.0 / sin($_) }
End

Function: cotan
loop_over: @sines
skip: abs(sin($angle)) < 1e-6
desired_result: cos($angle.key()) / sin($angle.key())
end-setup
complex_check: { cos($_) / sin($_) }
End

Function: sinh
loop_over: @sinhes
desired_result: $angle.value
end-setup
complex_check: { (exp($_) - exp(-$_)) / 2 }
plus_inf: Inf
minus_inf: -Inf
End

Function: cosh
loop_over: @coshes
desired_result: $angle.value
end-setup
rational_inverse_tests: (2/2, 3/2, 4/2, 5/2)
complex_check: { (exp($_) + exp(-$_)) / 2 }
plus_inf: Inf
minus_inf: Inf
End

Function: tanh
loop_over: @sines
skip: abs(cosh($angle)) < 1e-6
desired_result: sinh($angle.key()) / cosh($angle.key())
end-setup
rational_inverse_tests: (-2/2, -1/2, 0/1, 1/2)
complex_check: { sinh($_) / cosh($_) }
plus_inf: 1
minus_inf: -1
End

Function: sech
loop_over: @cosines
skip: abs(cosh($angle)) < 1e-6
desired_result: 1.0 / cosh($angle.key())
end-setup
rational_inverse_tests: (1/4, 1/2, 3/4, 2/2)
complex_check: { 1.0 / cosh($_) }
plus_inf: 0
minus_inf: 0
End

Function: cosech
loop_over: @sines
skip: abs(sinh($angle)) < 1e-6
desired_result: 1.0 / sinh($angle.key())
end-setup
complex_check: { 1.0 / sinh($_) }
plus_inf: 0
minus_inf: "-0"
End

Function: cotanh
loop_over: @sines
skip: abs(sinh($angle)) < 1e-6
desired_result: cosh($angle.key()) / sinh($angle.key())
end-setup
rational_inverse_tests: (-4/2, -3/2, 3/2, 4/2)
complex_check: { cosh($_) / sinh ($_) }
plus_inf: 1
minus_inf: -1
End
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/S32-trig/TrigTestSupport������������������������������������������������������0000664�0001750�0001750�00000004327�12224265625�020413� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use v6;
use Test;
plan *;

class AngleAndResult
{
    has $.angle_in_degrees;
    has $.result;

    our @radians-to-whatever = (1, 180 / pi, 200 / pi, 1 / (2 * pi));
    our @degrees-to-whatever = ((312689/99532) / 180, 1, 200 / 180, 1 / 360);
    our @degrees-to-whatever-num = @degrees-to-whatever.map({ .Num });

    multi method new(Int $angle_in_degrees is copy, $result is copy) {
        self.bless(:$angle_in_degrees, :$result);
    }

    multi method perl() {
        "AngleAndResult.new($.angle_in_degrees, $.result)";
    }

    method complex($imaginary_part_in_radians, $base) {
        my $z_in_radians = $.angle_in_degrees / 180.0 * pi + ($imaginary_part_in_radians)i;
		$z_in_radians * @radians-to-whatever[$base];
    }
    
    method num($base) {
		$.angle_in_degrees * @degrees-to-whatever-num[$base];
    }
    
    method rat($base) {
		$.angle_in_degrees * @degrees-to-whatever[$base];
    }
    
    method int($base) {
        $.angle_in_degrees;
    }
    
    method str($base) {
	    ($.angle_in_degrees * @degrees-to-whatever-num[$base]).Str;
    }
}

my @sines = ( 
    AngleAndResult.new(-360, 0),
    AngleAndResult.new(135 - 360, 1/2*sqrt(2)),
    AngleAndResult.new(330 - 360, -0.5),
    AngleAndResult.new(0, 0),
    AngleAndResult.new(30, 0.5),
    AngleAndResult.new(45, 1/2*sqrt(2)),
    AngleAndResult.new(90, 1),
    AngleAndResult.new(135, 1/2*sqrt(2)),
    AngleAndResult.new(180, 0),
    AngleAndResult.new(225, -1/2*sqrt(2)),
    AngleAndResult.new(270, -1),
    AngleAndResult.new(315, -1/2*sqrt(2)),
    AngleAndResult.new(360, 0),
    AngleAndResult.new(30 + 360, 0.5),
    AngleAndResult.new(225 + 360, -1/2*sqrt(2)),
    AngleAndResult.new(720, 0)
);

my @cosines = @sines.map({ AngleAndResult.new($_.angle_in_degrees - 90, $_.result) });

my @sinhes = @sines.grep({ $_.angle_in_degrees < 500 }).map({ AngleAndResult.new($_.angle_in_degrees, 
                                             (exp($_.num(Radians)) - exp(-$_.num(Radians))) / 2.0)});

my @coshes = @sines.grep({ $_.angle_in_degrees < 500 }).map({ AngleAndResult.new($_.angle_in_degrees, 
                                             (exp($_.num(Radians)) + exp(-$_.num(Radians))) / 2.0)});

my @official_bases = (Radians, Degrees, Gradians, Circles);
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spectest.data����������������������������������������������������������������������0000664�0001750�0001750�00000051677�12255243310�015550� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# this is a list of all spec tests that are supposed to pass
# on current rakudo.
# empty lines and those beginning with a # are ignored
#
# we don't add some files here, although all tests might pass right now
#
# Each file may have one or more markers that deselects the test:
#     icu    - run tests only if --icu=1      (default is 1)
#     long   - run tests only if --long=1     (default is 1)
#     stress - run tests only if --stress=1   (default is 0)
# See the "make quicktest" and "make stresstest" targets in
# build/Makefile.in for examples of use.

S01-perl-5-integration/basic.t 
S02-lexical-conventions/begin_end_pod.t
S02-lexical-conventions/bom.t
S02-lexical-conventions/comments.t
S02-lexical-conventions/end-pod.t
S02-lexical-conventions/minimal-whitespace.t
S02-lexical-conventions/one-pass-parsing.t
S02-lexical-conventions/pod-in-multi-line-exprs.t
S02-lexical-conventions/sub-block-parsing.t
S02-lexical-conventions/unicode.t                          # icu
S02-lexical-conventions/unicode-whitespace.t
S02-lexical-conventions/unspace.t
S02-lists/tree.t
S02-literals/array-interpolation.t
S02-literals/autoref.t
S02-literals/char-by-name.t # icu
S02-literals/char-by-number.t
S02-literals/fmt-interpolation.t
S02-literals/hash-interpolation.t
S02-literals/hex_chars.t
S02-literals/listquote.t
S02-literals/listquote-whitespace.t
S02-literals/misc-interpolation.t
S02-literals/numeric.t
S02-literals/pair-boolean.t
S02-literals/pairs.t
S02-literals/quoting.t
S02-literals/quoting-unicode.t          # icu
S02-literals/radix.t
S02-literals/string-interpolation.t
S02-literals/sub-calls.t
S02-literals/subscript.t
S02-literals/types.t
S02-literals/underscores.t
S02-literals/version.t
S02-magicals/args.t
S02-magicals/config.t
S02-magicals/dollar_bang.t
S02-magicals/dollar-underscore.t
S02-magicals/env.t
S02-magicals/file_line.t
S02-magicals/pid.t
S02-magicals/progname.t
S02-magicals/sub.t
S02-magicals/vm.t
S02-names/bare-sigil.t
S02-names/caller.t
S02-names/identifier.t
S02-names/indirect.t
S02-names/is_default.t
S02-names/is_dynamic.t
S02-names/name.t
S02-names/our.t
S02-names/pseudo.t
S02-names/symbolic-deref.t
S02-names-vars/contextual.t
S02-names-vars/fmt.t
S02-names-vars/list_array_perl.t
S02-names-vars/names.t
S02-names-vars/perl.t                              # icu
S02-names-vars/signature.t
S02-names-vars/variables-and-packages.t
S02-names-vars/varnames.t
S02-one-pass-parsing/less-than.t
S02-packages/package-lookup.t
S02-types/anon_block.t
S02-types/array_extending.t
S02-types/array_ref.t
S02-types/array.t
S02-types/assigning-refs.t
S02-types/autovivification.t
S02-types/bag.t
S02-types/baghash.t
S02-types/bool.t
S02-types/capture.t
S02-types/catch_type_cast_mismatch.t
S02-types/declare.t
S02-types/deprecations.t
S02-types/fatrat.t
S02-types/flattening.t
S02-types/hash_ref.t
S02-types/hash.t
S02-types/infinity.t
S02-types/instants-and-durations.t
S02-types/isDEPRECATED.t
S02-types/lazy-lists.t
S02-types/lists.t
S02-types/mix.t
S02-types/mixhash.t
S02-types/mixed_multi_dimensional.t
S02-types/multi_dimensional_array.t
S02-types/nan.t
S02-types/native.t
S02-types/nested_arrays.t
S02-types/nested_pairs.t
S02-types/nil.t
S02-types/num.t
S02-types/pair.t
S02-types/parcel.t
S02-types/parsing-bool.t
S02-types/range.t
S02-types/set.t
S02-types/sethash.t
S02-types/sigils-and-types.t
S02-types/subscripts_and_context.t
S02-types/subset.t
S02-types/type.t
S02-types/undefined-types.t
S02-types/version.t                     # icu
S02-types/whatever.t
S03-binding/arrays.t
S03-binding/attributes.t
S03-binding/closure.t
S03-binding/hashes.t
S03-binding/nested.t
S03-binding/ro.t
S03-binding/scalars.t
S03-feeds/basic.t
S03-junctions/associative.t
S03-junctions/autothreading.t
S03-junctions/boolean-context.t
S03-junctions/misc.t
S03-metaops/cross.t
S03-metaops/eager-hyper.t
S03-metaops/hyper.t
S03-metaops/not.t
S03-metaops/reduce.t
S03-metaops/reverse.t
S03-metaops/zip.t
S03-operators/adverbial-modifiers.t
S03-operators/also.t
S03-operators/andthen.t
S03-operators/arith.t
S03-operators/assign-is-not-binding.t
S03-operators/assign.t
S03-operators/autoincrement-range.t # icu
S03-operators/autoincrement.t
S03-operators/autovivification.t
S03-operators/bag.t
S03-operators/basic-types.t
S03-operators/bit.t
S03-operators/boolean-bitwise.t
S03-operators/brainos.t
S03-operators/buf.t
S03-operators/chained-declarators.t
S03-operators/cmp.t
S03-operators/comparison-simple.t
S03-operators/comparison.t
S03-operators/context-forcers.t
S03-operators/context.t
S03-operators/equality.t
S03-operators/eqv.t
S03-operators/flip-flop.t
S03-operators/gcd.t
S03-operators/div.t
S03-operators/identity.t
S03-operators/increment.t
S03-operators/inplace.t
S03-operators/is-divisible-by.t
S03-operators/lcm.t
S03-operators/list-quote-junction.t
S03-operators/minmax.t
S03-operators/misc.t
S03-operators/names.t
S03-operators/nesting.t
S03-operators/not.t
S03-operators/overflow.t
S03-operators/precedence.t
S03-operators/range-basic.t
S03-operators/range-int.t                       # stress
S03-operators/range.t
S03-operators/reduce-le1arg.t
S03-operators/relational.t
S03-operators/repeat.t
S03-operators/scalar-assign.t
S03-operators/set.t
S03-operators/short-circuit.t
S03-operators/so.t
S03-operators/spaceship-and-containers.t
S03-operators/spaceship.t
S03-operators/subscript-adverbs.t
S03-operators/subscript-vs-lt.t
S03-operators/ternary.t
S03-operators/value_equivalence.t
S03-sequence/arity0.t
S03-sequence/arity-2-or-more.t
S03-sequence/basic.t
# S03-sequence/limit-arity-2-or-more.t # err: Not enough positional parameters passed; got 1 but expected 2
S03-sequence/misc.t
S03-sequence/nonnumeric.t
S03-smartmatch/any-any.t
S03-smartmatch/any-array.t
S03-smartmatch/any-bool.t
S03-smartmatch/any-callable.t
S03-smartmatch/any-complex.t
S03-smartmatch/any-hash-pair.t
S03-smartmatch/any-method.t
S03-smartmatch/any-num.t
S03-smartmatch/any-pair.t
S03-smartmatch/any-str.t
S03-smartmatch/any-sub.t
S03-smartmatch/any-type.t
S03-smartmatch/array-array.t
S03-smartmatch/array-hash.t
S03-smartmatch/capture-signature.t
S03-smartmatch/disorganized.t
S03-smartmatch/hash-hash.t
S03-smartmatch/range-range.t
S03-smartmatch/regex-hash.t
S03-smartmatch/scalar-hash.t
S03-smartmatch/signature-signature.t
S04-blocks-and-statements/let.t
S04-blocks-and-statements/pointy-rw.t
S04-blocks-and-statements/pointy.t
S04-blocks-and-statements/temp.t
S04-declarations/constant.t
S04-declarations/implicit-parameter.t
S04-declarations/multiple.t
S04-declarations/my.t
S04-declarations/our.t
S04-declarations/state.t
S04-declarations/will.t
S04-exception-handlers/catch.t
S04-exceptions/fail.t
S04-phasers/ascending-order.t
S04-phasers/begin.t
S04-phasers/check.t
S04-phasers/descending-order.t
S04-phasers/end.t
S04-phasers/enter-leave.t
S04-phasers/eval-in-begin.t
S04-phasers/first.t
S04-phasers/in-eval.t
S04-phasers/keep-undo.t
S04-phasers/multiple.t
S04-phasers/next.t
S04-phasers/pre-post.t
S04-phasers/rvalue.t
S04-statement-modifiers/for.t
S04-statement-modifiers/given.t 
S04-statement-modifiers/if.t
S04-statement-modifiers/unless.t
S04-statement-modifiers/until.t
S04-statement-modifiers/values_in_bool_context.t
S04-statement-modifiers/while.t
S04-statement-parsing/hash.t
S04-statements/do.t
S04-statements/for-scope.t
S04-statements/for.t
S04-statements/for_with_only_one_item.t
S04-statements/gather.t
S04-statements/given.t
S04-statements/if.t
S04-statements/last.t
S04-statements/loop.t
S04-statements/map-and-sort-in-for.t
S04-statements/next.t
S04-statements/no-implicit-block.t
S04-statements/once.t
S04-statements/redo.t
S04-statements/repeat.t
S04-statements/return.t
S04-statements/sink.t
S04-statements/terminator.t
S04-statements/try.t
S04-statements/unless.t
S04-statements/until.t
S04-statements/while.t
S05-capture/caps.t
S05-capture/dot.t
S05-capture/match-object.t
S05-capture/named.t
S05-capture/subrule.t
S05-grammar/action-stubs.t
S05-grammar/inheritance.t
S05-grammar/methods.t
S05-grammar/namespace.t
S05-grammar/parse_and_parsefile.t
S05-grammar/polymorphism.t
S05-grammar/protoregex.t
S05-grammar/protos.t
S05-grammar/signatures.t
S05-grammar/ws.t
S05-interpolation/lexicals.t
S05-interpolation/regex-in-variable.t
S05-mass/charsets.t
S05-mass/named-chars.t                                     # icu
S05-mass/properties-block.t                                # icu
S05-mass/properties-derived.t                              # icu
S05-mass/properties-general.t                              # icu
S05-mass/properties-script.t                               # icu
S05-mass/recursive.t
S05-mass/rx.t                                              # icu
S05-mass/stdrules.t
S05-match/arrayhash.t
S05-match/blocks.t
S05-match/capturing-contexts.t
S05-match/make.t
S05-match/non-capturing.t
# S05-match/perl.t # err: Default constructor only takes named arguments
S05-match/positions.t
S05-metachars/closure.t
S05-metachars/line-anchors.t
S05-metachars/newline.t
S05-metachars/tilde.t
S05-metasyntax/angle-brackets.t
S05-metasyntax/assertions.t
S05-metasyntax/changed.t
S05-metasyntax/charset.t
S05-metasyntax/delimiters.t
S05-metasyntax/interpolating-closure.t
S05-metasyntax/litvar.t
S05-metasyntax/longest-alternative.t
S05-metasyntax/lookaround.t
S05-metasyntax/null.t
S05-metasyntax/prior.t
S05-metasyntax/proto-token-ltm.t
S05-metasyntax/regex.t
S05-metasyntax/repeat.t
S05-metasyntax/sequential-alternation.t
S05-metasyntax/single-quotes.t
S05-metasyntax/unknown.t
S05-modifier/continue.t
S05-modifier/counted-match.t
S05-modifier/counted.t
S05-modifier/global.t
S05-modifier/ignorecase.t  # icu
S05-modifier/ii.t
S05-modifier/overlapping.t
S05-modifier/perl5_0.t
S05-modifier/perl5_1.t
# S05-modifier/perl5_2.t
# S05-modifier/perl5_3.t
# S05-modifier/perl5_4.t
S05-modifier/perl5_5.t
S05-modifier/perl5_7.t
S05-modifier/perl5_8.t
S05-modifier/pos.t
S05-modifier/repetition.t
S05-modifier/sigspace.t
S05-substitution/match.t
S05-substitution/subst.t # icu
S05-transliteration/trans.t
S05-transliteration/with-closure.t
S06-advanced/callframe.t
S06-advanced/callsame.t
S06-advanced/lexical-subs.t
S06-advanced/recurse.t
S06-advanced/return.t
S06-advanced/wrap.t
S06-currying/assuming-and-mmd.t
S06-currying/named.t
S06-macros/errors.t
S06-macros/quasi-blocks.t
S06-macros/unquoting.t
S06-macros/opaque-ast.t
S06-multi/lexical-multis.t
S06-multi/positional-vs-named.t
S06-multi/proto.t
S06-multi/redispatch.t
S06-multi/syntax.t
S06-multi/type-based.t
S06-multi/unpackability.t
S06-multi/value-based.t
S06-operator-overloading/imported-subs.t
S06-operator-overloading/methods.t
S06-operator-overloading/semicolon.t
S06-operator-overloading/sub.t
S06-operator-overloading/workout.t
S06-other/anon-hashes-vs-blocks.t
S06-other/introspection.t
S06-other/main-eval.t
S06-other/main.t
S06-other/main-usage.t
S06-other/misc.t
S06-routine-modifiers/lvalue-subroutines.t
S06-routine-modifiers/proxy.t
S06-routine-modifiers/scoped-named-subs.t
S06-signature/arity.t
S06-signature/closure-over-parameters.t
S06-signature/closure-parameters.t
S06-signature/code.t
S06-signature/defaults.t
S06-signature/errors.t
S06-signature/introspection.t
S06-signature/mixed-placeholders.t
S06-signature/multidimensional.t
S06-signature/named-parameters.t
S06-signature/named-placeholders.t
S06-signature/named-renaming.t
S06-signature/optional.t
S06-signature/outside-subroutine.t
S06-signature/passing-arrays.t
S06-signature/passing-hashes.t
S06-signature/positional-placeholders.t
S06-signature/positional.t
S06-signature/scalar-type.t
S06-signature/sigilless.t
S06-signature/slurpy-and-interpolation.t
S06-signature/slurpy-params.t
S06-signature/slurpy-placeholders.t
S06-signature/sub-ref.t
S06-signature/tree-node-parameters.t
S06-signature/type-capture.t
S06-signature/types.t
S06-signature/unpack-array.t
S06-signature/unpack-object.t
S06-signature/unspecified.t
S06-traits/is-assoc.t
S06-traits/is-copy.t
S06-traits/is-readonly.t
S06-traits/is-rw.t
S06-traits/misc.t
S06-traits/precedence.t
S06-traits/slurpy-is-rw.t
S09-autovivification/autoincrement.t
S09-autovivification/autovivification.t
S09-hashes/objecthash.t
S09-subscript/slice.t
S09-typed-arrays/arrays.t
S09-typed-arrays/hashes.t
S10-packages/basic.t
S10-packages/joined-namespaces.t
S10-packages/use-with-class.t
# S11-modules/export.t # err: Could not find symbol 'Foo::&Foo_exp_parens
S11-modules/importing.t
S11-modules/import-multi.t
S11-modules/import-tag.t
S11-modules/import.t
S11-modules/lexical.t
S11-modules/need.t
S11-modules/nested.t
S11-modules/require.t
S12-attributes/class.t
S12-attributes/clone.t
S12-attributes/defaults.t
S12-attributes/delegation.t
S12-attributes/inheritance.t
S12-attributes/instance.t
S12-attributes/mutators.t
S12-attributes/recursive.t
S12-attributes/undeclared.t
S12-class/anonymous.t
S12-class/attributes.t
S12-class/augment-supersede.t
S12-class/basic.t
S12-class/declaration-order.t
S12-class/extending-arrays.t
S12-class/inheritance-class-methods.t
S12-class/inheritance.t
S12-class/instantiate.t
S12-class/interface-consistency.t
S12-class/lexical.t
S12-class/literal.t
S12-class/magical-vars.t
S12-class/mro.t
S12-class/namespaced.t
S12-class/open.t
# S12-class/parent_attributes.t # err: Method 'at_key' not found for invocant of class 'Foo'
S12-class/rw.t
S12-class/self-inheritance.t
S12-class/stubs.t
S12-class/type-object.t
S12-construction/autopairs.t
S12-construction/BUILD.t
S12-construction/construction.t
S12-construction/named-params-in-BUILD.t
S12-construction/new.t
S12-enums/anonymous.t
S12-enums/as-role.t
S12-enums/basic.t
S12-enums/misc.t
S12-enums/non-int.t
S12-enums/pseudo-functional.t
S12-enums/thorough.t
S12-introspection/attributes.t
S12-introspection/can.t
S12-introspection/definite.t
S12-introspection/meta-class.t
S12-introspection/methods.t
S12-introspection/parents.t
S12-introspection/roles.t
S12-introspection/walk.t
S12-introspection/WHAT.t
S12-methods/accessors.t
S12-methods/attribute-params.t
S12-methods/calling_sets.t
S12-methods/calling_syntax.t
S12-methods/chaining.t
S12-methods/class-and-instance.t
S12-methods/delegation.t
S12-methods/default-trait.t
S12-methods/defer-call.t
S12-methods/defer-next.t
S12-methods/how.t
S12-methods/indirect_notation.t
S12-methods/instance.t
S12-methods/lastcall.t
S12-methods/lvalue.t
S12-methods/method-vs-sub.t 
S12-methods/multi.t
S12-methods/parallel-dispatch.t
S12-methods/private.t
S12-methods/qualified.t
S12-methods/submethods.t
S12-methods/syntax.t
S12-methods/topic.t
S12-methods/trusts.t
S12-methods/typed-attributes.t
S12-methods/what.t
S12-subset/multi-dispatch.t
S12-subset/subtypes.t
S13-overloading/metaoperators.t
S13-overloading/operators.t
S13-overloading/typecasting-long.t
S13-overloading/typecasting-mixed.t
S13-overloading/typecasting-short.t
S13-type-casting/methods.t
S14-roles/anonymous.t
S14-roles/attributes.t
S14-roles/basic.t
S14-roles/bool.t
S14-roles/composition.t
S14-roles/conflicts.t
S14-roles/crony.t
S14-roles/instantiation.t
S14-roles/lexical.t
S14-roles/mixin.t
S14-roles/namespaced.t 
S14-roles/parameterized-basic.t
S14-roles/parameterized-mixin.t
S14-roles/parameterized-type.t
S14-roles/parameter-subtyping.t
S14-roles/stubs.t
S14-roles/submethods.t
S14-traits/attributes.t
# S14-traits/package.t # err: Invalid typename in parameter declaration
S14-traits/routines.t
# S14-traits/variables.t # err: Invalid typename in parameter declaration
S16-filehandles/chmod.t
S16-filehandles/filestat.t
S16-filehandles/filetest.t
S16-filehandles/io_in_for_loops.t
S16-filehandles/io_in_while_loops.t
S16-filehandles/io.t
S16-filehandles/mkdir_rmdir.t
S16-filehandles/open.t
S16-filehandles/unlink.t
S16-io/bare-say.t
S16-io/basic-open.t
S16-io/cwd.t
S16-io/getc.t
S16-io/say-and-ref.t
S16-io/say.t
S16-io/tmpdir.t
S16-unfiled/rebindstdhandles.t
S17-concurrency/channel.t    # jvm
S17-concurrency/lock.t       # jvm 
S17-concurrency/promise.t    # jvm
S17-concurrency/scheduler.t  # jvm
S17-concurrency/supply.t     # jvm
S17-concurrency/thread.t     # jvm
S17-concurrency/winner.t     # jvm
S19-command-line/dash-e.t # icu
S19-command-line/help.t
S24-testing/0-compile.t
S26-documentation/01-delimited.t
S26-documentation/02-paragraph.t
S26-documentation/03-abbreviated.t
S26-documentation/04-code.t
S26-documentation/05-comment.t
S26-documentation/06-lists.t
S26-documentation/07-tables.t
S26-documentation/08-formattingcodes.t
S26-documentation/09-configuration.t
S26-documentation/10-doc-cli.t
S26-documentation/why.t
S28-named-variables/cwd.t
S28-named-variables/inc.t
S29-any/cmp.t
S29-any/isa.t
S29-context/die.t
S29-context/eval.t
S29-context/exit-in-if.t
S29-context/exit.t
S29-context/sleep.t
S29-conversions/hash.t
S29-conversions/ord_and_chr.t                              #icu
S29-os/system.t
S32-array/bool.t
S32-array/create.t
S32-array/delete.t
S32-array/delete-adverb.t
S32-array/delete-adverb-native.t
S32-array/elems.t
S32-array/end.t
S32-array/exists-adverb.t
S32-array/keys_values.t
S32-array/kv.t
S32-array/pairs.t
S32-array/perl.t
S32-array/pop.t
S32-array/push.t
S32-array/rotate.t
S32-array/shift.t
S32-array/splice.t
S32-array/unshift.t
S32-basics/warn.t
S32-container/roundrobin.t
S32-container/zip.t
S32-exceptions/misc.t
S32-hash/delete.t
S32-hash/delete-adverb.t
S32-hash/exists.t
S32-hash/exists-adverb.t
S32-hash/invert.t
S32-hash/keys_values.t
S32-hash/kv.t
S32-hash/pairs.t
S32-hash/perl.t
S32-hash/push.t
S32-hash/slice.t
S32-io/chdir.t
S32-io/copy.t
S32-io/dir.t
S32-io/file-tests.t
S32-io/io-spec-unix.t
S32-io/io-spec-win.t
S32-io/io-spec-cygwin.t
S32-io/io-path-unix.t
S32-io/io-path-win.t
S32-io/io-path-cygwin.t
S32-io/io-path.t
S32-io/note.t
S32-io/other.t
S32-io/slurp.t
S32-io/spurt.t
S32-list/categorize.t
S32-list/classify.t
S32-list/create.t
S32-list/combinations.t
S32-list/end.t
S32-list/first.t
S32-list/grep.t
S32-list/join.t
S32-list/map_function_return_values.t
S32-list/map.t
S32-list/minmax.t
S32-list/pick.t
S32-list/reduce.t
S32-list/reverse.t
S32-list/roll.t
S32-list/sort.t
S32-list/uniq.t
S32-list/squish.t
S32-num/abs.t
S32-num/base.t
S32-num/complex.t
S32-num/cool-num.t
S32-num/exp.t
S32-num/expmod.t
S32-num/fatrat.t
S32-num/int.t
S32-num/is-prime.t
S32-num/log.t
S32-num/pi.t
S32-num/polar.t
S32-num/power.t
S32-num/rand.t
S32-num/rat.t
S32-num/real-bridge.t
S32-num/roots.t
S32-num/rounders.t
S32-num/sign.t
S32-num/sqrt.t
S32-num/stringify.t
S32-num/unpolar.t
S32-scalar/defined.t
S32-scalar/perl.t
S32-scalar/undef.t
S32-str/append.t
S32-str/bool.t
S32-str/capitalize.t                                       # icu
S32-str/chomp.t
S32-str/chop.t
S32-str/comb.t                                             # icu
S32-str/encode.t
S32-str/flip.t                                             # icu
S32-str/indent.t                                           # icu
S32-str/index.t
S32-str/lc.t                                               # icu
S32-str/lines.t
S32-str/numeric.t
S32-str/ords.t
S32-str/pack.t
S32-str/pos.t
S32-str/rindex.t
S32-str/samecase.t                                         # icu
S32-str/split-simple.t
S32-str/split.t
S32-str/sprintf.t
S32-str/substr.t                                           # icu
S32-str/substr-rw.t
S32-str/tclc.t                                             # icu
S32-str/trim.t
S32-str/uc.t                                               # icu
S32-str/unpack.t
S32-str/words.t                                            # icu
S32-temporal/calendar.t
S32-temporal/Date.t
S32-temporal/DateTime-Instant-Duration.t
S32-temporal/DateTime.t
S32-temporal/local.t
S32-trig/atan2.t
S32-trig/cosech.t
S32-trig/cosec.t
S32-trig/cosh.t
S32-trig/cos.t
S32-trig/cotanh.t
S32-trig/cotan.t
S32-trig/e.t
S32-trig/pi.t
S32-trig/sech.t
S32-trig/sec.t
S32-trig/simple.t
S32-trig/sinh.t
S32-trig/sin.t
S32-trig/tanh.t
S32-trig/tan.t
integration/99problems-01-to-10.t
integration/99problems-11-to-20.t
integration/99problems-21-to-30.t
integration/99problems-31-to-40.t
integration/99problems-41-to-50.t
integration/99problems-51-to-60.t 
integration/99problems-61-to-70.t
integration/advent2009-day01.t
integration/advent2009-day02.t
integration/advent2009-day03.t
integration/advent2009-day04.t
integration/advent2009-day05.t
integration/advent2009-day06.t
integration/advent2009-day07.t
integration/advent2009-day08.t
integration/advent2009-day09.t
integration/advent2009-day10.t
integration/advent2009-day11.t
integration/advent2009-day12.t
integration/advent2009-day13.t
integration/advent2009-day14.t
integration/advent2009-day15.t
integration/advent2009-day16.t
integration/advent2009-day17.t # stress
integration/advent2009-day18.t
integration/advent2009-day19.t
integration/advent2009-day20.t
integration/advent2009-day22.t
integration/advent2009-day23.t
integration/advent2010-day04.t
integration/code-blocks-as-sub-args.t
integration/error-reporting.t  # icu
integration/lazy-bentley-generator.t
integration/lexical-array-in-inner-block.t
integration/lexicals-and-attributes.t
integration/man-or-boy.t
integration/method-calls-and-instantiation.t
integration/no-indirect-new.t
integration/packages.t
integration/pair-in-array.t
integration/passing-pair-class-to-sub.t
integration/real-strings.t
integration/role-composition-vs-attribute.t
integration/rule-in-class-Str.t
integration/say-crash.t
integration/substr-after-match-in-gather-in-for.t
integration/topic_in_double_loop.t
integration/variables-in-do.t
integration/weird-errors.t
rosettacode/greatest_element_of_a_list.t  
rosettacode/sierpinski_triangle.t
S32-io/IO-Socket-INET.t  # last to prevent load interference
�����������������������������������������������������������������rakudo-2013.12/t/spec/test_summary������������������������������������������������������������������0000775�0001750�0001750�00000067010�12254646735�016504� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl

# Copyright (C) 2004-2011, The Perl Foundation.

##  The "make spectest" target tells us how many tests we failed
##  (hopefully zero!), but doesn't say how many were actually passed.
##  This script runs the spectest tests and summarizes
##  passed, failed, todoed, skipped, executed and planned test results.
##
##  Usage:
##     tools/test_summary [--timing | --view] [--archive tap_archive.tar.gz] <implementation> [testlist]
##
##  The --timing option enables microsecond timing per test saved
##      in docs/test_summary.times.
##  The --view option renders docs/test_summary.times in various reports
##  If supplied, C<testlist> identifies an alternate list of tests
##  to use (e.g., t/localtest.data).

##  Rakudo Note:
##    Using this script with rakudo requires setting the PERL6LIB env var
##    to point to its lib directory so we can find Test.pm

use strict;
use warnings;
use Time::Local;
use Time::HiRes;
use Getopt::Long;

my $timing;
my $view;
my $archive;
unless (GetOptions('timing' => \$timing, 'view' => \$view, 'archive:s' => \$archive)) {
    die "$0 cannot handle the unknown option\n";
}
if ($view) { Simple::Relative::Benchmarking::view(); exit(0); }

my $benchmark;
# Comment out the next line to skip benchmarking; see docs below
$benchmark = Simple::Relative::Benchmarking::begin() if $timing;

# Which implementation are we running?
my $implementation = $ARGV[0] ||
    die "Must specify an implementation";

my $impl_class = $archive ? 'ArchiveRunner' : 'RealRunner';

# Put test names in %tname, with the 't/spec/' removed from the start
# and truncated to 49 characters. Keep track of the maximum name length.
my @tfiles = $impl_class->get_test_names;
my %tname;
@tfiles = sort @tfiles;
my $max = 0;
for my $tfile (@tfiles) {
    my $tname = $tfile;
    $tname =~ s{^t/spec/}{};
    $tname = substr($tname, 0, 49);
    if (length($tname) > $max) {
        $max = length($tname);
    }
    $tname{$tfile} = $tname;
}

# Prepare arrays and hashes to gather and accumulate test statistics
my @col = qw(pass fail todo skip plan spec);
my @syn = qw(S01 S02 S03 S04 S05 S06 S07 S09 S10 S11 S12 S13 S14 S16 S17 S19 S24 S26 S28 S29 S32 int);
my %syn; # number of test scripts per Synopsis
my %sum; # total pass/fail/todo/skip/test/plan per Synposis
my $syn;
for $syn (@syn) {
    $syn{$syn} = 0;
    for my $col (@col) {
        $sum{"$syn-$col"} = 0;
    }
}
$syn = ''; # to reliably trigger the display of column headings

# Execute all test scripts, aggregate the results, display the failures
$| = 1;
my ( @fail, @plan_hint );
my %plan_per_file;
for my $tfile (@tfiles) {
    my $th;
    open($th, '<', $tfile) || die "Can't read $tfile: $!\n";
    my ($pass,$fail,$todo,$skip,$plan,$abort,$bonus) = (0,0,0,0,0,0,0);
    my $no_plan = 0; # planless works, but is unhelpful for statistics
    # http://www.shadowcat.co.uk/blog/matt-s-trout/a-cunning-no_plan/
    while (<$th>) {                # extract the number of tests planned
        if (/^\s*plan\D*(\d+)/) { $plan = $1; last; }
        elsif (/^\s*plan\s+\*;/) { $no_plan = 1; last; }
    }
    close $th or die $!;
    my $tname = $tname{$tfile};
    # Repeat the column headings at the start of each Synopsis
    if ( $syn ne substr($tname, 0, 3) ) {
        $syn  =  substr($tname, 0, 3);
        printf( "%s  pass fail todo skip plan\n", ' ' x $max );
        unless ( exists $syn{$syn} ) {
            push @fail, "note: test_summary.pl \@syn does not have $syn";
        }
    }
    $syn{$syn}++;
    printf "%s%s..", $tname, '.' x ($max - length($tname));
    my @results = split /\n/, $impl_class->run_test($tfile);
    my (%skip, %todopass, %todofail);
    my ($time1, $time2, $testnumber, $test_comment ) = ( 0, 0, 0, '' );
    my @times = (); my @comments = ();
    for (@results) {
        # Pass over the optional line containing "1..$planned"
        if    (/^1\.\.(\d+)/)      { $plan = $1 if $1 > 0; next; }
        # Handle lines containing test times
        if    (/^# t=(\d+)/)  {
            my $microseconds = $1;
            if ( $testnumber > 0 ) {
                # Do this only if the time was after a test result
                $times[   $testnumber] = $microseconds;
                $comments[$testnumber] = $test_comment;
                $testnumber = 0;  # must see require another "ok $n" first
            }
            next;
        }
        # Ignore lines not beginning with "ok $$test" or "not ok $test"
        next unless /^(not )?ok +(\d+)/;
        if    (/#\s*SKIP\s*(.*)/i) { $skip++; $skip{$1}++; }
        elsif (/#\s*TODO\s*(.*)/i) { $todo++;
            my $reason = $1;
            if (/^ok /) { $todopass{$reason}++ }
            else        { $todofail{$reason}++ }
        }
        elsif (/^not ok +(.*)/)    { $fail++; push @fail, "$tname $1"; }
        elsif (/^ok +(\d+) - (.*)$/) {
            $pass++; $testnumber = $1; $test_comment = $2;
        }
        elsif (/^ok +(\d+)$/) {
            $pass++; $testnumber = $1; $test_comment = "";
        }
    }
    my $test = $pass + $fail + $todo + $skip;
    if ($plan > $test) {
        $abort = $plan - $test;
        $fail += $abort;
        push @fail, "$tname aborted $abort test(s)";
    }
    elsif ($plan < $test) {
        $bonus = $test - $plan;
        push @fail, "$tname passed $bonus unplanned test(s)";
    }
    if ($no_plan) {
        push @plan_hint, "'plan *;' could become 'plan $plan;' in $tname";
    }
    printf "%4d %4d %4d %4d %4d\n",
        $pass, $fail, $todo, $skip, $plan;
    $sum{'pass'} += $pass;  $sum{"$syn-pass"} += $pass;
    $sum{'fail'} += $fail;  $sum{"$syn-fail"} += $fail;
    $sum{'todo'} += $todo;  $sum{"$syn-todo"} += $todo;
    $sum{'skip'} += $skip;  $sum{"$syn-skip"} += $skip;
    $sum{'plan'} += $plan;  $sum{"$syn-plan"} += $plan;
    {
        my $f = $tfile;
        $f =~ s/\.$implementation$/.t/;
        $plan_per_file{$f} = $plan;
    }
    for (keys %skip) {
        printf "   %3d skipped: %s\n", $skip{$_}, $_;
    }
    for (keys %todofail) {
        printf "   %3d todo   : %s\n", $todofail{$_}, $_;
    }
    for (keys %todopass) {
        printf "   %3d todo PASSED: %s\n", $todopass{$_}, $_;
    }
    if ($abort) {
        printf "   %3d tests aborted (missing ok/not ok)\n", $abort;
    }
    if ($bonus) {
        printf "   %3d tests more than planned were run\n", $bonus;
    }
    defined $benchmark && $benchmark->log_script_times($tfile,\@times,\@comments);
} # for my $tfile (@tfiles)
defined $benchmark && $benchmark->end(); # finish simple relative benchmarking

# Calculate plan totals from test scripts grouped by Synopsis and overall.
# This ignores any test list and processes all unfudged files in t/spec/.
# Implementing 'no_plan' or 'plan *' in test scripts makes this total
# inaccurate.
for my $syn (sort keys %syn) {
    my $grepcmd = "grep ^plan t/spec/$syn*/* -rHn"; # recurse, always say filename, include line number for troubleshooting
    my @grep_output = `$grepcmd`; # gets an array of all the plan lines
    my $total_tests_planned_per_synopsis = 0;
    for (@grep_output) {
        # Most test scripts have a conventional 'plan 42;' or so near
        # the beginning which is what we need.  Unfortunately some have
        # 'plan $x*$y;' or so, which we cannot dynamically figure out.

        # Example grep output: t/spec/S02-names/our.t:4:plan 10;
        # Extract the filename and plan count from that if possible.
        if ( m/ ^ ([^:]*) : \d+ : plan (.*) $ /x ) {
            my ( $filename, $planexpression ) = ( $1, $2 );
            my $script_planned_tests = 0;
            if ( $filename =~ m/\.t$/ ) {
                if ( $planexpression =~ m/ ^ \s* (\d+) \s* ; $ /x ) {
                    # A conventional 'plan 42;' type of line
                    $script_planned_tests = $1;
                }
                else {
                    # It is some other plan argument, either * or variables.
                    # A workaround is to get the actual number of tests run
                    # from the output and just assume is the same number,
                    # but sometimes that is missing too.
                    if ( exists $plan_per_file{$filename} ) {
                        $script_planned_tests = $plan_per_file{$filename};
                    }
                }
            }
            $total_tests_planned_per_synopsis += $script_planned_tests;
        }
    }
    $sum{"$syn-spec"} = $total_tests_planned_per_synopsis;
    $sum{'spec'}     += $total_tests_planned_per_synopsis;
}

# Planless testing (eg 'plan *;') is useless for static analysis, making
# tools jump through hoops to calculate the number of planned tests.
# This part display hints about the scripts that could easily be edited
# make life easier on the reporting side.
# A test suite author can follow the hints and write the automatically
# counted number of tests into the test script, changing it back from
# planless to planned.

if (@plan_hint) {
    print "----------------\n";
    foreach (@plan_hint) {
        print "    $_\n";
    }
}

# Show test totals grouped by Synopsys, followed by overall totals
print "----------------\n";
my $sumfmt = qq(%-11.11s %6s,%6s,%6s,%6s,%6s,%6s\n);
printf $sumfmt, qq{"Synopsis",}, map { qq{"$_"} } @col;
for my $syn (sort keys %syn) {
    printf $sumfmt, qq{"$syn",}, map { $sum{"$syn-$_"} } @col;
}
my $total = scalar(@tfiles).' regression files';
printf $sumfmt, qq{"total",}, map { $sum{$_} } @col;
print "----------------\n";

# Optionally show the statistics that can be manually appended to
# docs/spectest-progress.csv
if ($ENV{'REV'}) {
    my @gmt = gmtime;
    my $testdate = sprintf '"%4d-%02d-%02d %02d:%02d"', $gmt[5]+1900,
        $gmt[4]+1, $gmt[3], $gmt[2], $gmt[1];
    my $filecount = scalar(@tfiles);
    my $passpercent = 100 * $sum{'pass'} / $sum{'spec'};
    print join(',', $ENV{'REV'}, (map { $sum{$_} } @col),
        $filecount), "\n";
    printf "spectest-progress.csv update: " .
        "%d files, %d (%.1f%% of %d) pass, %d fail\n",
        $filecount, $sum{'pass'}, $passpercent, $sum{'spec'}, $sum{'fail'};
}

# List descriptions of the tests that failed
if (@fail) {
    print "Failure summary:\n";
    foreach (@fail) {
        print "$_\n";
    }
}
else {
    print "No failures!\n";
}

# End of main program

#-------------------- Simple Relative Benchmarking ---------------------

package Simple::Relative::Benchmarking;

# begin
# Initialize simple relative benchmarking.  Called before the first test
sub begin {
    my $timings = shift || 5;    # number of timings to keep (default 5)
    my $self = {};
    my @test_history;
    $self->{'Timings'} = $timings;
    $self->{'Last_test_loaded'} = '';

    if ( open( $self->{'file_in'}, '<', 'docs/test_summary.times') ) {
        my $file_in = $self->{'file_in'};
        my $line = <$file_in>; chomp $line;
        if ( $line =~ m/{"test_.+":\[/i ) { # should be Test_history
            $line = <$file_in>; chomp $line;
            while ( $line =~ m/\s\s(.+\d\d\d\d-\d\d-\d\d.\d\d:\d\d:\d\d.+)/ ) {
                my $history_line = $1;
                $history_line =~ s/,$//; # trim possible trailing comma
                push @test_history, $history_line;
                $line = <$file_in>; chomp $line;
            } # ends on the ' ],' line after the test_history
            $line = <$file_in>; chomp $line;
            # if ( $line =~ m/ "test_microseconds":{/i ) {
            #     warn "begin reached 'test_microseconds'\n";
            # }
        }
    }
    open( $self->{'file_out'}, '>', 'docs/test_summary.times.tmp') or die "cannot create docs/test_summary.times.tmp: $!";
    my $parrot_version = qx{./perl6 -e'print \$*VM<config><revision>'};
    my $impl_version = qx{git log --pretty=oneline --abbrev-commit --max-count=1 .}; chomp $impl_version;
    $impl_version =~ s/^([0-9a-f])+\.\.\./$1/; # delete possible ... 
    $impl_version =~ s/\\/\\\\/g; # escape all backslashes
    $impl_version =~ s/\"/\\\"/g; # escape all double quotes
    my $file_out = $self->{'file_out'};
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time());
    push @test_history, sprintf("[\"%4d-%02d-%02d %02d:%02d:%02d\",%d,\"%s\"]",
        $year+1900, $mon+1, $mday, $hour, $min, $sec,
        $parrot_version, $impl_version );
    # Delete the oldest test test_history if there are too many.
    while ( @test_history > $self->{'Timings'} ) { shift @test_history; }
    print $file_out qq!{"test_history":[\n!;
    print $file_out "  " . join(",\n  ",@test_history) . "\n ],\n";
    print $file_out qq! "test_microseconds":{!;
    # tell Test.pm to output per-test timestamps
    $ENV{'PERL6_TEST_TIMES'} = 'true';
    return bless $self;
}

# Track simple relative benchmarking.  Called after running each test script.
sub log_script_times {
    my $self      = shift;
    my $test_name = shift;
    my $ref_times = shift;
    my $ref_comments = shift;
    # Make local arrays of the execution times in microseconds, and test
    # comments (or descriptions).  Since tests are being added to and
    # removed from the test suite, test numbers change over time.  The
    # comments are sometimes empty or duplicated, but they are the only
    # way to correlate test results if the test suite is edited.
    my (@times) = @$ref_times;
    my (@comments) = @$ref_comments;
    shift @times;     # offset by 1: the first result becomes $times[0];
    shift @comments;
    for ( my $i=0; $i<=@times; $i++ ) {
        if ( not defined $comments[$i] ) { $comments[$i] = ''; }
        $comments[$i] =~ s/\\/\\\\/g; # escape all backslashes
        $comments[$i] =~ s/\"/\\\"/g; # escape all double quotes
    }
    my ( $line );
    my $file_in  = $self->{'file_in'};
    my $file_out = $self->{'file_out'};
    $test_name =~ s{^t/spec/}{};   # eg 'S02-literals/numeric.t'
    my $test_separator;
    if ( $self->{'Last_test_loaded'} eq '' ) {
        $test_separator = "\n";
    }
    else {
        $test_separator = ",\n";
    }
    while ( not eof($file_in) and $self->{'Last_test_loaded'} lt $test_name ) {
        $line = <$file_in>; chomp $line;
        if ( $line =~ m/^\s\s"(.+)":.$/ ) {
            $self->{'Last_test_loaded'} = $1;
        }
    }
    my @logged_results;
    if ( not eof($file_in) and $self->{'Last_test_loaded'} eq $test_name ) {
        my $line = <$file_in>; chomp $line;
        while ( not eof($file_in) and $line =~ m/^\s\s\s\[(\d+),\[(.+?)\],?/ ) {
            my $test_number = $1;
            my @timings = split /,/ , $2;
            $logged_results[$test_number-1] = [ @timings ];
            $line = <$file_in>; chomp $line;
        }
    }
    my $microseconds = [];
    my $testcount = @times;
    for ( my $test_number=0; $test_number<$testcount; $test_number++) {
        unless ( defined($times[$test_number]) ) { $times[$test_number] = 0; }
        my ( @times_in_file );
        if ( defined @{$logged_results[$test_number]} ) {
            @times_in_file = ( @{$logged_results[$test_number]} );
        }
        push @times_in_file, $times[$test_number];
        if ( not defined( $times_in_file[0] ) ) { shift @times_in_file; }
        # Delete the oldest test timings if there are too many.
        while ( @times_in_file > $self->{'Timings'} ) { shift @times_in_file; }
        $$microseconds[$test_number] = [ @times_in_file ];
    }
    my $test_number = 1; # start from number 1 again
    print $file_out
        $test_separator .
        qq'  "$test_name":[\n' .
        join(",\n", map {'   ['.$test_number++.',['.join(',',@$_).'],"'.$comments[$test_number-2].'"]'} @$microseconds) .
        qq'\n  ]';
}

# Finish simple relative benchmarking.  Called after the first test
sub end {
    my $self = shift;
    my $file_in  = $self->{'file_in'};
    my $file_out = $self->{'file_out'};
    print $file_out "\n }\n}\n";
    close $file_out or warn $!;
    close $file_in or warn $!;
    unlink 'docs/test_summary.times';
    rename 'docs/test_summary.times.tmp', 'docs/test_summary.times';
}

# Report on simple relative benchmarking.  Does the --view option
sub view
{
    my $choice = '1'; my $choiceA; my $choiceB;
    do {
        my ($input, $output, $t, @timings, $script, @z, @sorted, @runs);
        my @ordername = ('', 'sorted by time', 'sorted by %change', 'sorted by time change', 'in test order' );
        open($input, '<', 'docs/test_summary.times') or die "$0 cannot open docs/test_summary.times\n";
        while (<$input>) {  # custom parser to avoid dependency on JSON.pm
            # a commit identification line
            if (/^\s\s\[\"([^"]*)\",\d+,\"([^"]*)\"/) { push @runs, { 'time'=>$1, 'comment'=>$2 }; }
            # test script name
            if (/^\s\s\"(.+)\":\[$/x) { $script = $1; }
            # individual test times
            if (/^\s\s\s\[(\d+),\[([0-9,]+)\],\"(.*)\"\],/x) {
                unless (defined $choiceA) { $choiceB = $#runs; $choiceA = $choiceB-1; }
                my $testnumber = $1;
                my @times = split /,/, $2;
                push @times, 0 while @times < 5;
                my $testcomment = $3;
                if ($times[$choiceA] > 0 && $times[$choiceB] > 0) {
                    push @timings, [ [@times], $testcomment, $testnumber, $script];
                }
            }
        }
        close($input);
        @z=();  # Prepare to sort using a Schwartzian transform
        if ($choice eq '1') { # by execution time
            for my $t ( @timings ) { push @z, $$t[0][$choiceB]; }
        }
        elsif ($choice eq '2') { # by relative speedup/slowdown
            for my $t ( @timings ) { push @z, ($$t[0][$choiceB]-$$t[0][$choiceA])/$$t[0][$choiceA]; }
        }
        elsif ($choice eq '3') { # by absolute speedup/slowdown
            for my $t ( @timings ) { push @z, ($$t[0][$choiceB]-$$t[0][$choiceA]); }
        }
        else {
            @sorted = @timings; # choice '4' is unsorted, meaning in order of execution
        }
        @sorted = @timings[ sort { $z[$a] <=> $z[$b] } 0..$#timings ] if @z;
        # Send the results to 'less' for viewing
        open $output, ">", "/tmp/test_summary.$$" or die "$0 cannot output to 'less'\n";
        print $output "Microseconds and relative change of spec tests $ordername[$choice].  Commits:\n";
        print $output "A: $runs[$choiceA]{'time'} $runs[$choiceA]{'comment'}\n";
        print $output "B: $runs[$choiceB]{'time'} $runs[$choiceB]{'comment'}\n";
        print $output "     A     B  Chg Test description (script#test)\n";
        for $t (@sorted) {
            printf $output "%6d %5d %+3.0f%% %s (%s#%d)\n", $$t[0][$choiceA], $$t[0][$choiceB],
                ($$t[0][$choiceB]-$$t[0][$choiceA])*100/$$t[0][$choiceA], $$t[1], $$t[3], $$t[2];
        }
        close $output;
        system "less --chop-long-lines /tmp/test_summary.$$";
        do {  # Prompt for user choice of sort order or commits
            print 'view: sort by 1)time 2)%change 3)change 4)none, other 5)commits q)uit> ';
            $choice = <STDIN>; chomp $choice;
            if ($choice eq '5') {  # choose a commit
                for (my $r=0; $r<@runs; ++$r) {
                    print "$r: $runs[$r]{'time'} $runs[$r]{'comment'}\n";
                }
                print 'commit for column A: ';
                $choiceA = <STDIN>; chomp $choiceA;
                print 'commit for column B: ';
                $choiceB = <STDIN>; chomp $choiceB;
            }
        } while index('5', $choice) >= 0;  # if user chose commits, must still choose sort order
    } while index('1234', $choice) >= 0;   # if valid sort order (not 'q') then do another report
}

package RealRunner;

sub get_test_names {
    my ($self) = @_;

    # Build the list of test scripts to run in @tfiles
    my @tfiles;
    my $testlist = $ARGV[1] || 't/spectest.data';
    my $fh;
    open($fh, '<', $testlist) || die "Can't read $testlist: $!";
    while (<$fh>) {
        /^ *#/ && next;
        my ($specfile, $fudgespec) = split ' ', $_, 2;
        next unless $specfile;
        next if $fudgespec =~ /jvm/ && $implementation !~ /jvm/;
        next if $fudgespec =~ /moar/ && $implementation !~ /moar/;
        push @tfiles, "t/spec/$specfile";
    }
    close $fh or die $!;

    # Fudge any implementation specific tests by running the fudgeall script
    {
        my $cmd = join ' ', $^X, 't/spec/fudgeall', $implementation, @tfiles;
        # Fudgeall prints the name of each test script, but changes the name
        # ending to match the implementation instead of .t if tests were fudged.
        print "$cmd\n";
        @tfiles = split ' ', `$cmd`; # execute fudgeall, collect test names
    }
    @tfiles;
}

sub run_test {
    my ($self, $tfile) = @_;

    my $cmd = "./perl6 $tfile";
    # Run the test, collecting all stdout in @results
    scalar qx{$cmd};
}

package ArchiveRunner;

my $arc_file;

sub get_test_names {
    require Archive::Tar;
    $arc_file = Archive::Tar->new($archive);
    grep /^t/, $arc_file->list_files;
}

sub run_test {
    my ($self, $tfile) = @_;
    $arc_file->get_content($tfile);
}

package main;

=pod

=head1 NAME

tools/test_summary.pl -- run spectests and make statistical reports

=head1 DESCRIPTION

This test harness written in Perl 5, runs the Perl 6 specification test
suite.  It uses the same Test Anything Protocol (TAP) as for example
L<TAP::Harness>, but does not depend those modules.

The names of the tests are listed in t/spectest.data, or another file
whose name is passed on the command line.

=head2 OUTPUT

The harness prints the name of each test script before running it.
After completion it prints the total number of tests passed, failed,
to do, skipped, and planned.  The descriptions of any tests failed,
skipped or left to do are also listed.

After running all the tests listed, the harness prints a set of
subtotals per Synopsis.

If you set the REV environment variable (with the first 7 characters of
a git commit id), the harness prints an additional set of grand
totals suitable for adding to F<docs/spectest_progress.csv>.

=head1 SIMPLE RELATIVE BENCHMARKING

Too little information can mislead, hence this self deprecating title.
For example, these measurements overlook variation in test times
('jitter'), kernel versus user process times, and measurement overheads.
But these results are better than no information at all.

If activated, this tool logs the most recent 5 timings in microseconds
in F<docs/test_summary.times> in a specific JSON format, for later
analysis.  Measurement and logging add less than 2% to the testing time
and makes a log file of about 2.5MB.

=head2 Methods

=head3 begin

Accepts an optional parameter, the number of timings per test to keep.
Creates a temporary file for new results, and returns an object that
updates the log file.  (F<begin> acts as the constructor).

=head3 log_script_times

Takes these parameters: test script name, reference to an array of times
in microseconds, reference to an array of test description strings.
Appends the results to the temporary log file.

=head3 end

Closes and renames the temporary log file.

=head2 Timing results file

All results are stored in F<docs/test_summary.times> in a specific JSON
format.  With 35000 test result lines and 5 runs it occupies just under
2.5 MB.

Here is an example with a few semi fictitious results:

    {"test_history":[
      ["2010-05-05 10:15:45",46276,"925629d Make $x does (R1, R2) work."],
      ["2010-05-07 08:58:07",46276,"5713af2 run two more test files"],
      ["2010-05-08 18:08:43",46405,"ab23221 bump PARROT_REVISION"],
      ["2010-05-09 05:53:25",46405,"c49d32b run S04-phasers/rvalues.t"],
      ["2010-05-10 00:44:46",46405,"118f4aa Overhaul sqrt for Numeric / Real."]
     ],
     "test_microseconds":{
      "S02-builtin_data_types/anon_block.rakudo":[
       [1,[6139,7559,6440,6289,5520],"The object is-a 'Sub()'"],
       [2,[6610,6599,6690,6580,6010],"sub { } works"]
      ],
      "S02-builtin_data_types/array.rakudo":[
       [1,[9100,8889,9739,9140,9169],"for 1, 2, 3 does 3 iterations"],
       [2,[5650,5599,6119,9819,5140],"for (1, 2, 3).item 3 iterations"],
       [3,[3920,3770,4190,4410,3350],"for [1, 2, 3] does one iteration"]
      ]
     }
    }

The "test_history" section lists the starting times for all the runs of
F<tools/test_summary.pl> that are recorded in the file.  Then the
"test_microseconds" records show each test filename, possibly fudged,
followed by the test numbers, followed by the times obtained from each
run.  If a test has fewer than the usual number of timings, the timings
will be from the most recent test runs.

The file is read and written by custom code and not a JSON module, to
reduce dependencies.  Altering the file format might cause reading to
fail and could result in data loss.  General purpose JSON parsers should
be able to read the data.  For example the following ranks the tests
from best speedup to worst slowdown.

    #!/usr/bin/perl
    use File::Slurp qw( slurp );
    use JSON;
    my $log_text = slurp('docs/test_summary.times');
    my $log = JSON->new->decode( $log_text );
    # Flatten the data structure to a 2-D array of nonzero test times
    my @timings;
    my $script_hash = $$log{'test_microseconds'};
    for my $script_name ( sort keys %$script_hash ) {
        my $test_list = $$script_hash{$script_name};
        for my $t ( @$test_list ) {
            my $times_count = @{$$t[1]};
            if ( $times_count >= 2 and ${$$t[1]}[$times_count-1] > 0 ) {
                push @timings, [$script_name, $$t[0], $$t[2], ${$$t[1]}[$times_count-2], ${$$t[1]}[$times_count-1] ];
            }
        }
    }
    # Sort the timings into improved/worsened order with a Schwartzian transform
    my @z; for my $t ( @timings ) { push @z, ($$t[4]-$$t[3])/$$t[4]; }
    my @sorted = @timings[ sort { $z[$a] <=> $z[$b] } 0..$#timings ];
    # Display the results: quicker is minus, slower is plus.
    for my $s ( @sorted ) {
        printf "%+3.0f%% %6d %6d %s:%d:%s\n",
           ($$s[4]-$$s[3])*100/$$s[3], $$s[3], $$s[4], $$s[0], $$s[1], $$s[2];
    } # %change, prev-time, latest-time, script, test-num, test-desc

A second example shows another way to read the results file, and ranks
the tests from most to least consistent in execution time.

    #!/usr/bin/perl
    use JSON;
    my $log_text = qx{$^X -MExtUtils::Command -e cat docs/test_summary.times};
    my $log = JSON->new->decode( $log_text );
    # Flatten the data structure to a 2-D array of nonzero test times
    my @timings;
    my $script_hash = $$log{'test_microseconds'};
    for my $script_name ( sort keys %$script_hash ) {
        my $test_list = $$script_hash{$script_name};
        for my $t ( @$test_list ) {
            my $times_count = @{$$t[1]};
            if ( $times_count >= 2 and ${$$t[1]}[$times_count-1] > 0 ) {
                my $min = my $max = ${$$t[1]}[0];
                for my $i (1..$times_count-1) {
                    $min = ${$$t[1]}[$i] if $min > ${$$t[1]}[$i];
                    $max = ${$$t[1]}[$i] if $max < ${$$t[1]}[$i];
                }
                push @timings, [$script_name, $$t[0], $$t[2], $min, $max ] if $min > 0;
            }
        }
    }
    # Sort the timings into most/least consistent order by Schwartzian transform
    my @z; for my $t ( @timings ) { push @z, ($$t[4]-$$t[3])/$$t[3]; }
    my @sorted = @timings[ sort { $z[$a] <=> $z[$b] } 0..$#timings ];
    # Display the results from most to least consistent
    for my $s ( @sorted ) {
        printf "%3.1f%% %6d %6d %s:%d:%s\n",
            ($$s[4]-$$s[3])*100/$$s[3], $$s[3], $$s[4], $$s[0], $$s[1], $$s[2];
    } # %difference, min-time, max-time, script, test-num, test-desc

=head2 TODO

Detect changes in number of tests or descriptions of tests in each
test script, and discard all previous results for that script if there
has been a change.  Consider whether to log total execution time per
test script.

Analyse and report useful results, such as the slowest n tests.

Parse the `say now` output as well as `print pir::__time()`.

=head1 SEE ALSO

The L<perlperf> module.  The L<http://json.org/> site.

=cut
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/t/spec/TODO��������������������������������������������������������������������������0000664�0001750�0001750�00000001430�12224265625�014474� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������TODO items for the Perl 6 Test Suite

Add any requested tests or other updates to this file. Please organize them
by synopsis (when applicable) or put them in the OVERALL section at the top
if they apply to the test suite in general.

NOTE that references to a t/ directory are for the t/ directory in the mu
repository found here:  https://github.com/perl6/mu

Please also read t/deprecated-syntax.pod for common mistakes in the test
suite, and clear them when you update tests.

When you are adding entries here, please put something like this in the
commit message:

[TODO]: Added more tasks for S02.

This way, people working on the test suite can easily spot these commits
in #perl6.

OVERALL
* Add smartlinks to tests without them
* Review XXX entries for test corrections

SPECIFIC
* 
����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������rakudo-2013.12/VERSION������������������������������������������������������������������������������0000664�0001750�0001750�00000000010�12255236076�013652� 0����������������������������������������������������������������������������������������������������ustar  �moritz��������������������������moritz�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������2013.12
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������
  {  }
    token quote_mod:sym  {  }
    token quote_mod:sym {  }
    token quote_mod:sym  {  }
    token quote_mod:sym  {  }
    token quote_mod:sym  {  }
    token quote_mod:sym  {  }
    token quote_mod:sym  {  }
    token quote_mod:sym  {  }

    proto token quote { <...> }
    token quote:sym  { :dba('single quotes') "'" ~ "'" , "'", "'", ['q']))> }
    token quote:sym  { :dba('double quotes') '"' ~ '"' , '"', '"', ['qq']))> }
    token quote:sym {
        :my $qm;
        'q'
        [
        |  »  { $qm := $.Str } , 'q', $qm)>
        | »  <.ws> , 'q')>
        ]
    }
    token quote:sym {
        :my $qm;
        'qq'
        [
        |  »  { $qm := $.Str } <.ws> , 'qq', $qm)>
        | »  <.ws> , 'qq')>
        ]
    }
    token quote:sym {
        :my $qm;
        'Q'
        [
        |  »  { $qm := $.Str } , $qm)>
        | »  <.ws> )>
        ]
    }
    token quote:sym { 'Q:PIR' <.ws> )> }
    
    token quote:sym { '/' \s* '/' <.typed_panic: "X::Syntax::Regex::NullRegex"> }
    token quote:sym  {
        :my %*RX;
        :my $*INTERPOLATE := 1;
        '/' , '/', '/'))> [ '/' || <.panic: "Unable to parse regex; couldn't find final '/'"> ]
        <.old_rx_mods>?
    }
    token quote:sym   {
         >> 
        :my %*RX;
        :my $*INTERPOLATE := 1;
        
         ?? %*LANG !! %*LANG)>
        
    }

    token quote:sym {
         (s)**0..1>>
        :my %*RX;
        :my $*INTERPOLATE := 1;
        { %*RX := 1 if $/[0] }
        
         ?? %*LANG !! %*LANG)>
        
    }

    token quote:sym {
         <.end_keyword> <.obs('qr for regex quoting', 'rx//')>
    }

    token setup_quotepair { '' }

    token sibble($l, $lang2, @lang2tweaks?) {
        :my $lang;
        :my $start;
        :my $stop;
        
        { my $B := $.ast; $lang := $B[0]; $start := $B[1]; $stop := $B[2]; }

        $start  [ $stop || <.panic("Couldn't find terminator $stop")> ]
        [ 
            <.ws>
            [  <.obs('brackets around replacement', 'assignment syntax')> ]?
            [  || <.missing: "assignment operator"> ]
            [ .Str eq '=' }> || <.malformed: "assignment operator"> ]
            # XXX When we support it, above check should add: || $[0]
            <.ws>
            [  || <.panic: "Assignment operator missing its expression"> ]
        ||
            { $lang := self.quote_lang($lang2, $stop, $stop, @lang2tweaks); }
             $stop || <.panic("Malformed replacement part; couldn't find final $stop")>
        ]
    }

    token quote:sym {
         (s)**0..1 >>
        :my %*RX;
        :my $*INTERPOLATE := 1;
        {
            %*RX := 1 if $/[0]
        }
        
         ?? %*LANG !! %*LANG, %*LANG, ['qq'])>
        <.old_rx_mods>?
    }

    token tribble ($l, $lang2 = $l, @lang2tweaks?) {
        :my $lang;
        :my $start;
        :my $stop;
        :my $*CCSTATE := '';
        
        { my $B := $.ast; $lang := $B[0]; $start := $B[1]; $stop := $B[2]; }
        $start  [ $stop || <.panic: "Couldn't find terminator $stop"> ]
        { $*CCSTATE := ''; }
        [ 
            <.ws> 
        ||
            { $lang := self.quote_lang($lang2, $stop, $stop, @lang2tweaks); }
             $stop || <.panic("Malformed replacement part; couldn't find final $stop")>
        ]
    }

    token quote:sym {
        
        :my %*RX;
        :my $*INTERPOLATE := 1;
        
         ?? %*LANG !! %*LANG, %*LANG, ['cc'])>
        <.old_rx_mods>?
    }

    token old_rx_mods {
        (<[ i g s m x c e ]>)
        {
            my $m := $/[0].Str;
            if    $m eq 'i' { $/.CURSOR.obs('/i',':i');                                   }
            elsif $m eq 'g' { $/.CURSOR.obs('/g',':g');                                   }
            elsif $m eq 'm' { $/.CURSOR.obs('/m','^^ and $$ anchors');                    }
            elsif $m eq 's' { $/.CURSOR.obs('/s','. or \N');                              }
            elsif $m eq 'x' { $/.CURSOR.obs('/x','normal default whitespace');            }
            elsif $m eq 'c' { $/.CURSOR.obs('/c',':c or :p');                             }
            elsif $m eq 'e' { $/.CURSOR.obs('/e','interpolated {...} or s{} = ... form'); }
            else            { $/.CURSOR.obs('suffix regex modifiers','prefix adverbs');   }
        }
    }

    token quote:sym {
         <.ws> 
        :my $*IN_QUASI := 1;
        :my @*UNQUOTE_ASTS := [];
        
    }

    token circumfix:sym<( )> { :dba('parenthesized expression') '(' ~ ')'  }
    token circumfix:sym<[ ]> { :dba('array composer') '[' ~ ']'  }
    token circumfix:sym {
        :dba('quote words')
        '<' ~ '>'
        [
            [ ' > <.obs('', '$*IN.lines (or add whitespace to suppress warning)')> ]?
            [ ]> <.obs('<>', 'lines() to read input, (\'\') to represent a null string or () to represent an empty list')> ]?
            , "<", ">", ['q', 'w']))>
        ]
    }
    token circumfix:sym«<< >>» { :dba('shell-quote words') '<<' ~ '>>' , "<<", ">>", ['qq', 'ww']))> }
    token circumfix:sym<« »> { :dba('shell-quote words') '«' ~ '»' , "«", "»", ['qq', 'ww']))> }
    token circumfix:sym<{ }> {   }

    ## Operators

    INIT {
        Perl6::Grammar.O(':prec, :assoc, :dba, :fiddly<1>', '%methodcall');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%autoincrement');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%exponentiation');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%symbolic_unary');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%multiplicative');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%additive');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%replication');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%concatenation');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%junctive_and');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%junctive_or');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%named_unary');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%structural');
        Perl6::Grammar.O(':prec, :assoc, :dba, :iffy<1>, :pasttype',  '%chaining');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%tight_and');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%tight_or');
        Perl6::Grammar.O(':prec, :assoc, :dba, :fiddly<1>', '%conditional');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%item_assignment');
        Perl6::Grammar.O(':prec, :assoc, :dba, :sub, :fiddly<1>', '%list_assignment');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%loose_unary');
        Perl6::Grammar.O(':prec, :assoc, :dba, :nextterm, :fiddly<1>',  '%comma');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%list_infix');
        Perl6::Grammar.O(':prec, :assoc, :dba', '%list_prefix');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%loose_and');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%loose_or');
        Perl6::Grammar.O(':prec, :assoc, :dba',  '%sequencer');
    }

    token termish {
        :my $*SCOPE := "";
        :my $*MULTINESS := "";
        :my $*OFTYPE;
        :my $*VAR;
        :dba('prefix or term')
        [
        || * 
            :dba('postfix')
            [
            || 
                [
                ||  [ +! ) }> ]**0..1
                ||                          +! ) }>
                || { $*VAR := 0 } 
                ]
            ||  *
            ]
        ||   {
            $/.CURSOR.typed_panic('X::Syntax::InfixInTermPosition', infix => ~$); } >
        || 
        ]
        { self.check_variable($*VAR) if $*VAR; }
    }

    sub bracket_ending($matches) {
        my $check := $matches[+$matches - 1];
        my $str   := $check.Str;
        my $last  := nqp::substr($str, nqp::chars($check) - 1, 1);
        $last eq ')' || $last eq '}' || $last eq ']' || $last eq '>'
    }

    method EXPR(str $preclim = '') {
        # Override this so we can set $*LEFTSIGIL.
        my $*LEFTSIGIL := '';
        nqp::findmethod(HLL::Grammar, 'EXPR')(self, $preclim, :noinfix($preclim eq 'y='));
    }

    token prefixish { 
        :dba('prefix or meta-prefix')
        [
        | 
        | 
        ]
        **0..1
        <.ws>
    }

    token infixish($in_meta = nqp::getlexdyn('$*IN_META')) {
        :my $*IN_META := $in_meta;
        
        
        :dba('infix or meta-infix')
        [
        |  
        | :dba('bracketed infix') '[' ~ ']'  {} )>
            # XXX Gets false positives.
            #[  { self.worry("Useless use of [] around infix op") unless $*IN_META; } ]?
        | 
        |  
        | 
        |  
        ]
    }
    
    token fake_infix {
        , :fake<1>, :dba')>
    }
    
    regex infixstopper {
        :dba('infix stopper')
        [
        |  
        |  >  
        ]
    }

    token postfixish {
        
        
        # last whitespace didn't end here
        

        [  [ <.unsp> | '\\' ] ]?

        :dba('postfix')
        [ ['.' <.unsp>?]?  <.unsp>?]**0..1
        [
        | 
        | 
        | 
        | 
        ]
        { $*LEFTSIGIL := '@'; }
    }

    token postop {
        |          $ = {$} $ = {$}
        |    $ = {$} $ = {$}
    }

    proto token prefix_circumfix_meta_operator { <...> }

    proto token infix_postfix_meta_operator { <...> }

    proto token infix_prefix_meta_operator { <...> }

    proto token infix_circumfix_meta_operator { <...> }

    proto token postfix_prefix_meta_operator { <...> }

    proto token prefix_postfix_meta_operator { <...> }
    
    method can_meta($op, $meta) {
        !$op ||
            self.sorry("Cannot " ~ $meta ~ " " ~ $op ~ " because " ~ $op ~ " operators are too fiddly");
        self;
    }
    
    regex term:sym {
        :my $*IN_REDUCE := 1;
        :my $op;
        
        
        '['
        [
        ||  
        || $=[\\] 
        || 
        ]
        ']'
        { $op := $; }
        
        <.can_meta($op, "reduce with")>

        
    }

    token postfix_prefix_meta_operator:sym<»> {
        [  | '>>' ] 
        [  ||  ]
    }

    token prefix_postfix_meta_operator:sym<«> {
         | '<<'
    }

    token infix_circumfix_meta_operator:sym<« »> {
        $=[ '«' | '»' ]
        {} 
        $=[ '«' | '»' || <.missing("« or »")> ]
        {} )>
    }

    token infix_circumfix_meta_operator:sym«<< >>» {
        $=[ '<<' | '>>' ]
        {} 
        $=[ '<<' | '>>' || <.missing("<< or >>")> ]
        {} )>
    }

    method copyO($from) {
        my $O   := $from;
        my $cur := self.'!cursor_start_cur'();
        $cur.'!cursor_pass'(self.pos());
        nqp::bindattr($cur, NQPCursor, '$!match', $O);
        $cur
    }

    method copyOPER($from) {
        my $OPER := $from;
        my $cur  := self.'!cursor_start_cur'();
        $cur.'!cursor_pass'(self.pos());
        nqp::bindattr($cur, NQPCursor, '$!match', $OPER);
        $cur
    }

    proto token dotty { <...> }
    token dotty:sym<.> {
         
        
    }

    token dotty:sym<.*> {
        $=['.' [ <[+*?=]> | '^' '!'? ]] 
        
    }

    token dottyop {
        :dba('dotty method or postfix')
        [
        | 
        | 
        |   $ = {$} $ = {$}
        ]
    }

    token privop {
        '!' 
        
    }

    token methodop {
        [
        | 
        |   { self.check_variable($) }
        | 
            [  || *? [\s|$] > ] # dwim on "$foo."
            
            [  || <.panic: "Quoted method name requires parenthesized arguments. If you meant to concatenate two strings, use '~'."> ]
        ] <.unsp>?
        :dba('method arguments')
        [
            [
            |  
            | ':'   
            ]
            ||  
            ||   
        ]
    }

    token dottyopish {
        
    }

    token postcircumfix:sym<[ ]> {
        :my $*QSIGIL := '';
        :dba('subscript')
        '[' ~ ']' [ <.ws>  ]
        
    }

    token postcircumfix:sym<{ }> {
        :my $*QSIGIL := '';
        :dba('subscript')
        '{' ~ '}' [ <.ws>  ]
        
    }

    token postcircumfix:sym {
        '<'
        [
        || , "<", ">", ['q', 'w']))> '>'
        ||  | ':' ] >
           { $/.CURSOR.panic("Whitespace required before < operator") }
        || { $/.CURSOR.panic("Unable to parse quote-words subscript; couldn't find right angle quote") }
        ]
        
    }
    
    token postcircumfix:sym«<< >>» {
        :dba('shell-quote words')
        '<<'
        [
        || , "<<", ">>", ['qq', 'ww']))> '>>'
        || { $/.CURSOR.panic("Unable to parse quote-words subscript; couldn't find right double-angle quote") }
        ]
        
    }
    
    token postcircumfix:sym<« »> {
        :dba('shell-quote words')
        '«'
        [
        || , "«", "»", ['qq', 'ww']))> '»'
        || { $/.CURSOR.panic("Unable to parse quote-words subscript; couldn't find right double-angle quote") }
        ]
        
    }

    token postcircumfix:sym<( )> {
        :dba('argument list')
        '(' ~ ')' [ <.ws>  ]
        
    }

    token postfix:sym  {  >>  }

    token prefix:sym<++>  {    }
    token prefix:sym<-->  {    }
    token postfix:sym<++> {    }
    token postfix:sym<--> {    }

    # TODO: report the correct bracket in error message
    token postfix:sym«->» {
        
        [
        |  ['[' | '{' | '(' ] <.obs('->(), ->{} or ->[] as postfix dereferencer', '.(), .[] or .{} to deref, or whitespace to delimit a pointy block')>
        | <.obs('-> as postfix', 'either . to call a method, or whitespace to delimit a pointy block')>
        ]
    }

    token infix:sym<**>   {    }

    token prefix:sym<+>   {    }
    token prefix:sym<~>   {    }
    token prefix:sym<->   {  ]>  }
    token prefix:sym   {    }
    token prefix:sym   {    }
    token prefix:sym<+^>  {    }
    token prefix:sym<~^>  {    }
    token prefix:sym  {    }
    token prefix:sym<^>   {    }
    token prefix:sym<|>   {    }

    token infix:sym<*>    {    }
    token infix:sym    {    }
    token infix:sym