[Cascavel-pm] getfree.pl - instalando softwares livres no Windows

Nelson Ferraz nferraz em phperl.com
Quinta Outubro 16 13:38:14 CDT 2003


Pessoal,

Aqui vai um pequeno script para automaticamente baixar e instalar 
diversos softwares livres no Windows.

A idéia é que o programa seja executado sempre que o computador é 
ligado, baixe os arquivos necessários, efetue a instalação e depois se 
desinstale automaticamente. Se a transmissão for interrompida, o 
programa deve continuar o download de onde parou.

A maior parte já está ok, incluindo o download e a descompactação. O que 
falta fazer é:

  - Criar chave no registry para execução na inicialização
  - Criar atalhos no Desktop após o término do download

Para o futuro, seria legal se o script pudesse ler as informações do 
Outlook/ICQ/MSN/etc e configurar as alternativas livres corretamente. 
Mas isto fica para depois. :)

Pergunta: alguém aqui tem experiência com os módulos Win32 e com a 
criação de executáveis no Windows?

-- 
[]s

Nelson

________________________________________________________________
Nelson Ferraz

GNU BIS: http://www.gnubis.com.br
PhPerl:  http://www.phperl.com

-------------- Próxima Parte ----------
#!/usr/bin/perl

# Perl script to automatically download and install open source software
#
# To generate bytecode:
# perl -MO=Bytecode,-O6,-ogetfree.plc,-umain getfree.pl
#
# More info on compiling perl scripts:
# http://search.cpan.org/~jhi/perl-5.8.1-RC5/pod/perlcompile.pod

use strict;
use warnings;

#
# Don't execute if year > 2003 (expiration date)
#

my ($sec,$min,$hour,$day,$mon,$year,$wday) = localtime(time);
die "Expired" if $year > 103;

#############
#           #
# LIBRARIES #
#           #
#############

use FindBin; # I'm running in $FindBin::Bin

use LWP::UserAgent;
use LWP::MediaTypes qw(guess_media_type media_suffix);
use URI ();
use HTTP::Date ();

use Digest::SHA1 qw(sha1);
use Archive::Zip qw(:ERROR_CODES);

#use Win32::Shortcut;
#use Win32::TieRegistry;

########
#      #
# DATA #
#      #
########

# These are the files we'll download
my %SW = (
		     'OpenOffice.org 1.1' => 'http://www.ibiblio.org/pub/packages/openoffice/stable/1.1.0/OOo_1.1.0_Win32Intel_install.zip',
		   'Mozilla Firebird 0.7' => 'http://ftp.mozilla.org/pub/mozilla.org/firebird/releases/0.7/MozillaFirebird-0.7-win32.zip',
		'Mozilla Thunderbird 0.3' => 'http://ftp.mozilla.org/pub/mozilla.org/thunderbird/releases/0.3/thunderbird-0.3-win32.zip'
);

my $USER_AGENT = "GetFree/0.0.1";
my $DEBUG = 1;

########
#      #
# MAIN #
#      #
########

# Install myself
Install_myself();

# Download files
foreach (keys %SW) {
  Download($SW{$_});
}

# Unzip files
foreach (keys %SW) {
  my ($filename) = $SW{$_} =~ m!([^/]+)$!; # get filename from url
  Unzip($filename) if $filename =~ m/\.zip$/i;
}

# Uninstall myself
Uninstall_myself();

######## 
#      #
# SUBS #
#      #
######## 

sub Install_myself {
  # Copy myself to home drive

  my $home = $ENV{HOMEDRIVE}; # Usually "C:"
  my ($script_name) = $0 =~ m!([^/]+)$!;

  if (!-f "$home/$script_name") {
    # Copy myself to home dir
    system("copy $FindBin::Bin/$script_name $home");

    # TO-DO: Add key to registry
    # [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run]
  }
}

###

sub Uninstall_myself {
  # Remove myself from home drive

  my $home = $ENV{HOMEDRIVE}; # Usually "C:"
  my ($script_name) = $0 =~ m!([^/]+)$!;

  if (!-f "$home/$script_name") {
    # Delete me from home dir
    unlink("$home/$script_name");

    # TO-DO: Delete key from registry
    # [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run]
  }
}

###

sub Download {
  # Download a given URL; resume if interrupted.

  my ( $file, $fsize, $last, $mod, $req, $res, $start, $size, $time, $total, $s );

  my $uri = URI->new(shift);
  ($file) = $uri =~ m!([^/]+)$!; # get filename from url

  my $ua  = new LWP::UserAgent;
  $ua->agent( $USER_AGENT );

  print "Checking remote file '$uri'...\n" if $DEBUG;
  $req = new HTTP::Request HEAD => $uri->as_string;
  $res = $ua->request( $req );

  $req = new HTTP::Request GET  => $uri->as_string;

  if (!$res->is_success) {
        die "Error"; # $res->status_line;
  }

  $fsize = 0;
  $total = $res->content_length || 0;
  $mod   = $res->last_modified  || time;

  print "Looking for local file '$file'...\n" if $DEBUG;
  if (-e $file) {
        my @s     = stat($file);
        $fsize    = $s[7];
        my $fmod  = $s[9];

        if ($fmod >= $mod && $fsize >= $total) {
            # Completed
            print "Found it, and seems complete.\n" if $DEBUG;
            return;
        } elsif ($fsize < $total && $res->protocol =~ /1\.1/) {
            print "Found it, but seems incomplete. Appending to file '$file'\n" if $DEBUG;
            $size = $fsize;
            my $headers = $req->headers();
            $headers->push_header( Range => "bytes=$fsize-" );
            open(FILE, ">>$file") || return "$file: $!\n";
        }
    } else {
        print "Not found. Creating new file '$file'\n" if $DEBUG;
        open(FILE,  ">$file") || return 0;
    }

    print "Requesting '$uri'...\n" if $DEBUG;
    $start = time;
    $last  = 0;
    $res   = $ua->request($req,
        sub
        {
            my ($data, $response, $protocol) = @_;
            print FILE $data;
            $time  = time - $start;
            $size += length($data);
            if ($time != $last) {
                $last = $time;
            }
        }
    );

    if (   $res->is_success
        || $res->message =~ /^Interrupted/
        || $res->message =~ /^OK/)
    {
        close (FILE);
        my $now = time;
        utime $now, $now, $file;
        print "Finished!\n\n" if $DEBUG;
    }
    else {
        print "Transfer incomplete: '$res->message'\n\n";
    }
  
}

###

sub Unzip {
  # Unzip a given zip file (extract the entire tree)

  my $zipName = shift;
  my $zip = Archive::Zip->new();

  print "Unzip '$zipName'...\n" if $DEBUG;

  my $status = $zip->read( $zipName );
  die "Read of $zipName failed\n" if $status != AZ_OK;

  $zip->extractTree();
  die "Extracting from $zipName failed\n" if $status != AZ_OK;

  print "Ok\n" if $DEBUG;
}

__END__


Mais detalhes sobre a lista de discussão Cascavel-pm