App-Rakubrew
view release on metacpan or search on metacpan
lib/App/Rakubrew.pm view on Meta::CPAN
);
my $self = bless \%opt, $class;
return $self;
}
sub run_script {
my ($self) = @_;
my @args = @{$self->{args}};
sub _cant_access_home {
say STDERR "Can't create rakubrew home directory in $prefix";
say STDERR "Probably rakubrew was denied access. You can either change that folder to be writable";
say STDERR "or set a different rakubrew home directory by setting the `\$RAKUBREW_HOME` environment";
say STDERR "prior to calling the rakubrew shell hook. ";
exit 1;
}
unless (-d $prefix) {
_cant_access_home() unless mkdir $prefix;
}
mkdir(catdir($prefix, 'bin')) || _cant_access_home() unless (-d catdir($prefix, 'bin'));
mkdir(catdir($prefix, 'update')) || _cant_access_home() unless (-d catdir($prefix, 'update'));
mkdir(catdir($prefix, 'repos')) || _cant_access_home() unless (-d catdir($prefix, 'repos'));
lib/App/Rakubrew.pm view on Meta::CPAN
shift @args; # Remove the shell parameter for the same reason.
}
elsif (
get_brew_mode() eq 'env'
&& !(@args && $args[0] eq 'mode' && $args[1] eq 'shim')
&& !(@args && $args[0] eq 'init')
&& !(@args && $args[0] eq 'home')
&& !(@args && $args[0] =~ /^internal_/)
|| @args && $args[0] eq 'shell'
|| @args >= 2 && $args[0] eq 'mode' && $args[1] eq 'env') {
say STDERR << "EOL";
The shell hook required to run rakubrew in either 'env' mode or with the 'shell' command seems not to be installed.
Run '$brew_name init' for installation instructions if you want to use those features,
or run '$brew_name mode shim' to use 'shim' mode which doesn't require a shell hook.
EOL
exit 1;
}
my $arg = shift(@args) // 'help';
if ($arg eq 'version' || $arg eq 'current') {
if (my $c = get_version()) {
if (@args && $args[0] eq '--short') {
say "$c"
}
else {
say "Currently running $c"
}
} else {
say STDERR "Not running anything at the moment. Use '$brew_name switch' to set a version";
exit 1;
}
} elsif ($arg eq 'versions' || $arg eq 'list') {
my $cur = get_version() // '';
map {
my $version_line = '';
$version_line .= 'BROKEN ' if is_version_broken($_);
$version_line .= $_ eq $cur ? '* ' : ' ';
$version_line .= $_;
$version_line .= ' -> ' . (get_version_path($_, 1) || '') if is_registered_version($_);
say $version_line;
} get_versions();
} elsif ($arg eq 'global' || $arg eq 'switch') {
if (!@args) {
my $version = get_global_version();
if ($version) {
say $version;
}
else {
say "$brew_name: no global version configured";
}
}
else {
$self->match_and_run($args[0], sub {
set_global_version(shift);
});
}
} elsif ($arg eq 'shell') {
if (!@args) {
my $shell_version = get_shell_version();
if (defined $shell_version) {
say "$shell_version";
}
else {
say "$brew_name: no shell-specific version configured";
}
}
else {
my $version = shift @args;
if ($version ne '--unset') {
verify_version($version);
}
}
} elsif ($arg eq 'local') {
validate_brew_mode();
if (!@args) {
my $version = get_local_version();
if ($version) {
say $version;
}
else {
say "$brew_name: no local version configured for this directory";
}
}
else {
my $version = shift @args;
if ($version eq '--unset') {
set_local_version(undef);
}
else {
$self->match_and_run($version, sub {
set_local_version(shift);
lib/App/Rakubrew.pm view on Meta::CPAN
} elsif ($arg eq 'rehash') {
validate_brew_mode();
rehash();
} elsif ($arg eq 'list-available' || $arg eq 'available') {
my ($cur_backend, $cur_rakudo) = split '-', (get_version() // ''), 2;
$cur_backend //= '';
$cur_rakudo //= '';
my @downloadables = App::Rakubrew::Download::available_precomp_archives();
say "Available Rakudo versions:";
map {
my $ver = $_;
my $d = (grep {$_->{ver} eq $ver} @downloadables) ? 'D' : ' ';
my $s = $cur_rakudo eq $ver ? '*' : ' ';
say "$s$d $ver";
} App::Rakubrew::Build::available_rakudos();
say '';
$cur_backend |= '';
$cur_rakudo |= '';
say "Available backends:";
map { say $cur_backend eq $_ ? "* $_" : " $_" } App::Rakubrew::Variables::available_backends();
} elsif ($arg eq 'build-rakudo' || $arg eq 'build') {
my ($impl, $ver, @args) =
App::Rakubrew::VersionHandling::match_version(@args);
if (!$ver) {
my @versions = App::Rakubrew::Build::available_rakudos();
@versions = grep { /^\d\d\d\d\.\d\d/ } @versions;
$ver = $versions[-1];
}
if ($impl eq "panda") {
say "panda is discontinued; please use zef (rakubrew build-zef) instead";
} elsif ($impl eq "zef") {
my $version = get_version();
if (!$version) {
say STDERR "$brew_name: No version set.";
exit 1;
}
App::Rakubrew::Build::build_zef($version);
# Might have new executables now -> rehash.
rehash();
say "Done, built zef for $version";
} elsif (!exists $impls{$impl}) {
my $warning = "Cannot build Rakudo with backend '$impl': this backend ";
if ($impl eq "parrot") {
$warning .= "is no longer supported.";
} else {
$warning .= "does not exist.";
}
say $warning;
exit 1;
}
else {
my $configure_opts = '';
if (@args && $args[0] =~ /^--configure-opts=/) {
$configure_opts = shift @args;
$configure_opts =~ s/^\-\-configure-opts=//;
$configure_opts =~ s/^'//;
$configure_opts =~ s/'$//;
}
if ($configure_opts =~ /--prefix/) {
say STDERR "Building Rakudo in a custom folder is not supported. If you need";
say STDERR "this it's recommended to build it manually and then use the";
say STDERR "`register` command to make that installation available in Rakubrew.";
exit 1;
}
my $name = "$impl-$ver";
$name = $impl if $impl eq 'moar-blead' && $ver eq 'main';
if ($impl && $impl eq 'all') {
for (App::Rakubrew::Variables::available_backends()) {
App::Rakubrew::Build::build_impl($_, $ver, $configure_opts);
}
} else {
App::Rakubrew::Build::build_impl($impl, $ver, $configure_opts);
}
# Might have new executables now -> rehash.
rehash();
if (get_version() eq 'system') {
set_global_version($name);
}
say "Done, $name built";
}
} elsif ($arg eq 'triple') {
my ($rakudo_ver, $nqp_ver, $moar_ver) = @args[0 .. 2];
my $name = App::Rakubrew::Build::build_triple($rakudo_ver, $nqp_ver, $moar_ver);
# Might have new executables now -> rehash
rehash();
if (get_version() eq 'system') {
set_global_version($name);
}
say "Done, $name built";
} elsif ($arg eq 'download-rakudo' || $arg eq 'download') {
my ($impl, $ver, @args) =
App::Rakubrew::VersionHandling::match_version(@args);
if (!exists $impls{$impl}) {
say STDERR "Cannot download Rakudo on '$impl': this backend does not exist.";
exit 1;
}
my $name = App::Rakubrew::Download::download_precomp_archive($impl, $ver);
# Might have new executables now -> rehash
rehash();
if (get_version() eq 'system') {
set_global_version("$name");
}
say "Done, $name installed";
} elsif ($arg eq 'register') {
my ($name, $path) = @args[0 .. 1];
if (!$name || !$path) {
say STDERR "$brew_name: Need a version name and rakudo installation path";
exit 1;
}
if (version_exists($name)) {
say STDERR "$brew_name: Version $name already exists";
exit 1;
}
sub invalid {
my $path = shift;
say STDERR "$brew_name: No valid rakudo installation found at '$path'";
exit 1;
}
$path = rel2abs($path);
invalid($path) if is_version_path_broken($path);
$path = clean_version_path($path);
spurt(catfile($versions_dir, $name), $path);
} elsif ($arg eq 'build-zef') {
my $version = get_version();
my $zef_version = shift(@args);
if (!$version) {
say STDERR "$brew_name: No version set.";
exit 1;
}
say("Building zef ", $zef_version || "latest");
App::Rakubrew::Build::build_zef($version, $zef_version);
# Might have new executables now -> rehash
rehash();
say "Done, built zef for $version";
} elsif ($arg eq 'build-panda') {
say "panda is discontinued; please use zef (rakubrew build-zef) instead";
} elsif ($arg eq 'exec') {
my $param = shift @args;
if ($param eq '--with') {
my $version = shift @args;
my $prog_name = shift @args;
$self->do_exec_with_version($version, $prog_name, \@args);
}
else {
$self->do_exec($param, \@args);
}
} elsif ($arg eq 'which') {
if (!@args) {
say STDERR "Usage: $brew_name which <command>";
}
else {
my $version = get_version();
if (!$version) {
say STDERR "$brew_name: No version set.";
exit 1;
}
map {say $_} which($args[0], $version);
}
} elsif ($arg eq 'whence') {
if (!@args) {
say STDERR "Usage: $brew_name whence [--path] <command>";
}
else {
my $param = shift @args;
my $pathmode = $param eq '--path';
my $prog = $pathmode ? shift(@args) : $param;
map {say $_} whence($prog, $pathmode);
}
} elsif ($arg eq 'mode') {
if (!@args) {
say get_brew_mode();
}
else {
set_brew_mode($args[0]);
}
} elsif ($arg eq 'self-upgrade') {
App::Rakubrew::Update::update();
} elsif ($arg eq 'init') {
$self->init(@args);
} elsif ($arg eq 'home') {
say $prefix;
} elsif ($arg eq 'test') {
my $version = shift @args;
if (!$version) {
$self->test(get_version());
}
elsif ($version eq 'all') {
for (get_versions()) {
$self->test($_);
}
lib/App/Rakubrew.pm view on Meta::CPAN
# - .exe/.bat/.cmd -> return "filename"
# - .nqp -> return "nqp filename"
# - shebang contains raku|perl6 -> return "raku|perl6 filename"
# - shebang contains perl -> return "perl filename"
# - nothing of the above -> return "filename" # if we can't
# figure out what to do with this
# filename, let Windows have a try.
# The first line is potentially the shebang. Thus the search for "perl" and/or perl6/raku.
my ($basename, undef, $suffix) = my_fileparse($prog_name);
if($suffix =~ /^\Q\.(exe|bat|cmd)\E\z/i) {
say $path;
}
elsif($suffix =~ /^\Q\.nqp\E\z/i) {
say which('nqp', get_version()).' '.$path;
}
else {
open(my $fh, '<', $path);
my $first_line = <$fh>;
close($fh);
if($first_line =~ /#!.*(perl6|raku)/) {
say get_raku(get_version()) . ' ' . $path;
}
elsif($first_line =~ /#!.*perl/) {
say 'perl '.$path;
}
else {
say $path;
}
}
} elsif ($arg eq 'internal_update') {
App::Rakubrew::Update::internal_update(@args);
} elsif ($arg eq 'rakubrew-version') {
say "rakubrew v$VERSION Build type: $distro_format OS: $^O";
} else {
require Pod::Usage;
my $help_text = "";
open my $pod_fh, ">", \$help_text;
my $verbose = 0;
@args = grep {
if ($_ eq '-v' || $_ eq '--verbose') {
$verbose = 1;
lib/App/Rakubrew.pm view on Meta::CPAN
-verbose => $verbose ? 2 : 1, # 1 = only SYNOPSIS, 2 = print everything
-output => $pod_fh, # filehandle reference
-noperldoc => 1 # do not call perldoc
);
}
close $pod_fh;
my $backends = join '|', App::Rakubrew::Variables::available_backends(), 'all';
say $help_text;
}
}
sub match_and_run {
my ($self, $version, $action) = @_;
if (!$version) {
say "Which version do you mean?";
say "Available builds:";
map {say} get_versions();
return;
}
if (grep { $_ eq $version } get_versions()) {
$action->($version);
}
else {
say "Sorry, '$version' not found.";
my @match = grep { /\Q$version/ } get_versions();
if (@match) {
say "Did you mean:";
say $_ for @match;
}
}
}
sub test {
my ($self, $version) = @_;
$self->match_and_run($version, sub {
my $matched = shift;
verify_version($matched);
my $v_dir = catdir($versions_dir, $matched);
if (!-d $v_dir) {
say STDERR "Version $matched was not built by rakubrew.";
say STDERR "Refusing to try running spectest there.";
exit 1;
}
chdir catdir($versions_dir, $matched);
say "Spectesting $matched";
if (!-f 'Makefile') {
say STDERR "Can only run spectest in self built Rakudos.";
say STDERR "This Rakudo is not self built.";
exit 1;
}
run(App::Rakubrew::Build::determine_make($matched), 'spectest');
});
}
sub nuke {
my ($self, $version) = @_;
$self->match_and_run($version, sub {
my $matched = shift;
if (is_registered_version($matched)) {
say "Unregistering $matched";
unlink(catfile($versions_dir, $matched));
}
elsif ($matched eq 'system') {
say 'I refuse to nuke system Raku!';
exit 1;
}
elsif ($matched eq get_version()) {
say "$matched is currently active. I refuse to nuke.";
exit 1;
}
else {
say "Nuking $matched";
remove_tree(catdir($versions_dir, $matched));
}
});
# Might have lost executables -> rehash
rehash();
}
sub init {
my $self = shift;
my $brew_exec = catfile($RealBin, $brew_name);
if (+@_ == 1) {
# We have an argument. That has to be the shell.
# We already retrieved the shell above, so no need to look at the passed argument here again.
say $self->{hook}->get_init_code;
}
else {
my $shell = ref($self->{hook});
$shell =~ s/.+:://;
my $shell_text = join('|', App::Rakubrew::Shell->available_shells);
my $text = <<EOT;
Your shell has been identified as $shell. If that's wrong, run
$brew_exec init --shell $shell_text
EOT
say $text;
say $self->{hook}->install_note;
}
}
sub de_par_environment {
# The PAR packager modifies the environment.
# We undo those modifications here.
# The following code was kindly provided by Roderich Schupp
# via email.
my $ldlibpthname = $Config::Config{ldlibpthname};
lib/App/Rakubrew/Build.pm view on Meta::CPAN
sub build_impl {
my ($impl, $ver, $configure_opts) = @_;
_check_build_dependencies();
my $name = "$impl-$ver";
$name = $impl if $impl eq 'moar-blead' && $ver eq 'main';
if (version_exists($name) && is_registered_version($name)) {
say STDERR "$name is a registered version. I'm not going to touch it.";
exit 1;
}
chdir $versions_dir;
unless (version_exists($name)) {
for(@{$impls{$impl}{need_repo}}) {
_update_git_reference($_);
}
run "$GIT clone --reference \"$git_reference/rakudo\" $git_repos{rakudo} $name";
}
chdir $name;
run "$GIT fetch";
# when people say 'build somebranch', they usually mean 'build origin/somebranch'
my $ver_to_checkout = $ver;
eval {
run "$GIT rev-parse -q --verify origin/$ver";
$ver_to_checkout = "origin/$ver";
};
run "$GIT checkout -q $ver_to_checkout";
$configure_opts .= ' ' . _get_git_cache_option(cwd());
run $impls{$impl}{configure} . " $configure_opts";
if (is_version_broken($name)) {
say STDERR "ERROR: The build does not look usable. There is no raku executable to be";
say STDERR "found in $versions_dir/$name/bin";
say STDERR "or in $versions_dir/$name/install/bin";
exit 1;
}
}
sub determine_make {
my $version = shift;
my $cmd = get_raku($version) . ' --show-config';
my $config = qx{$cmd};
my $make;
$make = $1 if $config =~ m/::make=(.*)$/m;
if (!$make) {
say STDERR "Couldn't determine correct make program. Aborting.";
exit 1;
}
return $make;
}
sub build_triple {
my ($rakudo_ver, $nqp_ver, $moar_ver) = @_;
_check_build_dependencies();
lib/App/Rakubrew/Build.pm view on Meta::CPAN
run "$PERL5 Configure.pl " . $configure_opts;
chdir updir();
run "$PERL5 Configure.pl --backend=moar " . $configure_opts;
chdir updir();
run "$PERL5 Configure.pl --backend=moar " . $configure_opts;
if (-d 'zef') {
say "Updating zef as well";
build_zef($name);
}
return $name;
}
sub _verify_git_branch_exists {
my $branch = shift;
return system("$GIT show-ref --verify -q refs/heads/" . $branch) == 0;
}
lib/App/Rakubrew/Build.pm view on Meta::CPAN
chdir $back;
}
sub _check_build_dependencies() {
_check_git();
_check_perl();
}
sub _check_git {
if (!can_run($GIT)) {
say STDERR "Did not find `$GIT` program. That's a requirement for using some rakubrew commmands. Aborting.";
exit 1;
}
}
sub _check_perl {
if (!can_run($PERL5)) {
say STDERR "Did not find `$PERL5` program. That's a requirement for using some rakubrew commands. Aborting.";
exit 1;
}
}
1;
lib/App/Rakubrew/Download.pm view on Meta::CPAN
sub download_precomp_archive {
my ($impl, $ver) = @_;
my $ht = HTTP::Tinyish->new();
my @matching_releases = grep {
$_->{backend} eq $impl && ($ver ? $_->{ver} eq $ver : 1)
} _retrieve_releases($ht);
if (!@matching_releases) {
say STDERR 'Couldn\'t find a precomp release for OS: "' . _my_platform() . '", architecture: "' . _my_arch() . '"' . ($ver ? (', version: "' . $ver . '"') : '');
say STDERR 'You can try building yourself. Use the `rakubrew build` command to do so.';
exit 1;
}
if ($ver && @matching_releases > 1) {
say STDERR 'Multiple releases found for your architecture. Don\'t know what to install. This shouldn\'t happen.';
exit 1;
}
if (!$ver) {
$ver = $matching_releases[0]->{ver};
}
my $name = "$impl-$ver";
chdir $versions_dir;
if (-d $name) {
say STDERR "$name is already installed.";
exit 1;
}
say 'Downloading ' . $matching_releases[0]->{url};
my $res = $ht->get($matching_releases[0]->{url});
unless ($res->{success}) {
say STDERR "Couldn\'t download release. Error: $res->{status} $res->{reason}";
exit 1;
}
mkdir $name;
say 'Extracting';
if (_my_platform() eq 'win') {
_unzip(\($res->{content}), $name);
}
else {
_untar($res->{content}, $name);
}
# Remove top-level rakudo-2020.01 folder and move all files one level up.
my $back = cwd();
chdir $name;
my $rakudo_dir;
opendir(DIR, '.') || die "Can't open directory: $!\n";
while (my $file = readdir(DIR)) {
if (-d $file && $file =~ /^rakudo-/) {
$rakudo_dir = $file;
last;
}
}
closedir(DIR);
unless ($rakudo_dir) {
say STDERR "Archive didn't look as expected, aborting. Extracted to: $name";
exit 1;
}
dirmove($rakudo_dir, '.');
rmdir($rakudo_dir);
chdir $back;
return $name;
}
sub available_precomp_archives {
lib/App/Rakubrew/Download.pm view on Meta::CPAN
$Config{archname} =~ /amd64/i ? 'x86_64' :
$Config{archname} =~ /x86/i ? 'x86' :
$Config{archname} =~ /i686/i ? 'x86' :
$Config{archname} =~ /aarch64/i ? 'arm64' : # e.g. Raspi >= 2.1 with 64bit OS
$Config{archname} =~ /arm-linux-gnueabihf/i ? 'armhf' : # e.g. Raspi >= 2, with 32bit OS
$Config{archname} =~ /s390x-linux/i ? 's390x' :
'';
}
unless ($arch) {
say STDERR 'Couldn\'t detect system architecture. Current arch is: ' . $Config{archname};
say STDERR 'Current uname -a is: ' . `uname -a`;
say STDERR 'Current machdep.cpu.brand_string is: ' . $mac_brand_string if $mac_brand_string;
exit 1;
}
return $arch;
}
sub _download_release_index {
my $ht = shift;
my $res = $ht->get($release_index_url);
unless ($res->{success}) {
say STDERR "Couldn\'t fetch release index at $release_index_url. Error: $res->{status} $res->{reason}";
exit 1;
}
return decode_json($res->{content});
}
sub _untar {
my ($data, $target) = @_;
my $back = cwd();
chdir $target;
open (TAR, '| tar -xz');
lib/App/Rakubrew/Download.pm view on Meta::CPAN
print TAR $data;
close TAR;
chdir $back;
}
sub _unzip {
my ($data_ref, $target) = @_;
my $zip = IO::Uncompress::Unzip->new($data_ref);
unless ($zip) {
say STDERR "Reading zip file failed. Error: $UnzipError";
exit 1;
}
my $status;
for ($status = 1; $status > 0; $status = $zip->nextStream()) {
my $header = $zip->getHeaderInfo();
my ($vol, $path, $file) = splitpath($header->{Name});
if (index($path, updir()) != -1) {
say STDERR 'Found updirs in zip file, this is bad. Aborting.';
exit 1;
}
my $target_dir = catdir($target, $path);
unless (-d $target_dir) {
unless (make_path($target_dir)) {
say STDERR "Failed to create directory $target_dir. Error: $!";
exit 1;
}
}
next unless $file;
my $target_file = catfile($target, $path, $file);
unless (open(FH, '>', $target_file)) {
say STDERR "Failed to write $target_file. Error: $!";
exit 1;
}
binmode(FH);
my $buf;
while (($status = $zip->read($buf)) > 0) {
print FH $buf;
}
close FH;
}
if ($status < 0) {
say STDERR "Failed to extract archive. Error: $UnzipError";
exit 1;
}
}
lib/App/Rakubrew/Shell.pm view on Meta::CPAN
my @params = @_;
my $command = shift(@params) // '';
my $mode = get_brew_mode(1);
my $version;
my $sep = $^O =~ /win32/i ? ';' : ':';
if ($command eq 'shell' && @params) {
$version = $params[0];
if ($params[0] eq '--unset') {
say $self->get_shell_unsetter_code();
}
elsif (! is_version_broken($params[0])) {
say $self->get_shell_setter_code($params[0]);
}
}
elsif ($command eq 'mode' && $mode eq 'shim') { # just switched to shim mode
my $path = env('PATH');
$path = $self->clean_path($path);
$path = $shim_dir . $sep . $path;
say $self->get_path_setter_code($path);
}
elsif ($mode eq 'env') {
$version = get_version();
}
if ($mode eq 'env') {
my $path = env('PATH');
$path = $self->clean_path($path);
if ($version ne 'system') {
lib/App/Rakubrew/Shell.pm view on Meta::CPAN
# Get version ignoring the still set shell version.
$version = get_version('shell');
}
return if is_version_broken($version);
$path = join($sep, get_bin_paths($version), $path);
}
# In env mode several commands require changing PATH, so we just always
# construct a new PATH and see if it's different.
if ($path ne env('PATH')) {
say $self->get_path_setter_code($path);
}
}
}
sub clean_path {
my $self = shift;
my $path = shift;
my $also_clean_path = shift;
my $sep = $^O =~ /win32/i ? ';' : ':';
lib/App/Rakubrew/Shell/Bash.pm view on Meta::CPAN
}
sub get_shell_unsetter_code {
my $self = shift;
return "unset $env_var";
}
sub completions {
my $self = shift;
my $index = shift;
say join(' ', $self->get_completions($self->strip_executable($index, @_)));
}
sub completion_options {
my $self = shift;
my $index = shift;
my @words = @_;
if($index == 3 && $words[1] eq 'register') {
say 'compopt -o nospace';
}
else {
say '';
}
}
1;
lib/App/Rakubrew/Shell/Fish.pm view on Meta::CPAN
return "set -gx $env_var $version";
}
sub get_shell_unsetter_code {
my $self = shift;
return "set -ex $env_var";
}
sub completions {
my $self = shift;
say join(" ", $self->get_completions($self->strip_executable($#_, @_)));
}
1;
lib/App/Rakubrew/Shell/PowerShell.pm view on Meta::CPAN
# Chop off trailing space.
$argumentString = chop($argumentString) if substr($argumentString, 0, length($argumentString) - 1) eq ' ';
# Remove command name and trailing space from arguments.
$argumentString =~ s/(^|.*\W)$brew_name(\.bat|\.exe)? ?//;
my @words = split ' ', $argumentString;
my $index = @words - 1 + ($newWord ? 1 : 0);
my @completions = $self->get_completions($index, @words);
say join(' ', @completions);
}
1;
lib/App/Rakubrew/Shell/Tcsh.pm view on Meta::CPAN
}
sub completions {
my $self = shift;
my $command = shift;
my @words = split ' ', $command;
my $index = @words - 1;
$index++ if $command =~ / $/;
my @completions = $self->get_completions($self->strip_executable($index, @words));
say join(' ', @completions);
}
1;
lib/App/Rakubrew/Shell/Zsh.pm view on Meta::CPAN
}
sub get_shell_unsetter_code {
my $self = shift;
return "unset $env_var";
}
sub completions {
my $self = shift;
my $index = shift;
say join(' ', $self->get_completions($self->strip_executable($index - 1, @_)));
}
1;
lib/App/Rakubrew/Tools.pm view on Meta::CPAN
open(my $fh, '<', $file);
local $/ = '';
my $ret = <$fh>;
close($fh);
return $ret // '';
}
sub spurt {
my ($file, $cont) = @_;
open(my $fh, '>', $file);
say $fh $cont;
close($fh);
}
sub trim {
my $text = shift;
$text =~ s/^\s+|\s+$//g;
return $text;
}
sub uniq {
lib/App/Rakubrew/Update.pm view on Meta::CPAN
sub update {
my $quiet = shift;
# For par packaged executables the following returns the path and name of
# the par packaged file.
my $current_rakubrew_file = catfile($RealBin, $RealScript);
# check whether this is a CPAN installation. Abort if yes.
if ($distro_format eq 'cpan') {
say STDERR 'Rakubrew was installed via CPAN, use your CPAN client to update.';
exit 1;
}
my $ht = HTTP::Tinyish->new();
my $release_index = _download_release_index($ht);
# check version
if ($App::Rakubrew::VERSION >= $release_index->{latest}) {
say 'Rakubrew is up-to-date!';
exit 0;
}
# Display changes
if (!$quiet) {
say "Changes\n";
say "=======\n";
for my $change (@{$release_index->{releases}}) {
next if $change->{version} <= $App::Rakubrew::VERSION;
say $change->{version} . ':';
say " $_" for split(/^/, $change->{changes});
say '';
}
print 'Shall we do the update? [y|N] ';
my $reply = <STDIN>;
chomp $reply;
exit 0 if $reply ne 'y';
say '';
}
mkdir catdir($prefix, 'update') unless (-d catdir($prefix, 'update'));
my $update_file = catfile($prefix, 'update', $RealScript);
# delete RAKUBREW_HOME/update/rakubrew
unlink $update_file;
# download latest to RAKUBREW_HOME/update/rakubrew
my $res = $ht->get($dl_urls{$distro_format});
unless ($res->{success}) {
say STDERR "Couldn\'t download update. Error: $res->{status} $res->{reason}";
exit 1;
}
my $fh;
if (!sysopen($fh, $update_file, O_WRONLY|O_CREAT|O_EXCL, 0777)) {
say STDERR "Couldn't write update file to $update_file. Aborting update.";
exit 1;
}
binmode $fh;
print $fh $res->{content};
close $fh;
if ($^O =~ /win32/i) {
# Windows has no real exec(). In addition all the standard perl
# utilities to start processes automatically make the started process
# inherit all handles of the parent. This has the effect that it's
# impossible in the child to delete the parents executable file even
# when the parent has already exited. So we use the lower level
# Win32::Process::Create with the 4th argument (inheritHandles) set to 0
# to get rid of the handles preventing the deletion of the parent
# executable.
say 'You will now see a command prompt, even though the update process is still running.';
say 'This is caused by a quirk in Windows\' process handling.';
say 'Just wait a few seconds until an "Update successful!" message shows up';
my $ProcessObj;
if (!Win32::Process::Create(
$ProcessObj,
$update_file,
Win32::ShellQuote::quote_native(
$update_file,
'internal_update',
$App::Rakubrew::VERSION,
$current_rakubrew_file),
0,
Win32::Process::NORMAL_PRIORITY_CLASS(),
"."
)) {
say STDERR 'Failed to call the downloaded rakubrew executable! Aborting update.';
exit 1;
};
exit 0;
}
else {
{ exec($update_file, 'internal_update', $App::Rakubrew::VERSION, $current_rakubrew_file) };
say STDERR 'Failed to call the downloaded rakubrew executable! Aborting update.';
exit 1;
}
}
sub internal_update {
my ($old_version, $old_rakubrew_file) = @_;
my $current_script = catfile($RealBin, $RealScript);
my $update_file = catfile($prefix, 'update', $RealScript);
if ($update_file ne $current_script) {
say STDERR "'internal_update' was called on a rakubrew ($current_script) that's not $update_file. That's probably wrong and dangerous. Aborting update.";
exit 1;
}
# custom update procedures
if ($old_version < 29) {
# Change Github URLs to use the https instead of the git protocol.
my @repos;
for my $dir ($git_reference, $versions_dir) {
opendir(my $dh, $dir);
lib/App/Rakubrew/Update.pm view on Meta::CPAN
for my $repo (@repos) {
$repo = catdir($repo, '.git') if -d catdir($repo, '.git');
my $config_file = catfile($repo, 'config');
if (-f $config_file) {
print "Updating Github repository URLs in $config_file...";
my $content = slurp($config_file);
my $replaced = ($content =~ s|^(\s* url \s* = \s*) git (://github\.com/)|$1https$2|gmx);
if ($replaced) {
spurt($config_file, $content);
say "done";
}
else {
say "nothing to be done";
}
}
}
}
#if ($old_version < 2) {
# Do update stuff for version 2.
#}
# copy RAKUBREW_HOME/update/rakubrew to 'path/to/rakubrew'
unlink $old_rakubrew_file or die "Failed to unlink old file: $old_rakubrew_file. Error: $!";
my $fh;
if (!sysopen($fh, $old_rakubrew_file, O_WRONLY|O_CREAT|O_EXCL, 0777)) {
say STDERR "Couldn't copy update file to $old_rakubrew_file. Rakubrew is broken now. Try manually copying '$update_file' to '$old_rakubrew_file' to get it fixed again.";
exit 1;
}
binmode $fh;
if (!copy($update_file, $fh)) {
close $fh;
unlink $old_rakubrew_file;
say STDERR "Couldn't copy update file to $old_rakubrew_file. Rakubrew is broken now. Try manually copying '$update_file' to '$old_rakubrew_file' to get it fixed again.";
exit 1;
}
close $fh;
unlink $update_file;
say 'Update successful!';
}
sub _download_release_index {
my $ht = shift;
my $res = $ht->get($release_index_url);
unless ($res->{success}) {
say STDERR "Couldn\'t fetch release index at $release_index_url. Error: $res->{status} $res->{reason}";
;
exit 1;
}
return decode_json($res->{content});
}
lib/App/Rakubrew/VersionHandling.pm view on Meta::CPAN
}
sub get_shell_version {
# Check for shell version by looking for $RAKU_VERSION or $PL6ENV_VERSION the environment.
if (defined $ENV{$env_var} || defined $ENV{PL6ENV_VERSION}) {
my $version = env($env_var) // env('PL6ENV_VERSION');
if (version_exists($version)) {
return $version;
}
else {
say STDERR "Version '$version' is set via the RAKU_VERSION environment variable.";
say STDERR "This version is not installed. Ignoring.";
say STDERR '';
return undef;
}
}
else {
return undef;
}
}
sub get_local_version {
my ($vol, $path, undef) = splitpath(realpath(), 1);
my @fragments = splitdir($path);
while (@fragments) {
for ($local_filename, '.perl6-version') {
my $filepath = catpath($vol, catdir(@fragments), $_);
if (-f $filepath) {
my $version = trim(slurp($filepath));
if(version_exists($version)) {
return $version;
}
else {
say STDERR "Version '$version' is given in the";
say STDERR "$filepath";
say STDERR "file. This version is not installed. Ignoring.";
say STDERR '';
}
}
}
pop @fragments;
}
return undef;
}
sub is_version_broken {
my $version = shift;
lib/App/Rakubrew/VersionHandling.pm view on Meta::CPAN
return 0;
}
}
return 1;
}
sub verify_version {
my $version = shift;
if (! version_exists($version) ) {
say STDERR "$brew_name: version '$version' is not installed.";
exit 1;
}
if ( is_version_broken($version) ) {
say STDERR "Version $version is broken. Refusing to switch to it.";
exit 1;
}
}
sub set_local_version {
my $version = shift;
if ($version) {
verify_version($version);
spurt($local_filename, $version);
}
lib/App/Rakubrew/VersionHandling.pm view on Meta::CPAN
}
my $cur = slurp(catfile($prefix, 'CURRENT'));
chomp $cur;
return $cur;
}
sub set_global_version {
my $version = shift;
my $silent = shift;
verify_version($version);
say "Switching to $version" unless $silent;
spurt(catfile($prefix, 'CURRENT'), $version);
}
sub get_version {
my $ignore = shift // '';
my $version = $ignore eq 'shell' ? undef : get_shell_version();
return $version if defined $version;
if (get_brew_mode() eq 'shim') {
# Local version is only supported in shim mode.
lib/App/Rakubrew/VersionHandling.pm view on Meta::CPAN
sub set_brew_mode {
my $mode = shift;
if ($mode eq 'env') {
spurt(catfile($prefix, 'MODE'), 'env');
}
elsif ($mode eq 'shim') {
spurt(catfile($prefix, 'MODE'), 'shim');
rehash();
}
else {
say STDERR "Mode must either be 'env' or 'shim'";
}
}
sub get_brew_mode {
my $silent = shift;
if (!-e catfile($prefix, 'MODE')) {
spurt(catfile($prefix, 'MODE'), 'env');
}
my $mode = trim(slurp(catfile($prefix, 'MODE')));
if ($mode ne 'env' && $mode ne 'shim') {
say STDERR 'Invalid mode found: ' . $mode unless $silent;
say STDERR 'Resetting to env-mode' unless $silent;
set_brew_mode('env');
$mode = 'env';
}
return $mode;
}
sub validate_brew_mode {
if (get_brew_mode() eq 'env') {
say STDERR "This command is not available in 'env' mode. Switch to to 'shim' mode using '$brew_name mode shim'";
exit 1;
}
}
sub version_exists {
my $version = shift;
return undef if !defined $version;
my %versionsMap = map { $_ => 1 } get_versions();
return exists($versionsMap{$version});
}
lib/App/Rakubrew/VersionHandling.pm view on Meta::CPAN
return ($impl, $ver, @args);
}
sub which {
my $prog = shift;
my $version = shift;
my $target = _which($prog, $version);
if (!$target) {
say STDERR "$brew_name: $prog: command not found";
if(whence($prog)) {
say STDERR <<EOT;
The '$prog' command exists in these Raku versions:
EOT
map {say STDERR $_} whence($prog);
}
exit 1;
}
return $target;
}
sub _which {
my $prog = shift;
my $version = shift;
lib/App/Rakubrew/VersionHandling.pm view on Meta::CPAN
sub rehash {
return if get_brew_mode() ne 'shim';
my @paths = ();
for my $version (get_versions()) {
next if $version eq 'system';
next if is_version_broken($version);
push @paths, get_bin_paths($version);
}
say "Updating shims";
{ # Remove the existing shims.
opendir(my $dh, $shim_dir);
while (my $entry = readdir $dh) {
next if $entry =~ /^\./;
unlink catfile($shim_dir, $entry);
}
closedir $dh;
}
t/03-broken-versions.t view on Meta::CPAN
my $desc = shift;
my $out;
my $success = run([@rakubrew, $cmd], \"", \$out);
ok( $success, "$cmd succeeds" );
like( $out, qr/$pattern/, $desc );
}
sub spurt {
my ($file, $cont) = @_;
open(my $fh, '>', $file);
say $fh $cont;
close($fh);
}
sub fake_install {
my $path = shift;
my $broken = shift;
mkdir "$path/bin";
spurt("$path/bin/raku", "foo") if !$broken;
}
sub fake_version {
t/04-environment.t view on Meta::CPAN
@rakubrew = ($rakubrew_exec, "internal_hooked", "Bash");
}
else {
@exec = ($PERL, "-I$FindBin::Bin/../lib");
@rakubrew = ($PERL, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/rakubrew", "internal_hooked", "Bash");
}
sub spurt {
my ($file, $cont) = @_;
open(my $fh, '>', $file);
say $fh $cont;
close($fh);
}
sub fake_install {
my $path = shift;
my $broken = shift;
mkdir "$path/bin";
spurt("$path/bin/raku", "foo") if !$broken;
}
sub fake_version {
( run in 1.325 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )