#!/usr/bin/perl

# --------------------------------------------------------------
# Prontus CMS
# http://www.prontus.cl
# by Altavoz.net
#
# licensed under LGPL license.
# http://www.prontus.cl/license.html
# --------------------------------------------------------------

package Update;
use strict;
use utf8;

use DBI;
use POSIX qw/ceil/;

use glib_fildir_03;
use File::Copy;
use lib_prontus;
use prontus_varglb;
use glib_hrfec_03;
use Digest::MD5 qw(md5_hex);
use File::Compare;

# ---------------------------------------------------------------
# Errores orientados a que los pueda leer el usuario, sin info del ambiente.
# el texto completo del error se tira al STDERR
our $ERR = '';

# ---------------------------------------------------------------
# Crea el objeto y retorna una referencia a el.
# Este metodo es el primer paso obligado
sub new {
    my $clase = shift;
    my $upd_obj = {@_};
    bless $upd_obj, $clase;

    $ERR = '';

    # Atributos recibidos.
    $upd_obj->{document_root}   ||= $prontus_varglb::DIR_SERVER; # valor por omision
    $upd_obj->{prontus_id}      ||= '';
    $upd_obj->{version_prontus} ||= '';
    $upd_obj->{actualizaciones} ||= 'SI';
    $upd_obj->{just_status}     ||= '0';
    $upd_obj->{required_size}     = 150;

    if ((!&lib_prontus::valida_prontus($upd_obj->{prontus_id})) || ($upd_obj->{version_prontus} eq '')) {
        $ERR = "Update::new con params no validos:\n"
                    . "prontus_id[$upd_obj->{prontus_id}] \n"
                    . "version_prontus[$upd_obj->{version_prontus}] \n";
        return 0;
    }

    $upd_obj->{update_server} = $prontus_varglb::CONFIG{$upd_obj->{prontus_id}}{'UPDATE_SERVER'};

    # Establece y chequea dirs
    $upd_obj->{dir_updates} = $upd_obj->{document_root} . "/_prontus_update";

    # Determina y disponibiliza version del update disponible, en caso de haberlo.
    $upd_obj->{rama_instalada} = '';
    $upd_obj->{nro_revision_instalada} = '';
    $upd_obj->{nom_file_vdescriptor} = '';
    if (! $upd_obj->_set_info_release_instalada()) {
        return 0;
    }

    # Datos del espacio en disco.
    $upd_obj->{quota_usado} = '';
    $upd_obj->{quota_asignado} = '';
    $upd_obj->{quota_usado_porc} = '';

    $upd_obj->{nom_cgicpn_current} = $prontus_varglb::DIR_CGI_CPAN;
    $upd_obj->{nom_cgibin_current} = $prontus_varglb::DIR_CGI_PUBLIC;

    $upd_obj->{buffer_last} = &glib_fildir_03::read_file($upd_obj->{dir_updates} . '/' . $upd_obj->{nom_file_vdescriptor}); # last.XX.0.txt
    $upd_obj->{last_version_disponible} = $upd_obj->update_disponible();

    $upd_obj->{ts_actualizacion} = &glib_hrfec_03::get_dtime_pack4();

    if ($upd_obj->{just_status} ne '1') {
        $upd_obj->{dir_backup} = $upd_obj->get_dir_backup();
        if($upd_obj->{dir_backup} eq '') {
            $ERR = "No se pueden crear directorios de respaldo";
            print STDERR $ERR . "[$!]\n";
            return 0;
        }

        $upd_obj->{dir_descarga} = $upd_obj->get_dir_descarga();
        if($upd_obj->{dir_descarga} eq '') {
            $ERR = "No se pueden crear directorios de descarga";
            print STDERR $ERR . "[$!]\n";
            return 0;
        }
    }

    return $upd_obj;
}

# ---------------------------------------------------------------
sub garbage_dirs {

    # Borrar dirs descargados del download actual, pero deja el .tgz y el .md5
    my $this = shift;
    &glib_fildir_03::borra_dir("$this->{dir_descarga}/cgi-cpn");
    &glib_fildir_03::borra_dir("$this->{dir_descarga}/cgi-bin");
    &glib_fildir_03::borra_dir("$this->{dir_descarga}/prontus");
    &glib_fildir_03::borra_dir("$this->{dir_descarga}/wizard_prontus");

    # Garbage de backups, deja solo los 3 respaldos mas recientes.
    $this->garbage_dirs_keep3($this->{dir_updates} . '/updated');

    # Garbage de downloads, deja solo los 3 downloads mas recientes.
    $this->garbage_dirs_keep3($this->{dir_updates} . '/downloads');

}
# ---------------------------------------------------------------
sub get_dir_backup {
    my $this = shift;
    my $dir_dst_bak = $this->{dir_updates} . '/updated/'
                    . $this->{rama_instalada}
                    . '.' . $this->{nro_revision_instalada}
                    . $this->{beta_revision_instalada}
                    . '-' . $this->{ts_actualizacion};
    if(! -d $dir_dst_bak) {
        return '' if (! &glib_fildir_03::check_dir($dir_dst_bak));
    }
    return $dir_dst_bak;
}
# ---------------------------------------------------------------
sub get_dir_descarga {
    my $this = shift;
    my $dir_descarga = $this->{dir_updates} . '/downloads/'
                    . $this->{last_version_disponible};
    if(! -d $dir_descarga) {
        return '' if (! &glib_fildir_03::check_dir($dir_descarga));
    }
    return $dir_descarga;
}
# ---------------------------------------------------------------
# Este método realiza todas las validaciones necesarias, antes
# de comenzar el proceso de update
sub check_before_update {
    my $this = shift;

    # Ver si estan las carpetas a respaldar (aunque se supone que estan!)
    if (! -d "$this->{document_root}/$this->{nom_cgicpn_current}") {
        $ERR = "Error al respaldar version actual de las CGIs back-end de Prontus: el directorio de origen no existe o no es valido.";
        print STDERR $ERR . " - dir cgis backend origen[$this->{document_root}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }
    if (! -d "$this->{document_root}/$this->{nom_cgibin_current}") {
        $ERR = "Error al respaldar version actual de las CGIs front-end de Prontus: el directorio de origen no existe o no es valido.";
        print STDERR $ERR . " - dir cgis frontend origen[$this->{document_root}/$this->{nom_cgibin_current}]\n";
        return 0;
    }

    # Se revisa si se puede escribir en el directorio de las CGIs
    my $random = &glib_str_03::random_string(10);
    while(-f "$this->{document_root}/$this->{nom_cgicpn_current}/$random.txt") {
        $random = &glib_str_03::random_string(10);
    }
    &glib_fildir_03::write_file("$this->{document_root}/$this->{nom_cgicpn_current}/$random.txt", $random);
    if(! unlink("$this->{document_root}/$this->{nom_cgicpn_current}/$random.txt")) {
        $ERR = "No se pudo escribir en el directorio: /$this->{nom_cgicpn_current}";
        print STDERR $ERR . " - dir cgis frontend origen[$this->{document_root}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }

    $random = &glib_str_03::random_string(10);
    while(-f "$this->{document_root}/$this->{nom_cgibin_current}/$random.txt") {
        $random = &glib_str_03::random_string(10);
    }
    &glib_fildir_03::write_file("$this->{document_root}/$this->{nom_cgibin_current}/$random.txt", $random);
    if(! unlink("$this->{document_root}/$this->{nom_cgibin_current}/$random.txt")) {
        $ERR = "No se pudo escribir en el directorio: /$this->{nom_cgibin_current}";
        print STDERR $ERR . " - dir cgis frontend origen[$this->{document_root}/$this->{nom_cgibin_current}]\n";
        return 0;
    }

    # Revisa si se pueden asignar permisos ejecucion a las cgis, recursivamente.
    my $permResult = $this->setExecPermisos("$this->{document_root}/$this->{nom_cgicpn_current}", 755);
    if ($permResult ne '') {
        $ERR = "Error al cambiar permisos de las CGIs back-end de Prontus: no se pudo asignar permisos de ejecucion a las CGIs: [$permResult]";
        print STDERR $ERR . " - dir de cgis backend[$this->{document_root}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }
    $permResult = $this->setExecPermisos("$this->{document_root}/$this->{nom_cgibin_current}", 755);
    if ($permResult ne '') {
        $ERR = "Error al cambiar permisos de las CGIs front-end de Prontus: no se pudo asignar permisos de ejecucion a las CGIs: [$permResult]";
        print STDERR $ERR . " - dir de cgis frontend[$this->{document_root}/$this->{nom_cgibin_current}]\n";
        return 0;
    }

    return 1;
}
# ---------------------------------------------------------------
sub _set_info_release_instalada {
    my $this = shift;
    my $rama_instalada;
    if ($this->{version_prontus} =~ /([0-9]+\.[0-9]+)\.([0-9]+)(\.beta\.[0-9]+|\.[0-9]+)?/) {
        $this->{rama_instalada} = $1;
        $this->{nro_revision_instalada} = $2;
        # si no hay valor se considera revision 0 de la version para realizar comparaciones
        $this->{beta_revision_instalada} = defined($3)?$3:0;
        $this->{nom_file_vdescriptor} = 'last.' . $this->{rama_instalada} . '.txt';
        return 1;
    } else {
        $ERR = 'No se pudo determinar version base instalada, no es posible verificar actualizaciones disponibles.';
        print STDERR "$ERR\n";
        return 0;
    }
}
# ---------------------------------------------------------------
sub set_info_quota {
    my $this = shift;
    ($this->{quota_asignado}, $this->{quota_usado}, $this->{quota_usado_porc}) = @_;
}
# ---------------------------------------------------------------
sub update_disponible {
    # Determina y retorna version del update disponible, en caso de haberlo.
    # Lee el archivo ya descargado.
    my $this = shift;
    $this->{last_version_disponible} = '';

    if ($this->{rama_instalada} ne '')  {
        my $rama_instalada = $this->{rama_instalada};
        if ($this->{buffer_last} =~ /$rama_instalada\.([0-9]+)(\.beta\.[0-9]+|\.[0-9]+)?/) {
            my $nro_revision_last = $1;
            my $beta_rev = defined($2)? $2 : '';
            my $last_version_disponible = $rama_instalada . '.' . $nro_revision_last . $beta_rev;
            # hay una nueva revision, puede ser beta
            if ($nro_revision_last > $this->{nro_revision_instalada}) {
                $this->{last_version_disponible} = $last_version_disponible;
            }
            # si es una subrevision/beta nueva
            elsif ($nro_revision_last eq $this->{nro_revision_instalada}) {
                # ambas son versiones beta de la misma revision
                if ($this->{beta_revision_instalada} =~ /beta/ && $beta_rev =~ /beta/) {
                    # verificamos beta superior
                    if (substr($beta_rev, 6) > substr($this->{beta_revision_instalada}, 6)) {
                        $this->{last_version_disponible} = $last_version_disponible;
                    }
                # esta instalada una beta y hay una release estable
                } elsif ($this->{beta_revision_instalada} =~ /beta/) {
                    $this->{last_version_disponible} = $last_version_disponible;
                # verificamos subrevision
                } elsif (substr($beta_rev, 1) > substr($this->{beta_revision_instalada}, 1)) {
                    $this->{last_version_disponible} = $last_version_disponible;
                }
            }
        }
    }
    return $this->{last_version_disponible}
}
# ---------------------------------------------------------------
sub get_status_update {
    my $this = shift;
    my $status_upd;
    if ($this->{actualizaciones} eq 'SI') {
        if ($this->{buffer_last}) {
            # Existe una actualizacion, ahora se compara para ver si es mas actual
            if ($this->{last_version_disponible}) {
                $status_upd = $this->{last_version_disponible};
            } else {
                $status_upd = "no_updates";
            }
        } else {
            $status_upd = "notfound";
        }
    } else {
        $status_upd = "disabled";
    }
    # variables para test
    # $status_upd = "12.0.0.beta.0";
    # $status_upd = "notfound";
    # $status_upd = "no_updates";
    # print STDERR "status_upd[$status_upd]\n";
    return $status_upd;
}

# ---------------------------------------------------------------
sub descarga_upd_descriptor {
    my $this = shift;

    if (! &glib_fildir_03::check_dir($this->{dir_updates}) ) {
        $ERR = "No se pueden crear directorios de update";
        print STDERR $ERR . "[$!]\n";
        return 0;
    }

    # http://www.prontus.cl/release/prontus.11.0/last.11.0.txt
    unlink $this->{dir_updates} . '/' . $this->{nom_file_vdescriptor};

    my $url = $this->{update_server} . '/release/prontus.' . $this->{rama_instalada} . '/last.' . $this->{rama_instalada} . '.txt';
    my $public_name = $prontus_varglb::CONFIG{$prontus_varglb::PRONTUS_ID}{'PUBLIC_SERVER_NAME'};
    $public_name =~ s/https?:?\/*//;
    $url .= "?$prontus_varglb::PRONTUS_ID&$public_name";
    my ($last_version_available, $msg_err) = &lib_prontus::get_url($url, 10);

    my $download_ok = 1;

    if ($msg_err) {
        if ($msg_err =~ /^404 /) {
            print STDERR "No hay actualizacion disponible, 404 - no se encuentra el archivo[$url]";
            $download_ok = 0;
        } else {
            my $err = "No se pudo descargar información de nuevas versiones disponibles: $msg_err";
            print STDERR "$err - url[$url]\n";
            $download_ok = 0;
        }
    } else {
        if ($last_version_available !~ /[0-9]+\.[0-9]+\.[0-9]+(\.beta\.[0-9]+|\.[0-9]+)?/) {
            print STDERR "No hay actualizacion disponible, el archivo [$url] existe pero no contiene info valida, last_version_available[$last_version_available]";
            $download_ok = 0;
        }
    }

    if ($download_ok) {
        $this->{buffer_last} = $last_version_available;
        $this->{buffer_last} =~ s/[\r\n]+$//sg;
        &glib_fildir_03::write_file($this->{dir_updates} . '/' . $this->{nom_file_vdescriptor}, $last_version_available);
    }

    return $download_ok;
}

sub check_before_download {
    my $this = shift;
    my $url = $this->{update_server} . '/release/prontus.' . $this->{rama_instalada} . '/files.' . $this->{last_version_disponible} . '.tgz';

    if ($this->{quota_usado_porc} eq '' || $this->{quota_usado} eq '' || $this->{quota_asignado} eq '') {
        $ERR = "No se pudo determinar el espacio libre en disco.";
        print STDERR "$ERR\n";
        return 0;
    }

    my $content_length = &lib_prontus::get_http_content_length($url); # obtener el tamaño del archivo a descargar.
    $content_length = 0 if (!$content_length);

    if ($content_length <= 0) {
        $ERR = "No se pudo determinar el tamaño de la actualización.";
        print STDERR "$ERR\n";
        return 0;
    }
    print STDERR "TGZ content_length[$content_length]\n";

    my $disponible_mb = &lib_quota::format_bytes($this->{quota_asignado} - $this->{quota_usado});

    if ($this->{quota_usado_porc} eq '100%') {
        $ERR = "No hay suficiente espacio libre en disco para descargar la actualización.";
        print STDERR "$ERR\n";
        return 0;
    } else {
        $content_length = ceil($content_length / 1024); #kib
        my $quota_usado = $this->{quota_usado} + $content_length + $this->{required_size} * 1024;
        my $required_mb = &lib_quota::format_bytes($content_length + $this->{required_size} * 1024);
        if ($quota_usado > $this->{quota_asignado}) {
            $ERR = "No hay suficiente espacio libre en disco para descargar la actualización. (Requerido: $required_mb, Disponible: $disponible_mb)";
            print STDERR "$ERR\n";
            return 0;
        }
    }

    return 1;
}

sub check_after_download {
    my $this = shift;
    my $path_local_tgz = shift;
    my $uncompressed;

    my $disponible_mb = &lib_quota::format_bytes($this->{quota_asignado} - $this->{quota_usado});
    my $gzip_info = `gzip -l $path_local_tgz`;
    if ($gzip_info =~ /(\d+)\s+(\d+)\s+(.*?%)/is) {
        $uncompressed = $2; # bytes.
        print STDERR "TGZ uncompressed[$uncompressed]\n";
        $uncompressed = ceil($uncompressed / 1024); #kib
        my $quota_usado = $this->{quota_usado} - $uncompressed + $this->{required_size}*1024;
        if ($quota_usado > $this->{quota_asignado}) {
            my $requerido_mb = &lib_quota::format_bytes($this->{required_size}*1024 - $uncompressed);
            $ERR = "No hay suficiente espacio libre en disco para descomprimir la actualización (Requerido: $requerido_mb, Disponible: $disponible_mb).";
            print STDERR "$ERR\n";
            return 0;
         }
    } else {
        print STDERR "No se pudo obtener tamaño desde info gzip:\n$gzip_info\n";
        $ERR = "No se pudo obtener el tamaño del archivo descargado.";
        print STDERR "$ERR\n";
        return 0;
    }

    return 1;
}

# ---------------------------------------------------------------
# Descarga tgz, md5 y descomprime:
# http://www.prontus.cl/release/prontus.x.y/files.x.y.z.tgz ->     /_prontus_update/downloads/x.y.z/files.x.y.z.tgz
#                                          /files.x.y.z.tgz.md5 ->                                 /files.x.y.z.tgz.md5
sub descarga_release {
    my $this = shift;

    # Descarga tgz
    # http://www.prontus.cl/release/prontus.11.0/files.11.0.13.tgz
    my $url = $this->{update_server} . '/release/prontus.' . $this->{rama_instalada} . '/files.' . $this->{last_version_disponible} . '.tgz';
    my ($tgz_content, $msg_err) = &lib_prontus::get_url($url, 30);

    if ($msg_err) {
        if ($msg_err =~ /^404 /) {
            $ERR = "Error al descargar release .tgz, 404 - no se encuentra el archivo[$url]";
            print STDERR "$ERR\n";
        } else {
            $ERR = "Error al descargar release .tgz [$url]: $msg_err";
            print STDERR "$ERR\n";
        }
        return 0;
    } else {

        # Si ok el tgz, descarga md5
        # http://www.prontus.cl/release/prontus.11.0/files.11.0.13.tgz.md5
        my $url_md5 = $url . ".md5";
        my ($md5_remoto, $msg_err_md5) = &lib_prontus::get_url($url_md5, 10);
        if ($msg_err_md5) {
            if ($msg_err_md5 =~ /^404 /) {
                $ERR = "Error al descargar release md5, 404 - no se encuentra el archivo[$url_md5]";
                print STDERR "$ERR\n";
            } else {
                $ERR = "Error al descargar release md5 [$url_md5]: $msg_err_md5";
                print STDERR "$ERR\n";
            }
            return 0;
        } else {
            if ($md5_remoto =~ /([a-z0-9]{32})/) {
                $md5_remoto = $1;
            } else {
                $ERR = "Error al descargar release md5 [$url_md5]: No contiene un string md5 valido, contiene[$md5_remoto]";
                print STDERR "$ERR\n";
                return 0;
            }

            # Si descargo ok el md5, verificar el tgz con este
            my $md5_local = Digest::MD5::md5_hex($tgz_content);
            if ($md5_local ne $md5_remoto) {
                $ERR = "Error al descargar release [$url]: md5 no coincide\nlocal [$md5_local]\nremoto[$md5_remoto]\nEl archivo no se pudo descargar correctamente.";
                print STDERR "$ERR\n";
                return 0;
            } else {
                # Si verificacion ok, guardar tgz y descomprimir en ubicacion de destino, por ej:
                # /_prontus_update/downloads/11.0.13/files.11.0.13.tgz
                return 0 if (! &glib_fildir_03::check_dir($this->{dir_descarga}));
                my $path_local_tgz = $this->{dir_descarga} . '/files.' . $this->{last_version_disponible} . '.tgz';
                &glib_fildir_03::write_file_bin($path_local_tgz, $tgz_content);
                if ((-s $path_local_tgz) && (-f $path_local_tgz)) {
                    my $ret = $this->check_after_download($path_local_tgz); # revisar si hay espacio suficiente para descomprimir el archivo.
                    if (!$ret) {
                        return 0;
                    }

                    # guardar el .md5
                    &glib_fildir_03::write_file("$path_local_tgz.md5", $md5_remoto);
                    # descomprimir en el mismo dir, el .tgz
                    system("tar xzf $path_local_tgz -C $this->{dir_descarga}");
                    if ($? != 0) {
                        $ERR = "Error al descomprimir release .tgz[$path_local_tgz] en dir[$this->{dir_descarga}]: Error[$!]";
                        print STDERR "$ERR\n";
                        return 0;
                    }

                    # Eliminar cgi-cpn/dir_cgi.pm  y cgi-bin/dir_cgi.pm de la release a instalar, no se debe sobreescribir
                    unlink "$this->{dir_descarga}/cgi-cpn/dir_cgi.pm";
                    unlink "$this->{dir_descarga}/cgi-bin/dir_cgi.pm";
                    unlink "$this->{dir_descarga}/cgi-bin/posting_limit.cfg";

                } else {
                    $ERR = "Error al descargar release .tgz [$url]: $msg_err";
                    print STDERR "$ERR\n";
                    return 0;
                }
            }
        }
    }

    # Finalmente se chequea que realmente vengan los cgi-cgi y cgi-bin
    my $dir_src_cgicpn = "$this->{dir_descarga}/cgi-cpn";
    if (! -d $dir_src_cgicpn) {
        $ERR = "En la release a instalar no se encontro directorio cgi-cpn";
        print STDERR $ERR . " - dir_src_cgicpn[$dir_src_cgicpn]\n";
        return 0;
    }
    my $dir_src_cgibin = "$this->{dir_descarga}/cgi-bin";
    if (! -d $dir_src_cgibin) {
        $ERR = "En la release a instalar no se encontro directorio cgi-bin";
        print STDERR $ERR . " - dir_src_cgicpn[$dir_src_cgibin]\n";
        return 0;
    }

    # Se chequea que venga el core del wizard
    my $dir_src_core_wiz = "$this->{dir_descarga}/wizard_prontus/core";
    if (! -d $dir_src_core_wiz) {
        $ERR = "En la release a instalar no se encontro directorio core";
        print STDERR $ERR . " - dir_src[$dir_src_core_wiz]\n";
        return 0;
    }
    return 1;
}

# ---------------------------------------------------------------
# Deja solo los ultimos 3 respaldos generados por el update
sub garbage_dirs_keep3 {
    my $this = shift;
    my $dir = shift;

    return unless(-d $dir);
    my @entries = &glib_fildir_03::lee_dir($dir);

    @entries = grep !/^\./, @entries; # Elimina directorios . y ..

    # Ordena por fecha dejando primero los mas nuevos
    @entries = sort { (stat("$dir/$b"))[9] <=> (stat("$dir/$a"))[9] } @entries;

    # Elimina del 3r dir en adelante
    my $numdir = 0;
    foreach my $entry (@entries) {
        next if (!-d "$dir/$entry");
        $numdir++;
        # print STDERR "garbage: revisando [$dir/$entry]\n";
        if ($numdir > 3) {
            print STDERR "\tgarbage: borrando [$dir/$entry]\n";
            &glib_fildir_03::borra_dir("$dir/$entry");
        }
    }
}

# ---------------------------------------------------------------
sub crea_respaldos {
    my $this = shift;

    # Copiar /cgi-cpn --> a dir de respaldo
    &glib_fildir_03::copy_tree_exclude_ext($this->{document_root}, $this->{nom_cgicpn_current},
                                $this->{dir_backup}, $this->{nom_cgicpn_current},
                                'prontus_error_log,wizard_error_log,prontus_temp,_unused',
                                '.error.log,.log');

    # Copiar /cgi-bin --> a dir de respaldo
    &glib_fildir_03::copy_tree_exclude_ext($this->{document_root}, $this->{nom_cgibin_current},
                                $this->{dir_backup}, $this->{nom_cgibin_current},
                                'prontus_error_log,wizard_error_log,prontus_temp,_unused',
                                '.error.log,.log');
    # Chequear integridad de respaldo - cgi-cpn.
    if (! -d "$this->{dir_backup}/$this->{nom_cgicpn_current}") {
        $ERR = "Error al respaldar version actual de las CGIs back-end de Prontus: no se creo el directorio destino.";
        print STDERR $ERR . " - dir bak de cgis backend[$this->{dir_backup}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }
    my $cmpResult = $this->compareDirs("$this->{dir_backup}/$this->{nom_cgicpn_current}", "$this->{document_root}/$this->{nom_cgicpn_current}");
    if ($cmpResult ne '') {
        $ERR = "Error al respaldar version actual de las CGIs back-end de Prontus: el dir. origen y el de destino del backup presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir bak de cgis backend[$this->{dir_backup}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }

    # Chequear integridad de respaldo - cgi-bin.
    if (! -d "$this->{dir_backup}/$this->{nom_cgibin_current}") {
        $ERR = "Error al respaldar version actual de las CGIs front-end de Prontus: no se creo el directorio destino.";
        print STDERR $ERR . " - dir bak de cgis frontend[$this->{dir_backup}/$this->{nom_cgibin_current}]\n";
        return 0;
    }
    $cmpResult = $this->compareDirs("$this->{dir_backup}/$this->{nom_cgibin_current}", "$this->{document_root}/$this->{nom_cgibin_current}");
    if ($cmpResult ne '') {
        $ERR = "Error al respaldar version actual de las CGIs front-end de Prontus: el dir. origen y el de destino del backup presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir bak de cgis frontend[$this->{dir_backup}/$this->{nom_cgibin_current}]\n";
        return 0;
    }


    if (!-d "$this->{document_root}/$prontus_varglb::DIR_CORE") {
        $ERR = "Error al respaldar cpan de Prontus [$prontus_varglb::DIR_CORE]: no existe el directorio de origen.";
        return 0;
    }
    if (!-d "$this->{document_root}/$prontus_varglb::DIR_CORE_FRONT") {
        $ERR = "Error al respaldar front de Prontus [$prontus_varglb::DIR_CORE_FRONT]: no existe el directorio de origen.";
        return 0;
    }
    #### CPAN ####
    # respaldar core cpan antes de sobreescribir
    &glib_fildir_03::check_dir("$this->{dir_backup}/$prontus_varglb::DIR_CORE");
    &glib_fildir_03::copy_tree_exclude_ext("$this->{document_root}/prontus", 'cpan',
                                "$this->{dir_backup}/prontus", 'cpan',
                                'prontus_error_log,wizard_error_log,prontus_temp,_unused',
                                '.error.log,.log');

    # Chequear integridad de respaldo de core cpan
    if (! -d "$this->{dir_backup}/$prontus_varglb::DIR_CORE") {
        $ERR = "Error al respaldar cpan de Prontus [$prontus_varglb::DIR_CORE]: no se creo el directorio destino.";
        print STDERR $ERR . " - dir destino[$this->{dir_backup}/$prontus_varglb::DIR_CORE]\n";
        return 0;
    }
    $cmpResult = $this->compareDirs("$this->{dir_backup}/$prontus_varglb::DIR_CORE", "$this->{document_root}/$prontus_varglb::DIR_CORE");
    if ($cmpResult ne '') {
        $ERR = "Error al respaldar version actual de cpan de  Prontus [$prontus_varglb::DIR_CORE]: el dir. origen y el de destino del backup presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir destino[$this->{dir_backup}/$prontus_varglb::DIR_CORE]\n";
        return 0;
    }

    #### FRONT ####
    # respaldar core front antes de sobreescribir
    &glib_fildir_03::check_dir("$this->{dir_backup}/$prontus_varglb::DIR_CORE_FRONT");
    &glib_fildir_03::copy_tree_exclude_ext("$this->{document_root}/prontus", 'front',
                                "$this->{dir_backup}/prontus", 'front',
                                'prontus_error_log,wizard_error_log,prontus_temp,_unused',
                                '.error.log,.log');

    # Chequear integridad de respaldo de core front
    if (! -d "$this->{dir_backup}/$prontus_varglb::DIR_CORE_FRONT") {
        $ERR = "Error al respaldar front de Prontus [$prontus_varglb::DIR_CORE_FRONT]: no se creo el directorio destino.";
        print STDERR "$ERR\n";
        return 0;
    }
    $cmpResult = $this->compareDirs("$this->{dir_backup}/$prontus_varglb::DIR_CORE_FRONT", "$this->{document_root}/$prontus_varglb::DIR_CORE_FRONT");
    if ($cmpResult ne '') {
        $ERR = "Error al respaldar version actual de front de  Prontus [$prontus_varglb::DIR_CORE_FRONT]: el dir. origen y el de destino del backup presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR "$ERR\n";
        return 0;
    }

    # Se respalda el wizard si es que existe
    if (-d "$this->{document_root}/wizard_prontus") {
        &glib_fildir_03::check_dir("$this->{dir_backup}/wizard_prontus");
        # Se respalda el core del wizard
        &glib_fildir_03::copy_tree_exclude_ext("$this->{document_root}/wizard_prontus", 'core',
                                    "$this->{dir_backup}/wizard_prontus", 'core',
                                    'prontus_error_log,wizard_error_log,prontus_temp,_unused',
                                    '.error.log,.log');

        $cmpResult = $this->compareDirs("$this->{document_root}/wizard_prontus/core", "$this->{dir_backup}/wizard_prontus/core");
        if ($cmpResult ne '') {
            $ERR = "Error al respaldar Core del Wizard: el dir. origen (nueva release) y el de destino presentan diferencias en sus archivos:\n$cmpResult";
            print STDERR $ERR . " - dir target[$this->{document_root}/wizard_prontus/core]\n";
            return 0;
        }
    }

    # Si todo salio bien
    return 1;
}

# ---------------------------------------------------------------
# Descarga tgz, md5 y descomprime:
# http://www.prontus.cl/release/prontus.x.y/files.x.y.z.tgz ->     /_prontus_update/downloads/x.y.z/files.x.y.z.tgz
#                                          /files.x.y.z.tgz.md5 ->                                 /files.x.y.z.tgz.md5
sub install_cgis {
    my $this = shift;

    # Copiar /cgi-cpn de la nueva release --> a dir oficial
    &glib_fildir_03::copy_tree($this->{dir_descarga}, 'cgi-cpn',
                               $this->{document_root}, $this->{nom_cgicpn_current});

    # Copiar /cgi-bin de la nueva release --> a dir oficial
    &glib_fildir_03::copy_tree($this->{dir_descarga}, 'cgi-bin',
                               $this->{document_root}, $this->{nom_cgibin_current});

    # Chequear integridad de cgi-cpn current.
    my $cmpResult = $this->compareDirs("$this->{document_root}/$this->{nom_cgicpn_current}", "$this->{dir_descarga}/cgi-cpn");
    if ($cmpResult ne '') {
        $ERR = "Error al instalar CGIs back-end de Prontus: el dir. origen (nueva release) y el de destino presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir de cgis backend[$this->{document_root}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }

    # Chequear integridad de  cgi-bin current.
    $cmpResult = $this->compareDirs("$this->{document_root}/$this->{nom_cgibin_current}", "$this->{dir_descarga}/cgi-bin");
    if ($cmpResult ne '') {
        $ERR = "Error al instalar CGIs front-end de Prontus: el dir. origen (nueva release) y el de destino presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir de cgis frontend[$this->{document_root}/$this->{nom_cgibin_current}]\n";
        return 0;
    }

    # Asignar permisos ejecucion a las cgis, recursivamente.
    my $permResult = $this->setExecPermisos("$this->{document_root}/$this->{nom_cgicpn_current}", 755);
    if ($permResult ne '') {
        $ERR = "Error al instalar CGIs back-end de Prontus: no se pudo asignar permisos de ejecucion a las CGIs: [$permResult]";
        print STDERR $ERR . " - dir de cgis backend[$this->{document_root}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }
    $permResult = $this->setExecPermisos("$this->{document_root}/$this->{nom_cgibin_current}", 755);
    if ($permResult ne '') {
        $ERR = "Error al instalar CGIs front-end de Prontus: no se pudo asignar permisos de ejecucion a las CGIs: [$permResult]";
        print STDERR $ERR . " - dir de cgis frontend[$this->{document_root}/$this->{nom_cgibin_current}]\n";
        return 0;
    }

    return 1;
}

# ---------------------------------------------------------------
sub install_core {
    my $this = shift;

    my $doc_root = $this->{document_root};

    # Prontus dirs a actualizar el core
    if (!-d "$this->{document_root}/$prontus_varglb::DIR_CORE") {
        $ERR = "Error al respaldar cpan de Prontus [$prontus_varglb::DIR_CORE]: no existe el directorio de origen.";
        return 0;
    }
    if (!-d "$this->{document_root}/$prontus_varglb::DIR_CORE_FRONT") {
        $ERR = "Error al respaldar front de Prontus [$prontus_varglb::DIR_CORE_FRONT]: no existe el directorio de origen.";
        return 0;
    }

    #### CPAN ####
    # Copiar core cpan de la nueva release a dir destino
    &glib_fildir_03::copy_tree("$this->{dir_descarga}/prontus", 'cpan',
                               "$this->{document_root}/prontus", 'cpan');

    # Chequear integridad de lo copiado
    my $cmpResult = $this->compareDirs("$this->{document_root}/$prontus_varglb::DIR_CORE", "$this->{dir_descarga}/$prontus_varglb::DIR_CORE");
    if ($cmpResult ne '') {
        $ERR = "Error al instalar nuevo core de Prontus: el dir. origen (nueva release) y el de destino presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir de core target[$this->{document_root}/$prontus_varglb::DIR_CORE]\n";
        return 0;
    }

    #### FRONT ####
    # Copiar core front de la nueva release a dir destino
    &glib_fildir_03::copy_tree("$this->{dir_descarga}/prontus", 'front',
                               "$this->{document_root}/prontus", 'front');

    # Chequear integridad de lo copiado
    $cmpResult = $this->compareDirs("$this->{document_root}/$prontus_varglb::DIR_CORE_FRONT", "$this->{dir_descarga}/$prontus_varglb::DIR_CORE_FRONT");
    if ($cmpResult ne '') {
        $ERR = "Error al instalar nuevo core de Prontus: el dir. origen (nueva release) y el de destino presentan diferencias en sus archivos:\n$cmpResult";
        print STDERR $ERR . " - dir de core target[$this->{document_root}/$prontus_varglb::DIR_CORE_FRONT]\n";
        return 0;
    }

    return 1;
}

# ---------------------------------------------------------------
# Actualiza /wizard_prontus/core/
sub install_core_wizard {
    my $this = shift;

    # Actualizar el core del wizard, en caso de que se encuentre instalado
    if (-d "$this->{document_root}/wizard_prontus/core") {
        &glib_fildir_03::check_dir("$this->{dir_backup}/wizard_prontus/");
        # Copiar el core del wizard
        &glib_fildir_03::copy_tree("$this->{dir_descarga}/wizard_prontus", 'core',
                                   "$this->{document_root}/wizard_prontus", 'core');

        # Chequear integridad de lo copiado
        my $cmpResult = $this->compareDirs("$this->{document_root}/wizard_prontus/core", "$this->{dir_descarga}/wizard_prontus/core");
        if ($cmpResult ne '') {
            $ERR = "Error al actualizar Core del Wizard: el dir. origen (nueva release) y el de destino presentan diferencias en sus archivos:\n$cmpResult";
            print STDERR $ERR . " - dir target[$this->{document_root}/wizard_prontus/core]\n";
            return 0;
        }
    }

    return 1;
}

# ---------------------------------------------------------------
sub compareDirs {
    my $this = shift;
    my $errors;
    my $targetDir = shift;
    my $sourceDir = shift;

    unless (-d $targetDir) {
        $errors .= "'$targetDir' is not a valid target directory. Please pass the name of a valid target directory enclosed in quotes.\n";
        return $errors;
    }

    unless (-d $sourceDir) {
        $errors .= "'$sourceDir' is not a valid target directory. Please pass the name of a valid target directory enclosed in quotes.\n";
        return $errors;
    }

    opendir THISDIR, $sourceDir;
    my @allFiles = grep { $_ ne '.' and $_ ne '..' && -f $_}  readdir THISDIR;
    closedir THISDIR;

    foreach (@allFiles) {
        if (File::Compare::compare("$sourceDir/$_", "$targetDir/$_") == 1) {
            $errors .= "$_ in source dir. $sourceDir differs from that in target dir. $targetDir\n\n";
        }
        if (File::Compare::compare("$sourceDir/$_", "$targetDir/$_") < 0) {
            $errors .= "$_ found in source dir. $sourceDir but not in target dir. $targetDir\n\n";
        }
    }

    return $errors;
}

# ---------------------------------------------------------------
sub setExecPermisos {
    my $this = shift;
    my ($dir) = shift;

    my @entries = &glib_fildir_03::lee_dir($dir);
    my $errors;

    # Recorre recursivamente, asignando permisos
    foreach my $entry (@entries) {
        next if ($entry =~ /^\./);
        if (-d "$dir/$entry") {
            $errors .= $this->setExecPermisos("$dir/$entry");
        } else {
            next if ($entry !~ /(\.cgi|\.pl|\.py)$/);
            if ($entry =~ /^prontus_/ || $entry =~ /^wizard_/) { # solo cambiar permisos a cgi que comiencen con prontus_ o wizard_
                my $ret = chmod 0755, "$dir/$entry";
                $errors .= "No fue posible asignar permisos de ejecucion a $dir/$entry\n" if (!$ret);
            }
        }
    }
    return $errors;
}


# ---------------------------------------------------------------
# Este metodo sirve para dejar todo como estaba antes de la actualizacion
# Se usa cuando uno de los procesos arroja error
# Esta no es la panacéa absoluta, ya que se pueden dar muchos casos extraños.
# La idea es dejar el prontus operativo mientras se revisa que pudo haber pasado
sub rollback_update {
    my $this = shift;

    # Copiar /cgi-cpn del backup al dir oficial del sitio
    &glib_fildir_03::copy_tree($this->{dir_backup}, $this->{nom_cgicpn_current},
                               $this->{document_root}, $this->{nom_cgicpn_current});

    # Copiar /cgi-bin del backup al dir oficial del sitio
    &glib_fildir_03::copy_tree($this->{dir_backup}, $this->{nom_cgicpn_current},
                               $this->{document_root}, $this->{nom_cgibin_current});

    # Asignar permisos ejecucion a las cgis, recursivamente.
    my $permResult = $this->setExecPermisos("$this->{document_root}/$this->{nom_cgicpn_current}", 755);
    if ($permResult ne '') {
        $ERR = "Error en el Rollback de Prontus: no se pudo asignar permisos de ejecucion a las CGIs: [$permResult]";
        print STDERR $ERR . " - dir de cgis backend[$this->{document_root}/$this->{nom_cgicpn_current}]\n";
        return 0;
    }

    # Copiar core cpan de la release original a dir destino
    glib_fildir_03::copy_tree("$this->{dir_backup}/prontus", 'cpan',
                               "$this->{document_root}/prontus", 'cpan');


    # Copiar core front de la release original a dir destino
    glib_fildir_03::copy_tree("$this->{dir_backup}/prontus", 'front',
                               "$this->{document_root}/prontus", 'front');

    return 1;
}

1;

# Para desplegar la doc. desde linea de comandos:
# perldoc Update.pm
# Para generar la doc en html:
# perldoc -T -o html IO::Handle > IO::Handle.html

__END__

=head1 NOMBRE

B<Update.pm> - Clase para Prontus Updates

=for comment
# ---------------------------------------------------------------

=head1 SINOPSIS

Instanciar y acceder a un metodo publico:

    use Update;

    # Creacion del objeto Update (todas los params son obligatorios).
    my $upd_obj = Update->new(
                    'prontus_id'        => 'prontus_noticias',
                    'version_prontus'   => $prontus_varglb::VERSION_PRONTUS,
                    'document_root'     => $prontus_varglb::DIR_SERVER)
                    || die("Error inicializando objeto Update: $ERR\n");

    # Obtener link para descargar el update disponible
    my $lnk_update = $upd_obj->get_status_update();

=for comment
# ---------------------------------------------------------------

=head1 DESCRIPCION

Contiene operaciones necesarias para gestionar el mecanismo de actualizacion automatica de Prontus.

=for comment
# ---------------------------------------------------------------

=head1 AUTOR

Yerko Chapanoff, E<lt>yerko@altavoz.netE<gt>

=cut
