cata-update.pl

#!/usr/bin/perl
use 5.010;
use strict;
no warnings "deprecated";
use utf8;
use if $^O =~ /win/i, encoding => ("utf8", STDOUT => "cp866");

use LWP;
use Archive::Extract;
use File::Temp;
use File::Spec::Functions qw/catfile catdir/;
use File::Copy qw/move/;
use File::Copy::Recursive qw/rcopy/;
use File::Path qw/rmtree/;

# ----------------------------------------

my $game_dir    = "cataclysmdda-tiles";
my $backup_dir  = "cataclysmdda-tiles.old";

# ----------------------------------------

my $lwp = new LWP::UserAgent;

say "Получаем ссылку на последнюю версию...";
my $address = $^O =~ /win/i ? "http://dev.narc.ro/cataclysm/jenkins-latest/Windows/Tiles/"
                            : "http://dev.narc.ro/cataclysm/jenkins-latest/Linux/Tiles/";
my $res = $lwp->get($address);
die $res->status_line unless $res->is_success;
my $latest = $address . ($res->content =~ /href="(cataclysmdda.*?\.(?:gz|zip))/gm)[-1];

# ----------------------------------------

say "Загрузка `$latest'...";
$res = $lwp->get($latest);
die $res->status_line unless $res->is_success;

my $tmpfile = new File::Temp(suffix => $latest =~ /\d{4}(.*)$/gm);
open my $fh, '>', $tmpfile->filename or die $!;
binmode $fh;
syswrite $fh, $res->content, $res->content_length;
close $fh;

# ----------------------------------------

if(-d $game_dir) {
   say "Обнаружена старая версия игры. Перемещение в `$backup_dir'...";
   rmtree("$backup_dir") if -d $backup_dir;
   move $game_dir, $backup_dir or die $!;
}

say "Распаковка архива...";
my $archive = new Archive::Extract(archive => $tmpfile);
my $tmpdir = File::Temp->newdir;
$archive->extract(to => $tmpdir->dirname);
die $archive->error if $archive->error;

say "Перемещение в `$game_dir/'...";
if($archive->is_tgz) {
   move(catdir($tmpdir->dirname, $archive->files->[0]), $game_dir) or die $!;
} else {
   move $tmpdir->dirname, $game_dir or die $!;
}

# ----------------------------------------

if(-d $backup_dir) {
   say "Копирование сохранений и настроек из старой версии...";
   for my $dir ("save", "config", catdir("data", "font"),
                catdir("gfx", "MShock32Xotto++"), catdir("data", "sound", "ChestHole")) {
      my($orig, $new) = (catdir($backup_dir, $dir), catdir($game_dir, $dir));
      if(-d $orig) {
         say "$orig -> $new";
         rcopy $orig, $new;# or die $!;
      }
   }
}

# ----------------------------------------

say "Похоже, что всё прошло нормально.";