Awaiting a bugfix

When using Proc::Async we need to await while waiting for a fix for R#3817. While adding many tests to Shell::Piping I got a flapper on Travis. After my last misadvanture while testing async code I learned to use stress -c 30 to make sure that OS threads are congested. And sure enough, I got the same tests to fail then on Travis. A workaround is to await after reading form Proc::Async.stdout. In my code that looks like the following.

for $.proc-out-stdout.lines {
    my $value := &.code.($_);
    my $processed = $value === Nil ?? ‚‘ !! $value ~ "\n";
    await $.proc-in.write: $processed.encode with $.proc-in;
  # ^^^^^ WORKAROUND for R#3817
}

I then had to add a piece of odd code at another place to have something to await on.

method write($blob) { my $p = Promise.new; $p.keep; a.push: $blob.decode.chomp; $p }

The Promise is really just there so we can nudge Rakudo to have a good look at its threads. If you are using Proc::Async in your code please check for .write and test it on a system with more work then cores. You wont get an error with this bug. It will just silently drop values that are send via .write to another process or fetched via .stdout.lines. Good hunting!

Conditional whenever

I wrote a script to filter iostat because the latter either displays too much or too little. It also doesn’t know about bcache. I wanted to have the script react the same way to pressing q then top, atop or iotop. But it should only watch the keyboard and quit when $*OUT is a terminal. First we need to read the keyboard.

whenever key-pressed(:!echo) {
    when 'q' | 'Q' { done }
}

Now we got a few options to add a check for an attached terminal

if $*OUT.t {
    whenever key-pressed(:!echo) {
        when 'q' | 'Q' { done }
    }
}
$*OUT.t && do whenever key-pressed(:!echo) {
    when 'q' | 'Q' { done }
}
do whenever key-pressed(:!echo) {
    when 'q' | 'Q' { done }
} if $*OUT.t

The last one kind of lines up with other whenever blocks but the condition gets harder to read. At first I thought it wont be possible to use ?? !! because whenever always wants to run .tap on the parameter. But then I remembered that we use 0x90 to tell a CPU to do nothing. If we get a Supply that does nothing we can opt out of doing something.

constant NOP = Supplier.new;
whenever $*OUT.t ?? key-pressed(:!echo) !! NOP {
    when 'q' | 'Q' { done }
}

Now it neatly lines up with other whenever blocks.

As a member of the Perl family Perl 6 has more then one way to do it. Most of them look a big odd though.

Threading nqp through a channel

Given that nqp is faster then plain Perl 6 and threads combining the two should give us some decent speed. Using a Supply as promised in the last post wouldn’t really help. The emit will block until the internal queue of the Supply is cleared. If we want to process files recursively the filesystem might stall just after the recursing thread is unblocked. If we are putting pressure on the filesystem in the consumer, we are better of with a Channel that is swiftly filled with file paths.

Let’s start with a simulated consumer that will stall every now end then and takes the Channel in $c.

my @files;
react {
    whenever $c -> $path {
        @files.push: $path;
        sleep 1 if rand < 0.00001;
    }
}

If we would pump out paths as quickly as possible we could fill quite a bit of RAM and put a lot of pressure on the CPU caches. After some trial and error I found that sleeping befor the .send on the Channel helps when there are more then 64 worker threads waiting to be put onto machine threads. That information is accessible via Telemetry::Instrument::ThreadPool::Snap.new<gtq>.

my $c = Channel.new;
start {
    my @dirs = '/snapshots/home-2019-01-29';
    while @dirs.shift -> str $dir {
        my Mu $dirh := nqp::opendir(nqp::unbox_s($dir));
        while my str $name = nqp::nextfiledir($dirh) {
            next if $name eq '.' | '..';
            my str $abs-path = nqp::concat( nqp::concat($dir, '/'), $name);
            next if nqp::fileislink($abs-path);
            if Telemetry::Instrument::ThreadPool::Snap.new<gtq> > 64 {
                say Telemetry::Instrument::ThreadPool::Snap.new<gtq>;
                say 'sleeping';
                sleep 0.1;
        }
        $c.send($abs-path) if nqp::stat($abs-path, nqp::const::STAT_ISREG);
        @dirs.push: $abs-path if nqp::stat($abs-path, nqp::const::STAT_ISDIR);
    }
    CATCH { default { put BOLD .Str, ' ⟨', $dir, '⟩' } }
    nqp::closedir($dirh); }
    $c.close;
}

