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

Nelson Ferraz nferraz em phperl.com
Sexta Outubro 17 23:23:22 CDT 2003


Flavio S. Glock wrote:
> Eu já usei o PAR para criação de executável - funciona bem, e o 
> executável não fica muito grande.

Obrigado pela dica!

O executável ficou com 2.4Mb, mas consegui reduzir o tamanho para 1.3Mb, 
com o UPX.

(Apenas como teste, um "Hello, world" gerou um executável de 1.7Mb, que 
foi reduzido para 615kb com o UPX).

Aqui vai a última versão do script.

-- 
[]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 executable: (pp -o getfree.exe getfree.pl)

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 File::Copy;

use URI ();
use LWP::UserAgent;
use Archive::Zip qw(:ERROR_CODES);

#use Digest::SHA1 qw(sha1);
#use Win32::TieRegistry ( TiedHash => '%RegHash' );
#use Win32::Shortcut;

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

# These are the files we'll download
my %SW = (
	'OpenOffice.org 1.1' => {
		uri => 'http://www.ibiblio.org/pub/packages/openoffice/stable/1.1.0/OOo_1.1.0_Win32Intel_install.zip',
		sha1=> '454953c6595b91b175f79d57c99d065f5b89025f',
		install => 'OOo_1.1.0_Win32Intel_install/setup.exe'
	},
	'Mozilla 1.5' => {
		uri => 'http://ftp.mozilla.org/pub/mozilla.org/mozilla/releases/mozilla1.5/mozilla-win32-1.5-installer.exe',
		sha1 => '8e02cc5d34bf38fce3ccc03417e8b535c723c462',
		install => 'mozilla-win32-1.5-installer.exe'
	},
	'Mozilla Firebird 0.7' => {
		uri => 'http://ftp.mozilla.org/pub/mozilla.org/firebird/releases/0.7/MozillaFirebird-0.7-win32.zip',
		sha1 => '3dfd5a22525d6af7b4ab97cb6a250a9ef4cc1937'
	},
	'Mozilla Thunderbird 0.3' => {
		uri => 'http://ftp.mozilla.org/pub/mozilla.org/thunderbird/releases/0.3/thunderbird-0.3-win32.zip',
		sha1 => '93f33e6addd8d95e47f92459a7a4e964b67d040a'
	},
	'Perl 5.8.0' => {
		uri => 'http://www.cpan.org/authors/id/G/GR/GRAHAMC/SiePerl-5.8.0-bin-1.0-Win32.INSTALL.exe',
		sha1 => 'f020bdfcb571071f4317aae6e30a50a87f4da71b',
		install => 'SiePerl-5.8.0-bin-1.0-Win32.INSTALL.exe'
	}
);

my $USER_AGENT    = "GetFree/0.0.3";

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

my $DEBUG         = 1;

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

# Install myself
Install_myself();

# Download files
foreach (keys %SW) {
  print "Preparing to download '$_'...\n" if $DEBUG;
  Download($SW{$_}->{uri});
}

# Install files
foreach (keys %SW) {
  print "Preparing to install '$_'...\n" if $DEBUG;
  my ($filename) = $SW{$_}->{uri} =~ m!([^/]+)$!; # get filename from uri
  Unzip($filename) if $filename =~ m/\.zip$/i;
  system($SW{$_}->{install}) if -f $SW{$_}->{install};
}

# Uninstall myself
Uninstall_myself();

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

sub Install_myself {
  # Copy myself to home drive

  if (!-f "$HOME/$SCRIPT_NAME") {
    # Copy myself to home dir
    copy("$FindBin::Bin/$SCRIPT_NAME","$HOME/$SCRIPT_NAME") or die "copy failed: $!";

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

###

sub Uninstall_myself {
  # Remove myself from home drive

  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 file from uri (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. Saving as 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" if $DEBUG;
    }
    else {
        print "Transfer incomplete: '$res->message'\n\n";
    }
  
}

###

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

  my $zipName = shift;
  die "File not found" if ! -f $zipName;

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


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