Skip to content

Instantly share code, notes, and snippets.

@Whateverable
Created October 15, 2017 06:06
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save Whateverable/7224ec8e96ed3d03ede4681e2d701d31 to your computer and use it in GitHub Desktop.
Save Whateverable/7224ec8e96ed3d03ede4681e2d701d31 to your computer and use it in GitHub Desktop.
committable6
HEAD say 42
Too many positionals passed; expected 3 arguments but got 4
  in method process-commit at /home/bisectable/git/whateverable/bin/Committable.p6 line 62 (⚠ uncommitted)
  in method process-commit at /home/bisectable/git/whateverable/bin/Committable.p6 line 73 (⚠ uncommitted)
  in method process at /home/bisectable/git/whateverable/bin/Committable.p6 line 96 (⚠ uncommitted)
  in method irc-to-me at /home/bisectable/git/whateverable/bin/Committable.p6 line 59 (⚠ uncommitted)
  in sub  at /home/bisectable/git/whateverable/lib/Whateverable.pm6 (Whateverable) line 64 (⚠ uncommitted)
  in block  at /home/bisectable/.rakudobrew/moar-nom/install/share/perl6/site/sources/EB1F9C31CF577841A9A329C086A53361AAE4C47F (IRC::Client) line 290
  in method handle-event at /home/bisectable/.rakudobrew/moar-nom/install/share/perl6/site/sources/EB1F9C31CF577841A9A329C086A53361AAE4C47F (IRC::Client) line 285
  in block  at /home/bisectable/.rakudobrew/moar-nom/install/share/perl6/site/sources/EB1F9C31CF577841A9A329C086A53361AAE4C47F (IRC::Client) line 109
  in block  at /home/bisectable/.rakudobrew/moar-nom/install/share/perl6/site/sources/EB1F9C31CF577841A9A329C086A53361AAE4C47F (IRC::Client) line 106