Sleeping for 0.1s before sending the next value is a bit naive. It would be better to watch the number of waiting workers and only continue when it has dropped below 64. But that is a task for a differnt module. We don’t really have a middle ground in Perl 6 between Supply with it’s blocking nature and the value pumping Channel. So such a module might be actually quite useful.

But that will have to wait. I seam to have stepped on a bug in IO::Handle.read while working with large binary files. We got tons of tests on roast that deal with small data. Working with large data isn’t well tested and I wonder what monsters are lurking there.

Issue All The Things

While on her epic quest to clean up the meta part of the ecosystem samvc send me a few pull requests. That raised the question which of my modules have open issues. Github is quite eager to list you many things but lacks the ability to show issues for a group of repos. Once again things fell into place.

Some time ago I made a meta module to save a few clicks when testing modules once a week. What means I have a list of modules I care about already.

perl6 -e 'use META6; use META6::bin :TERM :HELPER;\\
for META6.new(file => "$*HOME/projects/perl6/gfldex-meta-zef-test/META6.json").<depends> -> $name {\\
    say BOLD $name;\\
}'

META6::bin didn’t know about Github issues, what was easily solved, including retries on timeouts of the github api. Now I can feed the module names into &MAIN and get a list of issues.

perl6 -e 'use META6; use META6::bin :TERM :HELPER;\\
for META6.new(file => "$*HOME/projects/perl6/gfldex-meta-zef-test/META6.json").<depends> -> $name {\\
    say BOLD $name;\\
    try META6::bin::MAIN(:issues, :module($name), :one-line, :url);\\
}'

I switfly went to merge the pull requests.

Test::META
[open] Add License checks and use new META license spec [10d] ⟨https://github.com/jonathanstowe/Test-META/pull/21⟩
[open] warn on source [35d] ⟨https://github.com/jonathanstowe/Test-META/issues/20⟩
[open] warn on empty description [37d] ⟨https://github.com/jonathanstowe/Test-META/issues/19⟩
[open] check if source-url is accessible [37d] ⟨https://github.com/jonathanstowe/Test-META/issues/18⟩
[open] Check `perl` version [135d] ⟨https://github.com/jonathanstowe/Test-META/issues/14⟩
[open] Report missing modules? [1y] ⟨https://github.com/jonathanstowe/Test-META/issues/8⟩
[open] Add :strict-versions switch [1y] ⟨https://github.com/jonathanstowe/Test-META/issues/7⟩
[open] Test harder that "provides" is sane [1y] ⟨https://github.com/jonathanstowe/Test-META/issues/6⟩
Typesafe::XHTML::Writer
Rakudo::Slippy::Semilist
Slippy::Semilist
Github timed out, trying again 1/3.
Github timed out, trying again 2/3.
Github timed out, giving up.
Operator::defined-alternation
Concurrent::Channelify
[open] Use SPDX identifier in license field of META6.json [3d] ⟨https://github.com/gfldex/perl6-concurrent-channelify/pull/1⟩
Concurrent::File::Find
[open] Use SPDX identifier in license field of META6.json [3d] ⟨https://github.com/gfldex/perl6-concurrent-file-find/pull/1⟩
XHTML::Writer
Github timed out, trying again 1/3.
Typesafe::HTML
Git::Config
Proc::Async::Timeout
Github timed out, trying again 1/3.
[open] Use SPDX identifier in license field of META6.json [9d] ⟨https://github.com/gfldex/perl6-proc-async-timeout/pull/1⟩

To check the issues of any project that got a META6.json run meta6 --issues. To check if there are issues for a given module in the ecosystem use meta6 --issues --module=Your::Module::Name

UPDATE:

As requested by timotimo, meta6 --issues --one-line --url --deps will list all issues of the repo and all issues of the dependencies listed in META6.json.

You can call me Whatever you like

The docs spend many words to explain in great detail what a Whatever is and how to use it from the caller perspective. There are quite a few ways to support Whatever as a callee as I shall explain.

Whatever can be used to express “all of the things”. In that case we ask for the type object that is Whatever.

sub gimmi(Whatever) {};
gimmi(*);

Any expression that contains a Whatever * will be turned into a thunk. The latter happens to be a block without a local scope (kind of, it can be turned into a block when captured). We can ask specifically for a WhateverCode to accept Whatever-expressions.

sub compute-all-the-things(WhateverCode $c) { $c(42) }
say compute-all-the-things(*-1);
say (try say compute-all-the-things({$_ - 1})) // 'failed';
# OUTPUT: «41␤failed␤»

We could also ask for a Block or a Method as both come preloaded with one parameter. If we need a WhateverCode with more then one argument we have to be precise because the compiler can’t match a Callable sub-signature with a WhateverCode.

sub picky(WhateverCode $c where .arity == 2 || fail("two stars in that expession please") ) {
    $c.(1, 2)
}
say picky(*-*);
# OUTPUT: «-1␤»
say (try picky(*-1)) // $!;
# OUTPUT: «two stars in that expession please␤  in sub picky at …»

The same works with a Callable constraint, leaving the programmer more freedom what to supply.

sub picky(&c where .arity == 2) { c(1, 2) }

There are quite a few things a WhateverCode can’t do.

sub faily(WhateverCode $c) { $c.(1) }
say (try faily( return * )) // $!.^name;
# OUTPUT: «X::ControlFlow::Return␤»

The compiler can take advantage of that and provide compile time errors or get things done a little bit qicker. So trading the flexibility of Callable for a stricter WhateverCode constraint may make sense.

Dealing with Fallout

The much welcome and overdue sanification of the IO-subsystem lead to some fallout in some of my code that was enjoyably easy to fix.

Some IO-operations used to return False or undefined values on errors returned from the OS. Those have been fixed to return Failure. As a result some idioms don’t work as they used to.

my $v = §some-filename.txt".IO.open.?slurp // 'sane default';

The conditional method call operator .? does not defuse Failure as a result the whole expression blows up when an error occures. Luckily try can be used as a statement, which will return Nil, so we can still use the defined-or-operator // to assign default values.

my $v = (try "some-filename.txt".IO.open.slurpy) // 'sane default';

The rational to have IO-operations throw explosives is simple. Filesystem dealings can not be atomic (at least seen from the runtime) and can fail unexpectetly due to cable tripping. By packaging exceptions in Failure objects Perl 6 allows us to turn them back into undefined values as we please.

Slipping in a Config File

I wanted to add a config file to META6::bin without adding another dependency and without adding a grammar or other forms of fancy (and therefore time consuming) parsers. As it turns out, .split and friends are more then enough to get the job done.

# META6::bin config file

general.timeout = 60
git.timeout = 120
git.protocol = https

That’s how the file should look like and I wanted a multidim Hash in the end to query values like %config<git><timeout>.

our sub read-cfg($path) is export(:HELPER) {
    use Slippy::Semilist;

    return unless $path.IO.e;

    my %h;
    slurp($path).lines\
        ».chomp\
        .grep(!*.starts-with('#'))\
        .grep(*.chars)\
        ».split(/\s* '=' \s*/)\
        .flat.map(-> $k, $v { %h{||$k.split('.').cache} = $v });

    %h
}

We slurp in the whole file and process it line by line. All newlines are removed and any line that starts with a # or is empty is skipped. We separate values and keys by = and use a Semilist Slip to build the multidim Hash. Abusing a .map that doesn’t return values is a bit smelly but keeps all operations in order.

A Semilist is the thing you can find in %hash{1;2;3} (same for arrays) to express multi-dimentionallity. Just using a normal list wont cut it because a list is a valid key for a Hash.

I had Rakudo::Slippy::Semilist laying around for quite some time but never really used it much because it’s cheating by using nqp-ops to get some decent speed. As it turned out it’s not really the operations on a Hash as the circumfix:<{ }>-operator itself that is causing a 20x speed drop. By calling .EXISTS-KEY and .BIND-KEY directly the speed hit shrinks down to 7% over a nqp-implementation.

It’s one of those cases where things fall into place with Perl 6. Being able to define my own operator in conjunction with ». allows to keep the code flowing in the order of thoughs instead of breaking it up into nested loops.

Speeding up Travis

After some wiggling I managed to convince travis to use ubuntu packages to trim off about 4 minutes of a test. Sadly the .debs don’t come with build in zef, what would be another 40 seconds.

As follows a working .travis.yml.

sudo: required
before_install:
    - wget https://github.com/nxadm/rakudo-pkg/releases/download/2017.03_02/perl6-rakudo-moarvm-ubuntu16.04_20170300-02_amd64.deb
    - sudo dpkg --install perl6-rakudo-moarvm-ubuntu16.04_20170300-02_amd64.deb
    - sudo /opt/rakudo/bin/install_zef_as_root.sh
    - export PATH=/opt/rakudo/bin:$PATH
    - sudo chown -R travis.travis /home/travis/.zef/
install:
    - zef --debug install .
script:
- zef list --installed

Using a meta package in conjuction with .debs makes it quite easy to test if a module will work not just with bleeding Rakudo but with versions users might actually have.

Fork All The Things!

As requested by timotimo META6::bin is now able to fork a module on github by looking up its source in the ecosystem and telling git to clone it to the local FS.

meta6 --fork-module=Somebody::Else::Module

As a little bonus it will create a t/meta.t if possible. To be able to do so, META6::bin had to learn how to add dependencies to a META6.json-file.

meta6 --add-dep=Important::Module

I will add pullrequest creation as soon as I figured out how to convice the github api to do my bidding.

UPDATE: Pull requesting is in but not well tested (I don’t have any non-synthetic PRs to send right now). A META6.json is required to get the repo-name automatically. The youngest commit message sports the default PR title.

meta6 --pull-request

Make Children, not War

While teaching META6::bin how to read a config file, I was thinking about handling URIs by creating individual types per schema. That would require a factory what is not to my liking. I don’t use a dymanic language just to implement all that nice redundancy sugested in Design Patterns.

But then I reaslised that I use a dynamic language what means I can have a factory without implementing it. As long as I keep all subclasses in the same compunit then the parent class, that parent can use package introspection to collect all children and implement the factory method in its .new method.

class URL is export {
    my $.subclasses;

    our $.schema;
    has Str $.host;
    has $.raw;

    multi method new(Str $url) {
        $.subclasses //= UNIT::.values.grep({$_ ~~ URL && .schema});

        for $.subclasses.flat {
            return $_.new(:raw($url)) if $url.starts-with(.schema ~ '://');
        }
    }

    method host {
        $!host //= $.raw.substr($.raw.index('://') + 3).substr(0, $.raw.index('/') + 1);
    }
}

class HTTP is URL is export {
    our $.schema = 'http';
}

class HTTPS is URL is export {
    our $.schema = 'https';
}

sub url(|c){
    URL.new(|c)
}

say url('https://foo.com/bar.p6').host;

UNIT::.values returns a list of type objects that we can check against in the constructor. The class variable $.schema is used to pick the right child to return.

One could take that a step further and add a trait to register a child and a thunk with the base class to move the decision making what object to return to the children. That way a child could be moved to a different compunit as well.