view release on metacpan or  search on metacpan

lib/App/Rakubrew/Update.pm  view on Meta::CPAN

        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);
            push @repos, map({ catdir($dir, $_) } grep({ /^[^.]/ } readdir($dh)));
            closedir($dh);
        }
        push @repos, $zef_dir;

        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";
                }