#!/usr/bin/env perl6
# Copyright © 2016-2017
# Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com>
# Copyright © 2016
# Daniel Green <ddgreen@gmail.com>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
use Whateverable;
use Misc;
use IRC::Client;
unit class Committable does Whateverable;
constant TOTAL-TIME = 60 × 3;
constant shortcuts = %(
mc => ‘2015.12’, ec => ‘2015.12’,
mch => ‘2015.12,HEAD’, ech => ‘2015.12,HEAD’,
ma => ‘all’, all => ‘all’,
what => ‘6c’, ‘6c’ => ‘6c’, ‘v6c’ => ‘6c’, ‘v6.c’ => ‘6c’, ‘6.c’ => ‘6c’,
);
# https://github.com/rakudo/rakudo/wiki/dev-env-vars
my \ENV-VARS = set <MVM_SPESH_DISABLE MVM_SPESH_BLOCKING
MVM_SPESH_NODELAY MVM_SPESH_INLINE_DISABLE
MVM_SPESH_OSR_DISABLE MVM_JIT_DISABLE>;
method help($msg) {
“Like this: {$msg.server.current-nick}: f583f22,HEAD say ‘hello’; say ‘world’”
}
multi method irc-to-me($msg where .args[1] ~~ ?(my $prefix = m/^ $<shortcut>=@(shortcuts.keys)
[‘:’ | ‘,’]/)
&& .text ~~ /^ \s* $<code>=.+ /) is default {
self.process: $msg, shortcuts{$prefix<shortcut>}, ~$<code>
}
multi method irc-to-me($msg where /^ \s* [ @<envs>=((<[\w-]>+)‘=’(\S*)) ]* %% \s+
$<config>=<.&commit-list> \s+
$<code>=.+ /) {
my %ENV = @<envs>.map: { ~.[0] => ~.[1] } if @<envs>;
for %ENV {
grumble “ENV variable {.key} is not supported” if .key ∉ ENV-VARS;
grumble “ENV variable {.key} can only be 0, 1 or empty” if .value ne ‘0’ | ‘1’ | ‘’;
}
%ENV ,= %*ENV;
self.process: $msg, ~$<config>, ~$<code>, :%ENV
}
method process-commit($commit, $filename, :%ENV) {
# convert to real ids so we can look up the builds
my $full-commit = to-full-commit $commit;
my $short-commit = self.get-short-commit: $commit;
$short-commit ~= “({self.get-short-commit: $full-commit})” if $commit eq ‘HEAD’;
without $full-commit {
return $short-commit R=> ‘Cannot find this revision (did you mean “’ ~
self.get-short-commit(self.get-similar: $commit, <HEAD v6.c releases all>) ~
‘”?)’
}
$short-commit R=> self.process-commit: $commit, $filename, $full-commit, :%ENV;
}
method process($msg, $config is copy, $code is copy, :%ENV) {
my $start-time = now;
if $config ~~ /^ [say|sub] $/ {
$msg.reply: “Seems like you forgot to specify a revision (will use “v6.c” instead of “$config”)”;
$code = “$config $code”;
$config = ‘v6.c’
}
my @commits = self.get-commits: $config;
$code = self.process-code: $code, $msg;
my $filename = write-code $code;
LEAVE { unlink $_ with $filename }
my @outputs; # unlike %shas this is ordered
my %shas; # { output => [sha, sha, …], … }
%shas.categorize-list: as => *.value, {
if now - $start-time > TOTAL-TIME { # bail out if needed
grumble “«hit the total time limit of {TOTAL-TIME} seconds»”
}
@outputs.push: .key if %shas{.key}:!exists;
.key
}, @commits.map: { self.process-commit: $_, $filename, :%ENV };
my $short-str = @outputs == 1 && %shas{@outputs[0]} > 3 && $config.chars < 20
?? “¦{$config} ({+%shas{@outputs[0]}} commits): «{@outputs[0]}»”
!! ‘¦’ ~ @outputs.map({ “{%shas{$_}.join: ‘,’}: «$_»” }).join: ‘ ¦’;
my &limited-join = sub (@sha-list) {
my $l = ‘’;
gather for @sha-list -> $sha {
{ take “$l,”; $l = ‘’ } if $l and ($l ~ $sha).chars > 70;
$l ~= $l ?? “,$sha” !! $sha;
LAST take $l
}.join: “\n ”
}
my $long-str = ‘¦’ ~ @outputs.map({ “«{limited-join %shas{$_}}»:\n$_” }).join: “\n¦”;
$short-str but ProperStr($long-str);
}
Committable.new.selfrun: ‘committable6’, [ / [ | c <!before [「:\」|「:/」]> [ommit]?6?
| @(shortcuts.keys) ] <before ‘:’> /,
fuzzy-nick(‘committable6’, 3) ]
# vim: expandtab shiftwidth=4 ft=perl6
# Copyright © 2016-2017
# Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com>
# Copyright © 2016
# Daniel Green <ddgreen@gmail.com>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
use File::Directory::Tree;
use File::Temp;
use HTTP::UserAgent;
use IRC::Client::Message;
use IRC::Client;
use IRC::TextColor;
use JSON::Fast;
use Number::Denominate;
use Pastebin::Gist;
use Terminal::ANSIColor;
use Text::Diff::Sift4;
use Misc;
our $RAKUDO = (%*ENV<TESTABLE> // ‘’).contains(‘rakudo-mock’)
?? ‘./t/data/rakudo’.IO.absolute
!! ‘./data/rakudo-moar’.IO.absolute;
constant MOARVM = ‘./data/moarvm’.IO.absolute;
constant CONFIG = ‘./config.json’.IO.absolute;
constant SOURCE = ‘https://github.com/perl6/whateverable’;
constant WIKI = ‘https://github.com/perl6/whateverable/wiki/’;
constant WORKING-DIRECTORY = ‘.’.IO.absolute; # TODO not supported yet
constant ARCHIVES-LOCATION = “{WORKING-DIRECTORY}/data/builds”.IO.absolute;
constant BUILDS-LOCATION = ‘/tmp/whateverable/’.IO.absolute;
constant MESSAGE-LIMIT is export = 260;
constant COMMITS-LIMIT = 500;
my $GIST-LIMIT = 10_000;
constant $CAVE = ‘#whateverable’;
constant $PARENTS = ‘AlexDaniel’, ‘MasterDuke’;
our $RAKUDO-REPO = ‘https://github.com/rakudo/rakudo’;
constant Message = IRC::Client::Message;
unit role Whateverable[:$default-timeout = 10] does IRC::Client::Plugin does Helpful;
my $default-stdin = slurp ‘stdin’;
has $!bad-releases = set ‘2016.01’, ‘2016.01.1’;
method TWEAK {
# wrap around everything to catch exceptions
once { # per class
self.^lookup(‘irc-to-me’).wrap: sub ($self, $msg) {
LEAVE sleep 0.02; # https://github.com/perl6/whateverable/issues/163
try { with (callsame) { return $_ but Reply($msg) } else { return } }
$self.handle-exception: $!, $msg
};
self.^lookup(‘filter’).wrap: sub ($self, $response) {
my &filter = nextcallee;
try { return filter $self, $response }
try { return filter $self, $self.handle-exception($!, $response.?msg) }
‘Sorry kid, that's not my department.’
};
}
# TODO roles should not have TWEAK method
}
method handle-exception($exception, $msg?) {
CATCH { # exception handling is too fat, so let's do this also…
.note;
return ‘Exception was thrown while I was trying to handle another exception…’
~ ‘ What are they gonna do to me, Sarge? What are they gonna do⁈’
}
if $exception ~~ Whateverable::X::HandleableAdHoc { # oh, it's OK!
return $exception.message but Reply($_) with $msg;
return $exception.message
}
note $exception;
with $msg {
if .channel ne $CAVE {
.irc.send-cmd: ‘PRIVMSG’, $CAVE, “I'm acting stupid on {.channel}. Help me.”,
:server(.server), :prefix($PARENTS.join(‘, ’) ~ ‘: ’)
}
}
my ($text, @files) = flat self.awesomify-exception: $exception;
@files .= map({ ‘uncommitted-’ ~ .split(‘/’).tail => .IO.slurp });
@files.push: ‘|git-diff-HEAD.patch’ => run(:out, ‘git’, ‘diff’, ‘HEAD’).out.slurp-rest if @files;
@files.push: ‘result.md’ => $text;
my $return = (‘’ but FileStore(%@files))
but PrettyLink({“No! It wasn't me! It was the one-armed man! Backtrace: $_”});
# https://youtu.be/MC6bzR9qmxM?t=97
$return = $return but Reply($_) with $msg;
$return
}
method awesomify-exception($exception) {
my @local-files;
my $sha = run(:out, ‘git’, ‘rev-parse’, ‘--verify’, ‘HEAD’).out.slurp-rest;
‘<pre>’ ~
$exception.gist.lines.map({
# TODO Proper way to get data out of exceptions?
# For example, right now it is broken for paths with spaces
when /:s ^([\s**2|\s**6]in \w+ \S* at “{WORKING-DIRECTORY}/”?)$<path>=[\S+](
[<.ws>‘(’<-[)]>+‘)’]? line )$<line>=[\d+]$/ {
my $status = run :out, ‘git’, ‘status’, ‘--porcelain’, ‘--untracked-files=no’,
‘--’, ~$<path>;
proceed if !$status && !%*ENV<DEBUGGABLE>; # not a repo file and not in the debug mode
my $private-debugging = !$status;
$status = $status.out.slurp-rest;
my $uncommitted = $status && !$status.starts-with: ‘ ’; # not committed yet
@local-files.push: ~$<path> if $uncommitted || $private-debugging;
my $href = $uncommitted || $private-debugging
?? “#file-uncommitted-{$<path>.split(‘/’).tail.lc.trans(‘.’ => ‘-’)}-” # TODO not perfect but good enough
!! “{SOURCE}/blob/$sha/{markdown-escape $<path>}#”;
$href ~= “L$<line>”;
markdown-escape($0) ~
# let's hope for the best ↓
“<a href="$href">{$<path>}</a>” ~
markdown-escape($1 ~ $<line>) ~
($uncommitted ?? ‘ (⚠ uncommitted)’ !! ‘’)
}
default { $_ }
}).join(“\n”)
~ ‘</pre>’, @local-files
}
multi method irc-to-me(Message $msg where .text ~~
#↓ Matches only one space on purpose (for whitespace-only stdin)
/:i^ [stdin] [‘ ’|‘=’] [clear|delete|reset|unset] $/) {
$default-stdin = slurp ‘stdin’;
‘STDIN is reset to the default value’
}
multi method irc-to-me(Message $msg where .text ~~ /:i^ [stdin] [‘ ’|‘=’] $<stdin>=.* $/) {
$default-stdin = self.process-code: ~$<stdin>, $msg;
“STDIN is set to «{shorten $default-stdin, 200}»” # TODO is 200 a good limit
}
multi method irc-to-me(Message $ where .text ~~ /:i^ [source|url] ‘?’? $/ --> SOURCE) {}
multi method irc-to-me(Message $ where .text ~~ /:i^ wiki ‘?’? $/) { self.get-wiki-link }
multi method irc-to-me(Message $msg where .text ~~ /:i^ help ‘?’? $/) {
self.help($msg) ~ “ # See wiki for more examples: {self.get-wiki-link}”
}
multi method irc-to-me(Message $msg where .text ~~ /:i^ uptime $/) {
use nqp;
(denominate now - INIT now) ~ ‘, ’
~ nqp::atpos_i(nqp::getrusage(), nqp::const::RUSAGE_MAXRSS).fmt(‘%.2f’)/1000 ~ ‘KB maxrss. ’
~ (with nqp::getcomp("perl6") {
“This is {.implementation} version {.config<version>} ”
~ “built on {.backend.version_string} ”
~ “implementing {.language_name} {.language_version}.”
})
}
multi method irc-notice-me( $ --> ‘Sorry, it is too private here’) {} # TODO issue #16
multi method irc-privmsg-me($ --> ‘Sorry, it is too private here’) {} # TODO issue #16
multi method irc-to-me($) {
‘I cannot recognize this command. See wiki for some examples: ’ ~ self.get-wiki-link
}
sub I'm-alive is export {
use NativeCall;
sub sd_notify(int32, str --> int32) is native(‘systemd’) {*};
sd_notify 0, ‘WATCHDOG=1’; # this may be called too often, see TODO below
}
multi method irc-all($) {
# TODO https://github.com/zoffixznet/perl6-IRC-Client/issues/50
I'm-alive;
$.NEXT
}
method get-wiki-link { WIKI ~ self.^name }
method get-short-commit($original-commit) { # TODO not an actual solution tbh
$original-commit ~~ /^ <xdigit> ** 7..40 $/
?? $original-commit.substr(0, 7)
!! $original-commit
}
# TODO $default-timeout is VNNull when working in non-OOP style. Rakudobug it?
sub get-output(*@run-args, :$timeout = $default-timeout || 10, :$stdin, :$ENV, :$cwd = $*CWD) is export {
my $proc = Proc::Async.new: |@run-args;
my $fh-stdin;
LEAVE .close with $fh-stdin;
my $temp-file;
LEAVE unlink $_ with $temp-file;
with $stdin {
if $stdin ~~ IO::Path {
$fh-stdin = $stdin.open
} elsif $stdin ~~ IO::Handle {
$fh-stdin = $stdin
} else {
$temp-file = write-code $stdin;
$fh-stdin = $temp-file.IO.open
}
$proc.bind-stdin: $fh-stdin
}
my @chunks;
my $result;
my $s-start = now;
my $s-end;
react {
whenever $proc.stdout { @chunks.push: $_ }; # RT #131763
whenever $proc.stderr { @chunks.push: $_ };
whenever Promise.in($timeout) {
$proc.kill; # TODO sends HUP, but should kill the process tree instead
@chunks.push: “«timed out after $timeout seconds»”
}
whenever $proc.start: :$ENV, :$cwd { #: scheduler => BEGIN ThreadPoolScheduler.new { # TODO do we need to set scheduler?
$result = $_;
$s-end = now;
done
}
}
%(
output => @chunks.join.chomp,
exit-code => $result.exitcode,
signal => $result.signal,
time => $s-end - $s-start,
)
}
sub perl6-grep($stdin, $regex is copy, :$timeout = 180, :$complex = False, :$hack = 0) is export {
my $full-commit = to-full-commit ‘HEAD’ ~ (‘^’ x $hack);
die “No build for $full-commit. Oops!” unless build-exists $full-commit;
$regex = “m⦑ $regex ⦒”;
# TODO can we do something smarter?
my $sep = $complex ?? 「“\0\0”」 !! 「“\0”」;
my $magic = “INIT \$*ARGFILES.nl-in = $sep; INIT \$*OUT.nl-out = $sep;”
~ 「use nqp;」
~ 「 next unless」
~ ($complex ?? 「 nqp::substr($_, 0, nqp::index($_, “\0”)) ~~」 !! ‘’) ~ “\n”
~ $regex ~ “;\n”
~ 「last if $++ > 」 ~ $GIST-LIMIT;
my $filename = write-code $magic;
LEAVE unlink $_ with $filename;
my $result = run-snippet $full-commit, $filename, :$timeout, :$stdin, args => (‘-np’,);
my $output = $result<output>;
# numbers less than zero indicate other weird failures ↓
grumble “Something went wrong ($output)” if $result<signal> < 0;
$output ~= “ «exit code = $result<exit-code>»” if $result<exit-code> ≠ 0;
$output ~= “ «exit signal = {Signal($result<signal>)} ($result<signal>)»” if $result<signal> ≠ 0;
grumble $output if $result<exit-code> ≠ 0 or $result<signal> ≠ 0;
my @elems = $output.split: ($complex ?? “\0\0” !! “\0”), :skip-empty;
if @elems > $GIST-LIMIT {
grumble “Cowardly refusing to gist more than $GIST-LIMIT lines”
}
grumble ‘Found nothing!’ if @elems == 0;
@elems
}
sub build-exists($full-commit-hash, :$backend=‘rakudo-moar’) is export {
“{ARCHIVES-LOCATION}/$backend/$full-commit-hash.zst”.IO ~~ :e
or
“{ARCHIVES-LOCATION}/$backend/$full-commit-hash”.IO ~~ :e # long-term storage (symlink to a large archive)
}
method get-similar($tag-or-hash, @other?, :$repo=$RAKUDO) {
my @options = @other;
my @tags = get-output(cwd => $repo, ‘git’, ‘tag’,
‘--format=%(*objectname)/%(objectname)/%(refname:strip=2)’,
‘--sort=-taggerdate’)<output>.lines
.map(*.split(‘/’))
.grep({ build-exists .[0] || .[1] })
.map(*[2]);
my $cutoff = $tag-or-hash.chars max 7;
my @commits = get-output(cwd => $repo, ‘git’, ‘rev-list’,
‘--all’, ‘--since=2014-01-01’)<output>
.lines.map(*.substr: 0, $cutoff);
# flat(@options, @tags, @commits).min: { sift4($_, $tag-or-hash, 5, 8) }
my $ans = ‘HEAD’;
my $ans_min = ∞;
for flat @options, @tags, @commits {
my $dist = sift4 $_, $tag-or-hash, $cutoff;
if $dist < $ans_min {
$ans = $_;
$ans_min = $dist;
}
}
$ans
}
sub run-smth($full-commit-hash, $code, :$backend=‘rakudo-moar’) is export {
my $build-prepath = “{BUILDS-LOCATION}/$backend”;
my $build-path = “$build-prepath/$full-commit-hash”;
my $archive-path = “{ARCHIVES-LOCATION}/$backend/$full-commit-hash.zst”;
my $archive-link = “{ARCHIVES-LOCATION}/$backend/$full-commit-hash”;
mkdir $build-prepath; # create all parent directories just in case
# (may be needed for isolated /tmp)
# lock on the destination directory to make
# sure that other bots will not get in our way.
while run(:err(Nil), ‘mkdir’, ‘--’, $build-path).exitcode ≠ 0 {
if %*ENV<TESTABLE> {
use NativeCall;
sub kill(int32, int32) is native {*};
sub getppid(--> int32) is native {*};
kill getppid, 10; # SIGUSR1
}
note “$build-path is locked. Waiting…”;
sleep 0.5 # should never happen if setup correctly
}
if $archive-path.IO ~~ :e {
my $proc = run :out, :bin, ‘pzstd’, ‘-dqc’, ‘--’, $archive-path;
run :in($proc.out), :bin, ‘tar’, ‘x’, ‘--absolute-names’;
} else {
my $proc = run :out, :bin, ‘lrzip’, ‘-dqo’, ‘-’, ‘--’, $archive-link;
run :in($proc.out), :bin, ‘tar’, ‘--extract’, ‘--absolute-names’, ‘--’, $build-path;
}
my $return = $code($build-path); # basically, we wrap around $code
rmtree $build-path;
$return
}
# TODO $default-timeout is VNNull when working in non-OOP style. Rakudobug it?
sub run-snippet($full-commit-hash, $file, :$backend=‘rakudo-moar’, :@args=Empty,
:$timeout=$default-timeout||10, :$stdin=$default-stdin, :$ENV) is export {
run-smth :$backend, $full-commit-hash, -> $path {
“$path/bin/perl6”.IO !~~ :e
?? %(output => ‘Commit exists, but a perl6 executable could not be built for it’,
exit-code => -1, signal => -1, time => -1,)
!! get-output “$path/bin/perl6”, |@args,
‘--’, $file, :$stdin, :$timeout, :$ENV
}
}
method get-commits($_, :$repo=$RAKUDO) {
return .split: /‘,’\s*/ if .contains: ‘,’;
if /^ $<start>=\S+ ‘..’ $<end>=\S+ $/ {
if run(:out(Nil), :err(Nil), :cwd($repo),
‘git’, ‘rev-parse’, ‘--verify’, $<start>).exitcode ≠ 0 {
grumble “Bad start, cannot find a commit for “$<start>””
}
if run(:out(Nil), :err(Nil), :cwd($repo),
‘git’, ‘rev-parse’, ‘--verify’, $<end>).exitcode ≠ 0 {
grumble “Bad end, cannot find a commit for “$<end>””
}
my $result = get-output :cwd($repo), ‘git’, ‘rev-list’, ‘--reverse’,
“$<start>^..$<end>”; # TODO unfiltered input
grumble ‘Couldn't find anything in the range’ if $result<exit-code> ≠ 0;
my @commits = $result<output>.lines;
if @commits.elems > COMMITS-LIMIT {
grumble “Too many commits ({@commits.elems}) in range, you're only allowed {COMMITS-LIMIT}”
}
return @commits
}
return self.get-tags: ‘2015-12-24’, :$repo if /:i ^ [ releases | v? 6 ‘.’? c ] $/;
return self.get-tags: ‘2014-01-01’, :$repo if /:i ^ all $/;
return ~$<commit> if /:i ^ compare \s $<commit>=\S+ $/;
return $_
}
method get-tags($date, :$repo=$RAKUDO) {
my @tags = <HEAD>;
my %seen;
for get-output(cwd => $repo, ‘git’, ‘log’, ‘--pretty="%d"’,
‘--tags’, ‘--no-walk’, “--since=$date”)<output>.lines -> $tag {
next unless $tag ~~ /:i ‘tag:’ \s* ((\d\d\d\d\.\d\d)[\.\d\d?]?) /; # TODO use tag -l
next if $!bad-releases{$0}:exists;
next if %seen{$0[0]}++;
@tags.push($0)
}
@tags.reverse
}
sub to-full-commit($commit, :$short=False, :$repo=$RAKUDO) is export {
return if run(:out(Nil), :err(Nil), :cwd($repo),
‘git’, ‘rev-parse’, ‘--verify’, $commit).exitcode ≠ 0; # make sure that $commit is valid
my $result = get-output cwd => $repo,
|(‘git’, ‘rev-list’, ‘-1’, # use rev-list to handle tags
($short ?? ‘--abbrev-commit’ !! Empty), $commit);
return if $result<exit-code> ≠ 0;
return unless $result<output>;
$result<output>
}
sub write-code($code) is export {
my ($filename, $filehandle) = tempfile :!unlink;
$filehandle.print: $code;
$filehandle.close;
$filename
}
sub process-url($url, $msg) is export {
my $ua = HTTP::UserAgent.new;
my $response;
try {
$response = $ua.get: $url;
CATCH {
grumble ‘It looks like a URL, but for some reason I cannot download it’
~ “ ({.message})”
}
}
if not $response.is-success {
grumble ‘It looks like a URL, but for some reason I cannot download it’
~ “ (HTTP status line is {$response.status-line}).”
}
if not $response.content-type.contains: ‘text/plain’ | ‘perl’ {
grumble “It looks like a URL, but mime type is ‘{$response.content-type}’”
~ ‘ while I was expecting something with ‘text/plain’ or ‘perl’’
~ ‘ in it. I can only understand raw links, sorry.’
}
my $body = $response.decoded-content;
.reply: ‘Successfully fetched the code from the provided URL.’ with $msg;
sleep 0.02; # https://github.com/perl6/whateverable/issues/163
$body
}
method process-code($code is copy, $msg) {
$code ~~ m{^ ( ‘http’ s? ‘://’ \S+ ) }
?? process-url(~$0, $msg)
!! $code.subst: :g, ‘␤’, “\n”
}
multi method filter($response where (.encode.elems > MESSAGE-LIMIT
or ?.?additional-files
or (!~$_ and $_ ~~ ProperStr))) {
# Here $response is a Str with a lot of stuff mixed in (possibly)
my $description = ‘Whateverable’;
my $text = colorstrip $response.?long-str // ~$response;
my %files;
%files<result> = $text if $text;
%files.push: $_ with $response.?additional-files;
if $response ~~ Reply {
$description = $response.msg.server.current-nick;
%files<query> = $_ with $response.?msg.text;
}
my $url = self.upload: %files, public => !%*ENV<DEBUGGABLE>, :$description;
$url = $response.link-msg()($url) if $response ~~ PrettyLink;
$url
}
multi method filter($text is copy) {
ansi-to-irc($text).trans:
“\n” => ‘␤’,
3.chr => 3.chr, 0xF.chr => 0xF.chr, # keep these for IRC colors
|((^32)».chr Z=> (0x2400..*).map(*.chr)), # convert all unreadable ASCII crap
127.chr => ‘␡’, /<:Cc>/ => ‘␦’
}
method upload(%files is copy, :$description = ‘’, Bool :$public = True) {
if %*ENV<TESTABLE> {
my $nick = $.irc.servers.values[0].current-nick;
my $gists-path = “{BUILDS-LOCATION}/tist/$nick”;
rmtree $gists-path if $gists-path.IO ~~ :d;
mkdir $gists-path;
spurt “$gists-path/{.key}”, .value for %files;
return ‘https://whatever.able/fakeupload’;
}
state $config = from-json slurp CONFIG;
%files = %files.pairs.map: { .key => %( ‘content’ => .value ) }; # github format
my $gist = Pastebin::Gist.new(token => $config<github><access_token>);
return $gist.paste: %files, desc => $description, public => $public
}
method selfrun($nick is copy, @alias?) {
$nick ~= ‘test’ if %*ENV<DEBUGGABLE>;
.run with IRC::Client.new(
:$nick
:userreal($nick.tc)
:username($nick.substr(0, 3) ~ ‘-able’)
:password(?%*ENV<TESTABLE> ?? ‘’ !! from-json(slurp CONFIG)<irc><login password>.join: ‘:’)
:@alias
# IPv4 address of chat.freenode.net is hardcoded so that we can double the limit ↓
:host(%*ENV<TESTABLE> ?? ‘127.0.0.1’ !! (‘chat.freenode.net’, ‘185.30.166.38’).pick)
:channels(%*ENV<DEBUGGABLE>
?? ‘#whateverable’
!! %*ENV<TESTABLE>
?? “#whateverable_$nick”
!! (|<#perl6 #perl6-dev #zofbot #moarvm>, $CAVE) )
:debug(?%*ENV<DEBUGGABLE>)
:plugins(self)
:filters( -> |c { self.filter(|c) } )
)
}
# TODO move somewhere
# TODO commit unused
sub subprocess-commit($commit, $filename, $full-commit, :%ENV) is export {
return ‘No build for this commit’ unless build-exists $full-commit;
$_ = run-snippet $full-commit, $filename, :%ENV; # actually run the code
# numbers less than zero indicate other weird failures ↓
return “Cannot test this commit ($_<output>)” if .<signal> < 0;
my $output = .<output>;
$output ~= “ «exit code = $_<exit-code>»” if .<exit-code> ≠ 0;
$output ~= “ «exit signal = {Signal($_<signal>)} ($_<signal>)»” if .<signal> ≠ 0;
$output
}
# vim: expandtab shiftwidth=4 ft=perl6
diff --git a/bin/Committable.p6 b/bin/Committable.p6
index 2e1405e..e227461 100755
--- a/bin/Committable.p6
+++ b/bin/Committable.p6
@@ -65,24 +65,12 @@ method process-commit($commit, $filename, :%ENV) {
my $short-commit = self.get-short-commit: $commit;
$short-commit ~= “({self.get-short-commit: $full-commit})” if $commit eq ‘HEAD’;
- $short-commit R=> self.subprocess-commit: $commit, $filename, $full-commit, :%ENV;
-}
-
-method subprocess-commit($commit, $filename, $full-commit, :%ENV) {
without $full-commit {
- return ‘Cannot find this revision (did you mean “’ ~
+ return $short-commit R=> ‘Cannot find this revision (did you mean “’ ~
self.get-short-commit(self.get-similar: $commit, <HEAD v6.c releases all>) ~
‘”?)’
}
- return ‘No build for this commit’ unless build-exists $full-commit;
-
- $_ = run-snippet $full-commit, $filename, :%ENV; # actually run the code
- # numbers less than zero indicate other weird failures ↓
- return “Cannot test this commit ($_<output>)” if .<signal> < 0;
- my $output = .<output>;
- $output ~= “ «exit code = $_<exit-code>»” if .<exit-code> ≠ 0;
- $output ~= “ «exit signal = {Signal($_<signal>)} ($_<signal>)»” if .<signal> ≠ 0;
- $output
+ $short-commit R=> self.process-commit: $commit, $filename, $full-commit, :%ENV;
}
method process($msg, $config is copy, $code is copy, :%ENV) {
diff --git a/bin/Quotable.p6 b/bin/Quotable.p6
index dfbabc8..5072b8f 100755
--- a/bin/Quotable.p6
+++ b/bin/Quotable.p6
@@ -24,20 +24,36 @@ use IRC::Client;
unit class Quotable does Whateverable;
-my $CACHE-FILE = ‘data/irc/cache’.IO;
+my $CACHE-DIR = ‘data/irc/’.IO;
+my $LINK = ‘https://irclog.perlgeek.de’;
method help($msg) {
“Like this: {$msg.server.current-nick}: /^ ‘bisect: ’ /”
}
+my atomicint $hack = 0;
multi method irc-to-me($msg where /^ \s* [ || ‘/’ $<regex>=[.*] ‘/’
|| $<regex>=[.*?] ] \s* $/) {
- my $answer = perl6-grep($CACHE-FILE, ~$<regex>).join: “\n”;
- ‘’ but ProperStr($answer)
+ $hack ⚛= 0;
+ my $regex = $<regex>;
+ my $messages = $CACHE-DIR.dir(test => *.ends-with: ‘.total’)».slurp».trim».Int.sum;
+ $msg.reply: “OK, working on it! This may take up to three minutes ($messages messages to process)”;
+ my %channels = await do for $CACHE-DIR.dir(test => *.ends-with: ‘.cache’) {
+ my $channel = .basename.subst(/ ^‘#’ /, ‘’).subst(/ ‘.cache’$ /, ‘’);
+ start “result-#$channel.md” => process-channel $_, $channel, ~$regex
+ }
+ ‘’ but FileStore(%channels)
+}
+
+sub process-channel($file, $channel, $regex-str) {
+ perl6-grep($file, $regex-str, :complex, hack => $hack⚛++).map({
+ my @parts = .split: “\0”; # text, id, date
+ my $backticks = 「`」 x (1 + (@parts[0].comb(/「`」+/) || ‘’).max.chars);
+ # TODO proper escaping
+ “[$backticks @parts[0] $backticks]($LINK/$channel/@parts[2]#i_@parts[1])<br>”
+ }).join(“\n”)
}
-# ⚠ Quotable is currently broken. See issue #24
-#exit 1;
Quotable.new.selfrun: ‘quotable6’, [ / quote6? <before ‘:’> /,
fuzzy-nick(‘quotable6’, 2) ]
diff --git a/bin/build.p6 b/bin/build.p6
index a737ff8..538ff3b 100755
--- a/bin/build.p6
+++ b/bin/build.p6
@@ -37,6 +37,10 @@ my \EVERYTHING-RANGE = ‘2014.01^..HEAD’; # to build everything, but in hist
my \WORKING-DIRECTORY = ‘.’; # TODO not supported yet
+my \RAKUDO-NQP-ORIGIN = ‘https://github.com/perl6/nqp.git’;
+my \RAKUDO-NQP-LATEST = “/tmp/whateverable/rakudo-triple-nqp-repo”;
+my \RAKUDO-MOAR-ORIGIN = ‘https://github.com/MoarVM/MoarVM.git’;
+my \RAKUDO-MOAR-LATEST = “/tmp/whateverable/rakudo-triple-moar-repo”;
my \REPO-ORIGIN = RAKUDOISH
?? ‘https://github.com/rakudo/rakudo.git’
!! ‘https://github.com/MoarVM/MoarVM.git’;
@@ -60,13 +64,19 @@ exit 0 unless run ‘mkdir’, :err(Nil), ‘--’, BUILD-LOCK; # only one insta
my $locked = True;
END BUILD-LOCK.IO.rmdir if $locked;
-if REPO-LATEST.IO ~~ :d {
- my $old-dir = $*CWD;
- LEAVE chdir $old-dir;
- chdir REPO-LATEST;
- run ‘git’, ‘pull’;
-} else {
- exit unless run ‘git’, ‘clone’, ‘--’, REPO-ORIGIN, REPO-LATEST;
+sub pull-or-clone($repo-origin, $repo-path) {
+ if $repo-path.IO ~~ :d {
+ my $old-dir = $*CWD;
+ run :cwd($repo-path), ‘git’, ‘pull’;
+ } else {
+ exit unless run ‘git’, ‘clone’, ‘--’, $repo-origin, $repo-path;
+ }
+}
+
+pull-or-clone REPO-ORIGIN, REPO-LATEST;
+if RAKUDOISH {
+ pull-or-clone RAKUDO-NQP-ORIGIN, RAKUDO-NQP-LATEST;
+ pull-or-clone RAKUDO-MOAR-ORIGIN, RAKUDO-MOAR-LATEST;
}
if REPO-CURRENT.IO !~~ :d {
@@ -75,21 +85,61 @@ if REPO-CURRENT.IO !~~ :d {
my $channel = Channel.new;
-my @git-latest = ‘git’, ‘--git-dir’, “{REPO-LATEST}/.git”, ‘--work-tree’, REPO-LATEST;
-my @args-tags = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, ‘--tags’, ‘--no-walk’, ‘--since’, TAGS-SINCE;
-my @args-latest = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, COMMIT-RANGE;
-my @args-recent = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, ‘--all’, ‘--since’, ALL-SINCE;
-my @args-old = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, ‘--reverse’, EVERYTHING-RANGE;
+my @git-log = ‘git’, ‘log’, ‘-z’, ‘--pretty=%H’;
+my @args-tags = |@git-log, ‘--tags’, ‘--no-walk’, ‘--since’, TAGS-SINCE;
+my @args-latest = |@git-log, COMMIT-RANGE;
+my @args-recent = |@git-log, ‘--all’, ‘--since’, ALL-SINCE;
+my @args-old = |@git-log, ‘--reverse’, EVERYTHING-RANGE;
my %commits;
+
+# Normal Rakudo commits
for @args-tags, @args-latest, @args-recent, @args-old -> @_ {
- for run(:out, |@_).out.split(0.chr, :skip-empty) {
+ for run(:cwd(REPO-LATEST), :out, |@_).out.split(0.chr, :skip-empty) {
next if %commits{$_}:exists;
%commits{$_}++;
$channel.send: $_
}
}
+sub get-build-revision($repo, $on-commit, $file) {
+ run(:cwd($repo), :out, ‘git’, ‘show’,
+ “{$on-commit}:tools/build/$file”).out.slurp-rest.trim
+}
+
+# Rakudo-NQP-Moar triples (for bumps)
+#`「「「
+if PROJECT == Rakudo-Moar {
+ my @args-bumps = ‘git’, ‘log’, ‘-z’, ‘--pretty=%x00%H’,
+ ‘--follow’, ‘--reverse’,
+ EVERYTHING-RANGE, ‘tools/build/NQP_REVISION’;
+ for run(:cwd(REPO-LATEST), :out, |@args-bumps)
+ .out.split(0.chr, :skip-empty).rotor(2) -> ($rakudo-sha, $diff) {
+ #my $nqp-old = get-build-revision REPO-LATEST, “$rakudo-sha^”, ‘NQP_REVISION’;
+ #my $nqp-new = get-build-revision REPO-LATEST, “$rakudo-sha”, ‘NQP_REVISION’;
+
+ #say “$rakudo-sha”;
+ for run(:cwd(RAKUDO-NQP-LATEST), :out, |@git-log, “$nqp-old..$nqp-new”)
+ .out.split(0.chr, :skip-empty) -> $nqp-sha {
+ my $moar-sha = get-build-revision RAKUDO-NQP-LATEST, “$nqp-sha”, ‘MOAR_REVISION’;
+ # TODO shas are not shas
+ say “|- $nqp-sha - $moar-sha”;
+ }
+ for run(:cwd(RAKUDO-NQP-LATEST), :out, |@git-log, ‘--follow’, ‘--reverse’,
+ “$nqp-old..$nqp-new”, ‘tools/build/MOAR_REVISION’)
+ .out.split(0.chr, :skip-empty) -> $nqp-sha {
+ my $moar-old = get-build-revision RAKUDO-NQP-LATEST, “$nqp-sha^”, ‘MOAR_REVISION’;
+ my $moar-new = get-build-revision RAKUDO-NQP-LATEST, “$nqp-sha”, ‘MOAR_REVISION’;
+ for run(:cwd(RAKUDO-MOAR-LATEST), :out, |@git-log, “$moar-old..$moar-new”)
+ .out.split(0.chr, :skip-empty) -> $moar-sha {
+ say “ |- $moar-sha”;
+ }
+ }
+ }
+}
+# 」」」
+
+
await (for ^PARALLEL-COUNT { # TODO rewrite when .race starts working in rakudo
start loop {
my $commit = $channel.poll;
diff --git a/lib/Whateverable.pm6 b/lib/Whateverable.pm6
index b7d5a0e..a4e777f 100644
--- a/lib/Whateverable.pm6
+++ b/lib/Whateverable.pm6
@@ -171,11 +171,15 @@ multi method irc-to-me($) {
‘I cannot recognize this command. See wiki for some examples: ’ ~ self.get-wiki-link
}
-multi method irc-all($) {
- # TODO https://github.com/zoffixznet/perl6-IRC-Client/issues/50
+sub I'm-alive is export {
use NativeCall;
sub sd_notify(int32, str --> int32) is native(‘systemd’) {*};
- sd_notify 0, ‘WATCHDOG=1’; # this may be called too often, see TODO above
+ sd_notify 0, ‘WATCHDOG=1’; # this may be called too often, see TODO below
+}
+
+multi method irc-all($) {
+ # TODO https://github.com/zoffixznet/perl6-IRC-Client/issues/50
+ I'm-alive;
$.NEXT
}
@@ -188,7 +192,8 @@ method get-short-commit($original-commit) { # TODO not an actual solution tbh
!! $original-commit
}
-sub get-output(*@run-args, :$timeout = $default-timeout, :$stdin, :$ENV, :$cwd = $*CWD) is export {
+# TODO $default-timeout is VNNull when working in non-OOP style. Rakudobug it?
+sub get-output(*@run-args, :$timeout = $default-timeout || 10, :$stdin, :$ENV, :$cwd = $*CWD) is export {
my $proc = Proc::Async.new: |@run-args;
my $fh-stdin;
@@ -232,13 +237,16 @@ sub get-output(*@run-args, :$timeout = $default-timeout, :$stdin, :$ENV, :$cwd =
)
}
-sub perl6-grep($stdin, $regex is copy, :$timeout = 180) is export {
- my $full-commit = to-full-commit ‘HEAD’;
+sub perl6-grep($stdin, $regex is copy, :$timeout = 180, :$complex = False, :$hack = 0) is export {
+ my $full-commit = to-full-commit ‘HEAD’ ~ (‘^’ x $hack);
die “No build for $full-commit. Oops!” unless build-exists $full-commit;
$regex = “m⦑ $regex ⦒”;
# TODO can we do something smarter?
- my $magic = 「INIT $*ARGFILES.nl-in = 0.chr; INIT $*OUT.nl-out = 0.chr;」
- ~ 「 next unless」 ~ “\n”
+ my $sep = $complex ?? 「“\0\0”」 !! 「“\0”」;
+ my $magic = “INIT \$*ARGFILES.nl-in = $sep; INIT \$*OUT.nl-out = $sep;”
+ ~ 「use nqp;」
+ ~ 「 next unless」
+ ~ ($complex ?? 「 nqp::substr($_, 0, nqp::index($_, “\0”)) ~~」 !! ‘’) ~ “\n”
~ $regex ~ “;\n”
~ 「last if $++ > 」 ~ $GIST-LIMIT;
my $filename = write-code $magic;
@@ -251,8 +259,7 @@ sub perl6-grep($stdin, $regex is copy, :$timeout = 180) is export {
$output ~= “ «exit code = $result<exit-code>»” if $result<exit-code> ≠ 0;
$output ~= “ «exit signal = {Signal($result<signal>)} ($result<signal>)»” if $result<signal> ≠ 0;
grumble $output if $result<exit-code> ≠ 0 or $result<signal> ≠ 0;
-
- my @elems = $output.split: “\0”, :skip-empty;
+ my @elems = $output.split: ($complex ?? “\0\0” !! “\0”), :skip-empty;
if @elems > $GIST-LIMIT {
grumble “Cowardly refusing to gist more than $GIST-LIMIT lines”
}
@@ -327,8 +334,9 @@ sub run-smth($full-commit-hash, $code, :$backend=‘rakudo-moar’) is export {
$return
}
+# TODO $default-timeout is VNNull when working in non-OOP style. Rakudobug it?
sub run-snippet($full-commit-hash, $file, :$backend=‘rakudo-moar’, :@args=Empty,
- :$timeout=$default-timeout, :$stdin=$default-stdin, :$ENV) is export {
+ :$timeout=$default-timeout||10, :$stdin=$default-stdin, :$ENV) is export {
run-smth :$backend, $full-commit-hash, -> $path {
“$path/bin/perl6”.IO !~~ :e
?? %(output => ‘Commit exists, but a perl6 executable could not be built for it’,
@@ -496,4 +504,18 @@ method selfrun($nick is copy, @alias?) {
)
}
+# TODO move somewhere
+# TODO commit unused
+sub subprocess-commit($commit, $filename, $full-commit, :%ENV) is export {
+ return ‘No build for this commit’ unless build-exists $full-commit;
+
+ $_ = run-snippet $full-commit, $filename, :%ENV; # actually run the code
+ # numbers less than zero indicate other weird failures ↓
+ return “Cannot test this commit ($_<output>)” if .<signal> < 0;
+ my $output = .<output>;
+ $output ~= “ «exit code = $_<exit-code>»” if .<exit-code> ≠ 0;
+ $output ~= “ «exit signal = {Signal($_<signal>)} ($_<signal>)»” if .<signal> ≠ 0;
+ $output
+}
+
# vim: expandtab shiftwidth=4 ft=perl6
diff --git a/services/whateverable-all.service b/services/whateverable-all.service
index 5d1f640..202675a 100644
--- a/services/whateverable-all.service
+++ b/services/whateverable-all.service
@@ -17,6 +17,7 @@ Wants=whateverable@Coverable.service
Wants=whateverable@Releasable.service
Wants=whateverable@Nativecallable.service
Wants=whateverable@Squashable.service
+Wants=whateverable@Regressionable.service
[Service]
Type=oneshot
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment