2061 lines
40 KiB
Perl
2061 lines
40 KiB
Perl
#!/usr/bin/perl
|
|
|
|
### snap ###################################################
|
|
#
|
|
# This is the package management script for snap. It's
|
|
# quite a hack, and a bit messy currently. This will be
|
|
# cleaned up in time, but the initial goal is just to
|
|
# create something that works. It's not really too big
|
|
# to clean up later.
|
|
#
|
|
# Things to do!
|
|
# - Clean up $target, make sure it is correct for all subs
|
|
# - add 'usher' support (script executed from package):
|
|
# * built into ar archive
|
|
# * has preinst, postinst, prerm, postrm args
|
|
#
|
|
############################################################
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use IPC::Open3;
|
|
use IO::Select;
|
|
use IO::Socket;
|
|
use Compress::Zlib;
|
|
use Digest::SHA qw( sha256_hex );
|
|
use Data::Dumper;
|
|
|
|
my $snapver;
|
|
my $conffile = '/etc/snap.conf';
|
|
my $conf = readconf( $conffile );
|
|
my @opts = (
|
|
'info',
|
|
'list',
|
|
'hash',
|
|
'install',
|
|
'installed',
|
|
'reinstall',
|
|
'refresh',
|
|
'remove',
|
|
'search'
|
|
);
|
|
|
|
open( FILE, "</etc/snap_version" );
|
|
$snapver = <FILE>;
|
|
close( FILE );
|
|
chomp( $snapver );
|
|
|
|
sub readconf {
|
|
my $file = shift;
|
|
my $section = '';
|
|
my %data;
|
|
|
|
open( FILE, "<$file" ) || die( "open: $file: $!\n" );
|
|
|
|
while ( <FILE> ) {
|
|
chomp( $_ );
|
|
|
|
if ( $_ =~ /\[(\S+)\]/ ) {
|
|
$section = $1;
|
|
|
|
next;
|
|
}
|
|
elsif ( $_ =~ /(\S+)\s*=\s*(.*)$/ ) {
|
|
$data{$section}{$1} = $2;
|
|
}
|
|
}
|
|
|
|
close( FILE );
|
|
|
|
if ( ! $data{'general'}{'snapdir'} ) {
|
|
die( "readconf: $file: snapdir is required under [general]\n" );
|
|
}
|
|
elsif ( ! $data{'general'}{'pkgfile'} ) {
|
|
die( "readconf: $file: pkgfile is required under [general]\n" );
|
|
}
|
|
elsif ( ! $data{'sources'} ) {
|
|
die( "readconf: $file: no sources defined\n" );
|
|
}
|
|
|
|
return( \%data );
|
|
}
|
|
|
|
sub runcmd{
|
|
my $cmd = shift;
|
|
my %runcmd = (
|
|
sel => IO::Select->new(),
|
|
pid => 0,
|
|
stat => 0,
|
|
fh_out => '',
|
|
fh_err => ''
|
|
);
|
|
|
|
$runcmd{'pid'} = open3( \*CHLD_STDIN, \*CHLD_STDOUT,
|
|
\*CHLD_STDERR, $cmd );
|
|
close( CHLD_STDIN );
|
|
|
|
$runcmd{'sel'}->add( *CHLD_STDOUT, *CHLD_STDERR );
|
|
|
|
$runcmd{'fh_out'} = *CHLD_STDOUT;
|
|
$runcmd{'fh_err'} = *CHLD_STDERR;
|
|
|
|
return( %runcmd );
|
|
}
|
|
|
|
sub info{
|
|
my $pkgfile = shift;
|
|
my $target = shift || '';
|
|
my $pkgdir = "$target/$conf->{'general'}{'snapdir'}/$pkgfile";
|
|
my $cmd = "ar p $pkgfile snapinfo";
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => '',
|
|
info => {
|
|
package => '',
|
|
version => '',
|
|
depends => '',
|
|
arch => '',
|
|
bytes => 0,
|
|
url => '',
|
|
description => ''
|
|
}
|
|
);
|
|
my $regex = '^('
|
|
. 'package'
|
|
. '|version'
|
|
. '|depends'
|
|
. '|arch'
|
|
. '|bytes'
|
|
. '|url'
|
|
. '|description'
|
|
. '):\s+(.*)';
|
|
my %runcmd;
|
|
my $el;
|
|
|
|
if ( ! -f $pkgfile && -f "$pkgdir/snapinfo" ){
|
|
my $snapinfo = "$pkgdir/snapinfo";
|
|
|
|
open( SNAPINFO, "<$snapinfo" );
|
|
|
|
while ( my $line = <SNAPINFO> ){
|
|
if ( $line =~ /$regex/ ){
|
|
$el = $1;
|
|
$result{'info'}{$el} = $2;
|
|
}
|
|
elsif ( $el ){
|
|
$result{'info'}{$el} .= $line;
|
|
}
|
|
}
|
|
|
|
return( \%result );
|
|
}
|
|
elsif ( ! -f $pkgfile ){
|
|
$result{'stderr'} = "No such package ($pkgfile) found";
|
|
$result{'status'} = -1;
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
foreach my $fh ( @fhs ){
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
while ( my $line = <$fh> ){
|
|
$result{'stdout'} .= $line;
|
|
chomp( $line );
|
|
|
|
if ( $line =~ /$regex/ ){
|
|
$el = $1;
|
|
$result{'info'}{$el} = $2;
|
|
}
|
|
elsif ( $el ){
|
|
$result{'info'}{$el} .= $line;
|
|
}
|
|
}
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub list{
|
|
my $pkgfile = shift;
|
|
my $target = shift || '';
|
|
my $pkgdir = "$target/$conf->{'general'}{'snapdir'}/$pkgfile";
|
|
my $cmd = "ar p $pkgfile manifest";
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => '',
|
|
list => []
|
|
);
|
|
my %runcmd;
|
|
|
|
if ( ! -f $pkgfile && -f "$pkgdir/manifest" ){
|
|
my $manifest = "$pkgdir/manifest";
|
|
|
|
open( MANIFEST, "<$manifest" );
|
|
|
|
while ( my $line = <MANIFEST> ){
|
|
my ( $sha256, $perms, $file ) = split( /\s+/, $line );
|
|
my $type = substr( $perms, 0, 1 );
|
|
|
|
if ( $file =~ /^\.{1,2}$/ ){
|
|
next;
|
|
}
|
|
|
|
push( @{$result{'list'}}, {
|
|
sha256 => $sha256,
|
|
perms => $perms,
|
|
file => $file,
|
|
type => $type
|
|
} );
|
|
}
|
|
|
|
close( MANIFEST );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
foreach my $fh ( @fhs ){
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
while ( my $line = <$fh> ){
|
|
my $sha256;
|
|
my $perms;
|
|
my $file;
|
|
my $type;
|
|
|
|
chomp( $line );
|
|
|
|
( $sha256, $perms, $file ) =
|
|
split( /\s/, $line );
|
|
|
|
$type = substr( $perms, 0, 1 );
|
|
|
|
push( @{$result{'list'}}, {
|
|
sha256 => $sha256,
|
|
perms => $perms,
|
|
file => $file,
|
|
type => $type
|
|
} );
|
|
}
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub installed{
|
|
my $target = shift || '';
|
|
my $pkgsdir = "$target/$conf->{'general'}{'snapdir'}";
|
|
my %result;
|
|
|
|
opendir( DIR, $pkgsdir ) || die( "Error: $!" );
|
|
|
|
while ( my $file = readdir( DIR ) ){
|
|
if ( $file =~ /^\.{1,2}$/ || ! -d "$pkgsdir/$file" ){
|
|
next;
|
|
}
|
|
|
|
if ( -f "$pkgsdir/$file/snapinfo" ){
|
|
open( SNAPINFO, "<$pkgsdir/$file/snapinfo" )
|
|
|| die( "Error: $!" );
|
|
|
|
while ( my $line = <SNAPINFO> ){
|
|
if ( $line =~ /^package:\s*(\S+)$/ ){
|
|
$result{$file}{'package'} = $1;
|
|
}
|
|
elsif ( $line =~ /^version:\s*(\S+)$/ ){
|
|
$result{$file}{'version'} = $1;
|
|
}
|
|
elsif ( $line =~ /^bytes:\s*(\S+)$/ ){
|
|
$result{$file}{'bytes'} = $1;
|
|
}
|
|
elsif ( $line =~ /^description:\s*(.*)$/ ){
|
|
$result{$file}{'description'} = $1;
|
|
}
|
|
}
|
|
|
|
close( SNAPINFO );
|
|
}
|
|
}
|
|
|
|
close( DIR );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub repo {
|
|
my %packages;
|
|
|
|
foreach my $source ( keys( %{$conf->{'sources'}} ) ) {
|
|
my $file = "/$conf->{'general'}{'snapdir'}/$source-packages.gz";
|
|
my $data = gzopen( $file, 'r' );
|
|
my $buffer;
|
|
my $lastpkg;
|
|
|
|
while ( $data->gzreadline( $buffer ) > 0 ) {
|
|
if ( $buffer =~ /^package:\s+(.*)$/ ) {
|
|
$lastpkg = $1;
|
|
}
|
|
elsif ( $buffer =~ /^version:\s+(.*)$/ ) {
|
|
$packages{$lastpkg}{'version'} = $1;
|
|
}
|
|
elsif ( $buffer =~ /^depends:\s+(.*)$/ ) {
|
|
$packages{$lastpkg}{'depends'} = $1;
|
|
}
|
|
elsif ( $buffer =~ /^bytes:\s+(.*)$/ ) {
|
|
$packages{$lastpkg}{'bytes'} = $1;
|
|
}
|
|
elsif ( $buffer =~ /^description:\s+(.*)$/ ) {
|
|
$packages{$lastpkg}{'description'} = $1;
|
|
}
|
|
elsif ( $buffer =~ /^path:\s+(.*)$/ ) {
|
|
$packages{$lastpkg}{'path'} = $1;
|
|
}
|
|
elsif ( $buffer =~ /^sha256:\s+(.*)$/ ) {
|
|
$packages{$lastpkg}{'sha256'} = $1;
|
|
}
|
|
}
|
|
|
|
$data->gzclose();
|
|
}
|
|
|
|
return( \%packages );
|
|
}
|
|
|
|
sub hash{
|
|
my $pkgfile = shift;
|
|
my $result = {
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => '',
|
|
hash => ''
|
|
};
|
|
|
|
if ( ! -f $pkgfile ){
|
|
$result->{'status'} = 1;
|
|
$result->{'stderr'} = "'$pkgfile' not a valid package file";
|
|
|
|
return( $result );
|
|
}
|
|
|
|
open( PKG, "$pkgfile" );
|
|
|
|
$result->{'hash'} = sha256_hex( <PKG> );
|
|
|
|
close( PKG );
|
|
|
|
return( $result );
|
|
}
|
|
|
|
sub human{
|
|
my $B = shift;
|
|
my $human;
|
|
|
|
if ( $B > 1099511627776 ){
|
|
$human = sprintf( '%.02f', $B / ( 1024 ** 4 ) ) . 'TB';
|
|
}
|
|
elsif ( $B > 1073741824 ){
|
|
$human = sprintf( '%.02f', $B / ( 1024 ** 3 ) ) . 'GB';
|
|
}
|
|
elsif ( $B > 1048576 ){
|
|
$human = sprintf( '%.02f', $B / ( 1024 ** 2 ) ) . 'MB';
|
|
}
|
|
else{
|
|
$human = sprintf( '%.02f', $B / 1024 ) . 'KB';
|
|
}
|
|
|
|
return( $human );
|
|
}
|
|
|
|
sub conflicts{
|
|
my $pkgfile = shift;
|
|
my $target = shift || '';
|
|
my $infodata = info( $pkgfile, $target );
|
|
my $listdata = list( $pkgfile );
|
|
my $snapdir = "$target/$conf->{'general'}{'snapdir'}";
|
|
my @conflicts;
|
|
|
|
print "Checking for conflicts...\n";
|
|
|
|
opendir( DIR, $snapdir ) || die( $! );
|
|
|
|
####################################################
|
|
#
|
|
# Need to re-write this a little more efficiently..
|
|
# Should we design a SQLite DB to hold this data??
|
|
#
|
|
# It would be preferable to stick with flat files
|
|
# and directories for simplicity...
|
|
#
|
|
####################################################
|
|
|
|
while ( my $pkgdir = readdir( DIR ) ){
|
|
if ( ! -d "$snapdir/$pkgdir" || $pkgdir =~ /^\.{1,2}$/ ||
|
|
$infodata->{'info'}{'package'} eq $pkgdir ){
|
|
next;
|
|
}
|
|
|
|
if ( ! -f "$snapdir/$pkgdir/manifest" ) {
|
|
next;
|
|
}
|
|
|
|
open( MANIFEST, "<$snapdir/$pkgdir/manifest" ) || die( $! );
|
|
|
|
while ( my $line = <MANIFEST> ){
|
|
( my $file = $line ) =~ s/.*\t//g;
|
|
chomp( $file );
|
|
|
|
foreach my $data ( @{$listdata->{'list'}} ){
|
|
if ( $data->{'file'} eq $file
|
|
&& $data->{'type'} ne 'd' ){
|
|
push( @conflicts, "$pkgdir: $file" );
|
|
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( @conflicts ){
|
|
return( \@conflicts );
|
|
}
|
|
else{
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub depends {
|
|
my $packages = shift;
|
|
my $package = shift;
|
|
my $depends = shift;
|
|
|
|
if ( $packages->{$package} && $packages->{$package}{'depends'} ) {
|
|
foreach my $depend ( split( ',',
|
|
$packages->{$package}{'depends'} ) ) {
|
|
depends( $packages, $depend, $depends );
|
|
|
|
push( @$depends, $depend );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub mkinfo{
|
|
my $target = shift || '';
|
|
my $infodir = "$target/usr/share/info";
|
|
|
|
opendir( INFODIR, "<$infodir" );
|
|
|
|
while ( my $file = readdir( INFODIR ) ){
|
|
if ( ! -f $file ){
|
|
next;
|
|
}
|
|
|
|
system( "cd $infodir && install-info $file dir" ) ||
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
sub chkempty{
|
|
my $dir = shift;
|
|
my $empty = 1;
|
|
|
|
if ( ! -d $dir ) {
|
|
return;
|
|
}
|
|
|
|
opendir( DIR, $dir ) || die( $! );
|
|
|
|
while ( my $file = readdir( DIR ) ){
|
|
if ( $file =~ /^\.{1,2}$/ ){
|
|
next;
|
|
}
|
|
else{
|
|
$empty = 0;
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
return( $empty );
|
|
}
|
|
|
|
sub usher{
|
|
my $pkgfile = shift;
|
|
my $target = shift || '';
|
|
my $stage = shift;
|
|
my $snapdir;
|
|
my $pkgdir;
|
|
my $infodata;
|
|
my $usher;
|
|
my %runcmd;
|
|
my $cmd = "ar -t $pkgfile";
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
$snapdir = "$target/$conf->{'general'}{'snapdir'}";
|
|
$infodata = info( $pkgfile, $target );
|
|
$pkgdir = "$snapdir/$infodata->{'info'}{'package'}";
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
local $| = 1;
|
|
|
|
foreach my $fh ( @fhs ){
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
while ( my $line = <$fh> ){
|
|
chomp( $line );
|
|
|
|
if ( $line eq 'usher' ){
|
|
$usher = "$pkgdir/usher";
|
|
}
|
|
}
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
if ( ! $result{'stderr'} ){
|
|
$result{'stderr'} = <$fh>;
|
|
}
|
|
else{
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
|
|
if ( $result{'stdout'} ){
|
|
chomp( $result{'stdout'} );
|
|
}
|
|
if ( $result{'stderr'} ){
|
|
chomp( $result{'stderr'} );
|
|
}
|
|
|
|
if ( $result{'status'} || ! $usher ){
|
|
return( \%result );
|
|
}
|
|
|
|
if ( ! -d $pkgdir ){
|
|
mkdir( $pkgdir );
|
|
}
|
|
|
|
undef( $result{'stdout'} );
|
|
undef( $result{'stderr'} );
|
|
$cmd = "ar -p $pkgfile usher > $usher";
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
local $| = 1;
|
|
|
|
foreach my $fh ( @fhs ){
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
if ( ! $result{'stdout'} ){
|
|
$result{'stdout'} = <$fh>;
|
|
}
|
|
else{
|
|
$result{'stdout'} .= <$fh>;
|
|
}
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
if ( ! $result{'stderr'} ){
|
|
$result{'stderr'} = <$fh>;
|
|
}
|
|
else{
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
|
|
if ( $result{'stdout'} ){
|
|
chomp( $result{'stdout'} );
|
|
}
|
|
if ( $result{'stderr'} ){
|
|
chomp( $result{'stderr'} );
|
|
}
|
|
|
|
if ( $result{'status'} ){
|
|
return( \%result );
|
|
}
|
|
|
|
undef( $result{'stdout'} );
|
|
undef( $result{'stderr'} );
|
|
|
|
chmod( 0700, $usher ) || do{
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = $!;
|
|
|
|
return( \%result );
|
|
};
|
|
|
|
if ( $target ) {
|
|
$cmd = "chroot $target && $usher $stage";
|
|
}
|
|
else {
|
|
$cmd = "$usher $stage";
|
|
}
|
|
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
local $| = 1;
|
|
|
|
foreach my $fh ( @fhs ){
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
my $line = <$fh>;
|
|
|
|
if ( $line ){
|
|
print STDOUT $line;
|
|
}
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
my $line = <$fh>;
|
|
|
|
if ( $line ){
|
|
print STDERR $line;
|
|
}
|
|
}
|
|
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
|
|
if ( $result{'stdout'} ){
|
|
chomp( $result{'stdout'} );
|
|
}
|
|
if ( $result{'stderr'} ){
|
|
chomp( $result{'stderr'} );
|
|
}
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub httpget {
|
|
my $url = shift;
|
|
my $dest = shift;
|
|
my $mode = shift;
|
|
( my $host = $url ) =~ s/^https?:\/\/|\/.*//g;
|
|
( my $file = $url ) =~ s/.*$host//;
|
|
my %httpget = (
|
|
'status' => '',
|
|
'length' => 0,
|
|
'type' => '',
|
|
'data' => '',
|
|
'dflag' => 0
|
|
);
|
|
my $sock = IO::Socket::INET->new(
|
|
PeerAddr => $host,
|
|
PeerPort => 'http(80)',
|
|
Proto => 'tcp'
|
|
) || die( $! );
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
$sock->send("GET $file HTTP/1.0\r\n");
|
|
$sock->send("Host: $host\r\n");
|
|
$sock->send("\r\n");
|
|
|
|
if ( $dest && $mode ) {
|
|
open( DEST, ">$dest" ) || do{
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = "open: $dest: $!";
|
|
|
|
return( \%result );
|
|
};
|
|
chmod( $mode, $dest ) || do{
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = "chmod: $dest: $!";
|
|
|
|
return( \%result );
|
|
}
|
|
}
|
|
elsif ( $dest && ! $mode ) {
|
|
die( "httpget: Provided dest ($dest) without mode!\n" );
|
|
}
|
|
|
|
while ( <$sock> ) {
|
|
if ( ! $httpget{'dflag'} ) {
|
|
if ( ! $httpget{'status'}
|
|
&& $_ =~ /^HTTP\S+\s(\d+)/ ) {
|
|
$httpget{'status'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'date'}
|
|
&& $_ =~ /^Date:\s+(.*)/ ) {
|
|
$httpget{'date'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'server'}
|
|
&& $_ =~ /^Server:\s+(.*)/ ) {
|
|
$httpget{'server'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'lastmod'}
|
|
&& $_ =~ /^Last-Modified:\s+(.*)/ ) {
|
|
$httpget{'lastmod'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'etag'}
|
|
&& $_ =~ /^ETag:\s+(.*)/ ) {
|
|
$httpget{'etag'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'length'}
|
|
&& $_ =~ /Content-Length:\s+(\d+)/ ) {
|
|
$httpget{'length'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'type'}
|
|
&& $_ =~ /Content-Type:\s+(\S+)/ ) {
|
|
$httpget{'type'} = $1;
|
|
}
|
|
elsif( $_ eq "\r\n" ) {
|
|
$httpget{'dflag'}++;
|
|
}
|
|
|
|
next;
|
|
}
|
|
|
|
if ( ! $dest ) {
|
|
$httpget{'data'} .= $_;
|
|
}
|
|
else {
|
|
print DEST $_;
|
|
}
|
|
}
|
|
|
|
close( $sock );
|
|
return( \%httpget );
|
|
}
|
|
|
|
sub install{
|
|
my $pkgfile = shift;
|
|
my $target = shift || '';
|
|
my $snapdir = "$target/$conf->{'general'}{'snapdir'}";
|
|
my $infodata;
|
|
my $confirm;
|
|
my $cmd;
|
|
my %runcmd;
|
|
my $install;
|
|
my $package;
|
|
my $version;
|
|
my $snapinfo;
|
|
my $manifest;
|
|
my $filenum = 0;
|
|
my $type = 0;
|
|
my $mkinfo = 0;
|
|
my $usher;
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
if ( ! -d $snapdir ) {
|
|
mkdirp( $snapdir, 0755 ) || die( $! );
|
|
}
|
|
|
|
$infodata = info( $pkgfile );
|
|
|
|
if ( $infodata->{'status'} ) {
|
|
$result{'status'} = $infodata->{'status'};
|
|
$result{'stdout'} = $infodata->{'stdout'};
|
|
$result{'stderr'} = $infodata->{'stderr'};
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
$package = $infodata->{'info'}->{'package'};
|
|
$version = $infodata->{'info'}->{'version'};
|
|
$snapinfo = "$snapdir/$package/snapinfo";
|
|
$manifest = "$snapdir/$package/manifest";
|
|
|
|
print "Preparing to install $package-$version...\n";
|
|
|
|
if ( my $conflicts = conflicts( $pkgfile, $target ) ){
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = "Package $package conflicts"
|
|
. " with the following packages/files:\n"
|
|
. join( "\n", @$conflicts );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# If the package is already installed check the
|
|
# version and return if it is already installed
|
|
#
|
|
####################################################
|
|
|
|
if ( -f $snapinfo ){
|
|
open( SNAPINFO, "<$snapinfo" ) || die( $! );
|
|
|
|
while( my $line = <SNAPINFO> ){
|
|
if ( $line =~ /^version: (\S+)/ ){
|
|
my @sorted = sort( { vercmp( $a, $b ) }
|
|
( $1, $version ) );
|
|
|
|
if ( $sorted[0] eq $sorted[1] ){
|
|
$result{'status'} = -1;
|
|
$result{'stderr'} = "$package $version"
|
|
. " already installed";
|
|
|
|
return( \%result );
|
|
}
|
|
elsif ( $version eq $sorted[0] ){
|
|
$type = -1;
|
|
}
|
|
elsif ( $version eq $sorted[1] ){
|
|
$type = 1;
|
|
}
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
close( SNAPINFO );
|
|
}
|
|
|
|
if ( ! $confirm ){
|
|
my $size = human( $infodata->{'info'}->{'bytes'} );
|
|
|
|
print "Package: $infodata->{'info'}->{'package'}\n"
|
|
. "Version: $infodata->{'info'}->{'version'}\n"
|
|
. "Size: $size\n";
|
|
|
|
if ( $type == -1 ){
|
|
print "Downgrade $package to $version on $target?"
|
|
. "(y/n): ";
|
|
}
|
|
elsif ( $type == 1 ){
|
|
print "Upgrade $package to $version on $target?"
|
|
. "(y/n): ";
|
|
}
|
|
else{
|
|
print "Install $package on $target? (y/n): ";
|
|
}
|
|
}
|
|
|
|
while( ! $confirm ){
|
|
$confirm = <STDIN>;
|
|
chomp( $confirm );
|
|
|
|
if ( lc( $confirm ) eq 'n' ){
|
|
print STDERR "Aborting installation\n";
|
|
|
|
exit 1;
|
|
}
|
|
elsif ( lc( $confirm ne 'y' ) ){
|
|
print "Answer 'y' or 'n': ";
|
|
|
|
undef( $confirm );
|
|
}
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# Here we copy the old manifest (if present) to a
|
|
# temp file to compare after installation and clean
|
|
# up any files from the old package that don't exist
|
|
# in the new one.
|
|
#
|
|
####################################################
|
|
|
|
if ( -f $manifest ){
|
|
open( MANIFEST, "<$manifest" ) || die( $! );
|
|
open( TMPMANIFEST, ">$manifest.tmp" ) || die( $! );
|
|
|
|
while ( my $line = <MANIFEST> ){
|
|
print TMPMANIFEST $line || die( $! );
|
|
}
|
|
|
|
close( MANIFEST );
|
|
close( TMPMANIFEST );
|
|
}
|
|
|
|
$usher = usher( $pkgfile, $target, 'preinst' );
|
|
|
|
if ( $usher->{'status'} ) {
|
|
$result{'status'} = $usher->{'status'};
|
|
$result{'stdout'} = $usher->{'stdout'};
|
|
$result{'stderr'} = $usher->{'stderr'};
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
print "Extracting files for $infodata->{'info'}->{'package'}\n\n";
|
|
|
|
if ( $target ) {
|
|
$cmd = "ar p $pkgfile files.tar.gz|tar -hzvxf - -C $target";
|
|
}
|
|
else {
|
|
$cmd = "ar p $pkgfile files.tar.gz|tar -hzvxf - -C /";
|
|
}
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
local $| = 1;
|
|
|
|
foreach my $fh ( @fhs ){
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
my $line = <$fh>;
|
|
( my $file = $line ) =~ s/.*\/|\n$//;
|
|
chomp( $file );
|
|
|
|
if ( $file ){
|
|
$filenum++;
|
|
print STDOUT "\e[?16;0;200c\033[K"
|
|
. "$file\r";
|
|
}
|
|
|
|
if ( $line
|
|
&& $line =~ /^\/usr\/share\/info\// ){
|
|
$mkinfo = 1;
|
|
}
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
print STDERR <$fh>;
|
|
}
|
|
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
if ( $mkinfo && ! $result{'status'} ){
|
|
if ( mkinfo( $target ) ){
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = 'Failed to update info db';
|
|
}
|
|
}
|
|
|
|
print STDOUT "\e[K$filenum files extracted\n";
|
|
|
|
usher( $pkgfile, $target, 'postinst' );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub reinstall{
|
|
my @args = @_;
|
|
my $pkgfile;
|
|
my $target;
|
|
my $infodata;
|
|
my $confirm;
|
|
my $cmd;
|
|
my %runcmd;
|
|
my $install;
|
|
my $snapdir;
|
|
my $package;
|
|
my $version;
|
|
my $snapinfo;
|
|
my $manifest;
|
|
my $listdata;
|
|
my $filenum = 0;
|
|
my $type = 0;
|
|
my $mkinfo = 0;
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
for ( my $i = $#args; $i >= 0; $i-- ){
|
|
if ( $args[$i] eq '-y' ){
|
|
splice( @args, $i, 1 );
|
|
|
|
$confirm = 'y';
|
|
}
|
|
elsif ( $args[$i] eq 'reinstall' ){
|
|
splice( @args, $i, 1 );
|
|
}
|
|
}
|
|
|
|
( $pkgfile, $target ) = @args;
|
|
|
|
if ( $target ){
|
|
$target =~ s/\/$//;
|
|
}
|
|
else{
|
|
$target = '/';
|
|
}
|
|
|
|
$snapdir = "$target/var/snap";
|
|
$infodata = info( $pkgfile, $target );
|
|
|
|
$package = $infodata->{'info'}->{'package'};
|
|
$version = $infodata->{'info'}->{'version'};
|
|
$snapinfo = "$snapdir/$package/snapinfo";
|
|
$manifest = "$snapdir/$package/manifest";
|
|
|
|
print "Preparing to re-install $package-$version...\n";
|
|
|
|
if ( my $conflicts = conflicts( $pkgfile, $target ) ){
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = "Package $package conflicts"
|
|
. " with the following packages/files:\n"
|
|
. join( "\n", @$conflicts );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
if ( -f $snapinfo ){
|
|
open( SNAPINFO, "<$snapinfo" ) || die( $! );
|
|
|
|
while( my $line = <SNAPINFO> ){
|
|
if ( $line =~ /^version: (\S+)/ ){
|
|
my @sorted = sort( { vercmp( $a, $b ) }
|
|
( $1, $version ) );
|
|
|
|
if ( $sorted[0] eq $sorted[1] ){
|
|
last;
|
|
}
|
|
else{
|
|
close( SNAPINFO );
|
|
|
|
$result{'status'} = -1;
|
|
$result{'stderr'} = "$package $version"
|
|
. " not already installed";
|
|
|
|
return( \%result );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( SNAPINFO );
|
|
}
|
|
|
|
if ( ! $confirm ){
|
|
my $size = human( $infodata->{'info'}->{'bytes'} );
|
|
|
|
print "Package: $infodata->{'info'}->{'package'}\n"
|
|
. "Version: $infodata->{'info'}->{'version'}\n"
|
|
. "Size: $size\n";
|
|
|
|
print "Re-install $package on $target? (y/n): ";
|
|
}
|
|
|
|
while( ! $confirm ){
|
|
$confirm = <STDIN>;
|
|
chomp( $confirm );
|
|
|
|
if ( lc( $confirm ) eq 'n' ){
|
|
print STDERR "Aborting installation\n";
|
|
|
|
exit 1;
|
|
}
|
|
elsif ( lc( $confirm ne 'y' ) ){
|
|
print "Answer 'y' or 'n': ";
|
|
|
|
undef( $confirm );
|
|
}
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# Here we copy the old manifest (if present) to a
|
|
# temp file to compare after installation and clean
|
|
# up any files from the old package that done exist
|
|
# in the new one.
|
|
#
|
|
####################################################
|
|
|
|
open( MANIFEST, "<$manifest" ) || die( $! );
|
|
open( TMPMANIFEST, ">$manifest.tmp" ) || die( $! );
|
|
|
|
while ( my $line = <MANIFEST> ){
|
|
print TMPMANIFEST $line || die( $! );
|
|
}
|
|
|
|
close( MANIFEST );
|
|
close( TMPMANIFEST );
|
|
|
|
print "Extracting files for $infodata->{'info'}->{'package'}\n\n";
|
|
|
|
$cmd = "ar p $pkgfile files.tar.gz|tar -hzvxf - -C $target";
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
local $| = 1;
|
|
|
|
foreach my $fh ( @fhs ){
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
my $line = <$fh>;
|
|
( my $file = $line ) =~ s/.*\/|\n$//;
|
|
chomp( $file );
|
|
|
|
if ( $file ){
|
|
$filenum++;
|
|
print STDOUT "\e[?16;0;200c\033[K"
|
|
. "$file\r";
|
|
}
|
|
|
|
if ( $line
|
|
&& $line =~ /^\/usr\/share\/info\// ){
|
|
$mkinfo = 1;
|
|
}
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
print STDERR <$fh>;
|
|
}
|
|
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
if ( $result{'status'} ){
|
|
return( \%result );
|
|
}
|
|
|
|
if ( $mkinfo && ! $result{'status'} ){
|
|
if ( mkinfo( $target ) ){
|
|
$result{'status'} = 1;
|
|
$result{'stderr'} = 'Failed to update info db';
|
|
|
|
return( \%result );
|
|
}
|
|
}
|
|
|
|
print STDOUT "\e[K$filenum files extracted\n";
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub remove {
|
|
my @args = @_;
|
|
my $package;
|
|
my $target;
|
|
my $snapdir;
|
|
my $infodata;
|
|
my $listdata;
|
|
my $confirm;
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
for ( my $i = $#args; $i >= 0; $i-- ){
|
|
if ( $args[$i] eq '-y' ){
|
|
splice( @args, $i, 1 );
|
|
|
|
$confirm = 'y';
|
|
}
|
|
elsif ( $args[$i] eq 'remove' ){
|
|
splice( @args, $i, 1 );
|
|
}
|
|
}
|
|
|
|
$package = $args[0];
|
|
( $target = $args[1] || '' ) =~ s/\/$//;
|
|
$snapdir = "$target/$conf->{'general'}{'snapdir'}";
|
|
|
|
if ( ! $package ){
|
|
$result{'status'} = -1;
|
|
$result{'stderr'} = 'You must supply a package name';
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
if ( -d "$snapdir/$package" ){
|
|
$infodata = info( $package, $target );
|
|
$listdata = list( $package, $target );
|
|
}
|
|
else{
|
|
$result{'stderr'} = "Package '$package' is not installed";
|
|
$result{'status'} = -1;
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
if ( ! $confirm ){
|
|
my $size = human( $infodata->{'info'}->{'bytes'} );
|
|
|
|
print "Package: $infodata->{'info'}->{'package'}\n"
|
|
. "Version: $infodata->{'info'}->{'version'}\n"
|
|
. "Size: $size\n"
|
|
. "Remove $package from $target? (y/n): ";
|
|
}
|
|
|
|
while( ! $confirm ){
|
|
$confirm = <STDIN>;
|
|
chomp( $confirm );
|
|
|
|
if ( lc( $confirm ) eq 'n' ){
|
|
print STDERR "Aborting removal\n";
|
|
|
|
exit 1;
|
|
}
|
|
elsif ( lc( $confirm ne 'y' ) ){
|
|
print "Answer 'y' or 'n': ";
|
|
|
|
undef( $confirm );
|
|
}
|
|
}
|
|
|
|
foreach my $data ( @{$listdata->{'list'}} ){
|
|
if ( $data->{'type'} ne 'd' ){
|
|
unlink( "$target/$data->{'file'}" );
|
|
}
|
|
}
|
|
|
|
foreach my $data ( @{$listdata->{'list'}} ){
|
|
if ( $data->{'type'} eq 'd' ){
|
|
if ( chkempty( "$target/$data->{'file'}" ) ){
|
|
rmdir( "$target/$data->{'file'}" );
|
|
}
|
|
}
|
|
}
|
|
|
|
opendir( DIR, "$snapdir/$package" );
|
|
|
|
while ( my $file = readdir( DIR ) ){
|
|
if ( $file !~ /^\.{1,2}$/ ){
|
|
unlink( "$snapdir/$package/$file" ) || die( $! );
|
|
}
|
|
}
|
|
|
|
rmdir( "$snapdir/$package" ) || die( $! );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub manifest{
|
|
my @args = @_;
|
|
my $pkgfile;
|
|
my $target;
|
|
my $infodata;
|
|
my $listdata;
|
|
my $snapdir;
|
|
my $cmd;
|
|
my %runcmd;
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
for ( my $i = $#args; $i >= 0; $i-- ){
|
|
if ( $args[$i] eq '-y' ){
|
|
splice( @args, $i, 1 );
|
|
}
|
|
elsif ( $args[$i] =~ /(re)*install/ ){
|
|
splice( @args, $i, 1 );
|
|
}
|
|
}
|
|
|
|
( $pkgfile, $target ) = @args;
|
|
|
|
if ( $target ){
|
|
$target =~ s/\/$//;
|
|
}
|
|
else{
|
|
$target = '';
|
|
}
|
|
|
|
$infodata = info( $pkgfile, $target );
|
|
$listdata = list( $pkgfile );
|
|
|
|
$snapdir = "$target/var/snap/$infodata->{'info'}->{'package'}";
|
|
|
|
mkdir( "$snapdir" );
|
|
$cmd = "ar p $pkgfile manifest > $snapdir/manifest";
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
foreach my $fh ( @fhs ){
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
$result{'stdout'} .= <$fh>;
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub mkdirp{
|
|
( my $dir = shift ) =~ s/\/^//;
|
|
my $mode = shift;
|
|
( my $parent = $dir ) =~ s/\/[^\/]+$//;
|
|
|
|
if ( -d $dir ){
|
|
return;
|
|
}
|
|
|
|
mkdirp( $parent, $mode );
|
|
|
|
mkdir( $dir ) || return( $! );
|
|
}
|
|
|
|
sub snapinfo{
|
|
my @args = @_;
|
|
my $pkgfile;
|
|
my $target;
|
|
my $infodata;
|
|
my $snapdir;
|
|
my $cmd;
|
|
my %runcmd;
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
for ( my $i = $#args; $i >= 0; $i-- ){
|
|
if ( $args[$i] eq '-y' ){
|
|
splice( @args, $i, 1 );
|
|
}
|
|
elsif ( $args[$i] =~ /(re)*install/ ){
|
|
splice( @args, $i, 1 );
|
|
}
|
|
}
|
|
|
|
( $pkgfile, $target ) = @args;
|
|
|
|
if ( $target ){
|
|
$target =~ s/\/$//;
|
|
}
|
|
else{
|
|
$target = '';
|
|
}
|
|
|
|
$infodata = info( $pkgfile, $target );
|
|
|
|
$snapdir = "$target/var/snap/$infodata->{'info'}->{'package'}";
|
|
|
|
mkdir( "$snapdir" );
|
|
$cmd = "ar p $pkgfile snapinfo > $snapdir/snapinfo";
|
|
%runcmd = runcmd( $cmd );
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
foreach my $fh ( @fhs ){
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
$result{'stdout'} .= <$fh>;
|
|
}
|
|
elsif( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
sub search {
|
|
my $searchstring = shift;
|
|
|
|
foreach my $source ( keys( %{$conf->{'sources'}} ) ) {
|
|
my $file = "/$conf->{'general'}{'snapdir'}/$source-packages.gz";
|
|
my $data = gzopen( $file, 'r' );
|
|
my $buffer;
|
|
my @packages;
|
|
|
|
while ( $data->gzreadline( $buffer ) > 0 ) {
|
|
if ( $buffer =~ /^package:\s+(.*)$/ ) {
|
|
print "$1";
|
|
}
|
|
elsif ( $buffer =~ /^version:\s+(.*)$/ ) {
|
|
print "-$1";
|
|
}
|
|
elsif ( $buffer =~ /^description:\s+(.*)$/ ) {
|
|
print " - $1\n";
|
|
}
|
|
}
|
|
|
|
$data->gzclose();
|
|
}
|
|
}
|
|
|
|
sub sttysize {
|
|
my %size = (
|
|
width => 0,
|
|
height => 0
|
|
);
|
|
my $cmd = 'stty size';
|
|
my %runcmd = runcmd( $cmd );
|
|
my %result = (
|
|
status => 0,
|
|
stdout => '',
|
|
stderr => ''
|
|
);
|
|
|
|
while ( my @fhs = $runcmd{'sel'}->can_read ){
|
|
foreach my $fh ( @fhs ){
|
|
if ( eof( $fh ) ){
|
|
$runcmd{'sel'}->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( $runcmd{'fh_out'} ) ){
|
|
while ( my $line = <$fh> ){
|
|
$result{'stdout'} .= $line;
|
|
}
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( $runcmd{'fh_err'} ) ){
|
|
$result{'stderr'} .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( $runcmd{'fh_out'} );
|
|
close( $runcmd{'fh_err'} );
|
|
|
|
waitpid( $runcmd{'pid'}, 0 );
|
|
$result{'status'} = $? >> 8;
|
|
|
|
chomp( $result{'stdout'} );
|
|
chomp( $result{'stderr'} );
|
|
|
|
return( \%result );
|
|
}
|
|
|
|
### vercmp() ###############################################
|
|
#
|
|
# This subroutine was basically copied verbatim from the
|
|
# Sort::Versions module. It was modified slightly so that
|
|
# it more closely matched the aesthetics of the rest of
|
|
# the snap code. The following credits were provided within
|
|
# the documentation of that module:
|
|
#
|
|
# Ed Avis <ed@membled.com> and Matt Johnson
|
|
# <mwj99@doc.ic.ac.uk> for recent releases; the original
|
|
# author is Kenneth J. Albanowski <kjahds@kjahds.com>.
|
|
# Thanks to Hack Kampbjørn and Slaven Rezic for patches
|
|
# and bug reports.
|
|
#
|
|
# Copyright (c) 1996, Kenneth J. Albanowski. All rights
|
|
# reserved. This program is free software; you can
|
|
# redistribute it and/or modify it under the same terms as
|
|
# Perl itself.
|
|
#
|
|
############################################################
|
|
|
|
sub vercmp{
|
|
my @A = ( $_[0] =~ /([-.]|\d+|[^-.\d]+)/g );
|
|
my @B = ( $_[1] =~ /([-.]|\d+|[^-.\d]+)/g );
|
|
my ( $A, $B );
|
|
|
|
while ( @A and @B ){
|
|
$A = shift @A;
|
|
$B = shift @B;
|
|
|
|
if ( $A eq '-' and $B eq '-' ){
|
|
next;
|
|
}
|
|
elsif ( $A eq '-' ){
|
|
return -1;
|
|
}
|
|
elsif ( $B eq '-' ){
|
|
return 1;
|
|
}
|
|
elsif ( $A eq '.' and $B eq '.' ){
|
|
next;
|
|
}
|
|
elsif ( $A eq '.' ){
|
|
return -1;
|
|
}
|
|
elsif ( $B eq '.' ){
|
|
return 1;
|
|
}
|
|
elsif ( $A =~ /^\d+$/ and $B =~ /^\d+$/ ){
|
|
if ( $A =~ /^0/ || $B =~ /^0/ ){
|
|
return $A cmp $B if $A cmp $B;
|
|
}
|
|
else{
|
|
return $A <=> $B if $A <=> $B;
|
|
}
|
|
}
|
|
else{
|
|
$A = uc $A;
|
|
$B = uc $B;
|
|
return $A cmp $B if $A cmp $B;
|
|
}
|
|
}
|
|
|
|
@A <=> @B;
|
|
}
|
|
|
|
if ( $ARGV[0] eq 'info' ){
|
|
my $result = info( $ARGV[1], $ARGV[2] || '' );
|
|
my $info = $result->{'info'};
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
|
|
print "package: $info->{'package'}\nversion: $info->{'version'}\n";
|
|
print "depends: $info->{'depends'}\n";
|
|
print "bytes: $info->{'bytes'}\nurl: $info->{'url'}\n";
|
|
print "description: $info->{'description'}\n";
|
|
|
|
exit 0;
|
|
}
|
|
elsif ( $ARGV[0] eq 'list' && $ARGV[1] ){
|
|
my $result = list( $ARGV[1], $ARGV[2] || '' );
|
|
my $list = $result->{'list'};
|
|
|
|
if ( $result->{'status'} ){
|
|
print "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
|
|
foreach my $row ( @$list ){
|
|
if ( $row->{'type'} eq 'd' ){
|
|
next;
|
|
}
|
|
|
|
print "$row->{'sha256'}\t$row->{'file'}\n";
|
|
}
|
|
}
|
|
elsif ( $ARGV[0] eq 'installed' ){
|
|
my $result = installed( $ARGV[1] || '' );
|
|
|
|
foreach my $key ( sort( keys( %{$result} ) ) ){
|
|
if ( $result->{$key}{'package'} && -t STDOUT ){
|
|
printf( '%-10.10s ', $result->{$key}{'package'} );
|
|
}
|
|
elsif ( $result->{$key}{'package'} ){
|
|
printf( '%-30.30s', $result->{$key}{'package'} );
|
|
}
|
|
else{
|
|
printf( '%-10.10s ', 'UNKNOWN' );
|
|
}
|
|
|
|
if ( $result->{$key}{'version'} && -t STDOUT ){
|
|
printf( '%-10.10s ', $result->{$key}{'version'} );
|
|
}
|
|
elsif ( $result->{$key}{'version'} ){
|
|
printf( '%-20.20s', $result->{$key}{'version'} );
|
|
}
|
|
else{
|
|
printf( '%-10.10s ', 'UNKNOWN' );
|
|
}
|
|
|
|
if ( $result->{$key}{'description'} && -t STDOUT ){
|
|
printf( '%.58s', $result->{$key}{'description'} );
|
|
}
|
|
elsif ( $result->{$key}{'description'} ){
|
|
print "$result->{$key}{'description'}";
|
|
}
|
|
else{
|
|
printf( '%.58s', ' ' );
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
}
|
|
elsif ( $ARGV[0] eq 'hash' ){
|
|
my $result = hash( $ARGV[1] );
|
|
my $hash = $result->{'hash'};
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
|
|
print "$hash\n";
|
|
}
|
|
elsif ( $ARGV[0] eq 'install' ){
|
|
my $packages = repo();
|
|
my $installed = installed();
|
|
my $result; # = install( @ARGV );
|
|
my $infodata;
|
|
my $listdata;
|
|
my $manifest;
|
|
my $package;
|
|
my @depends;
|
|
my @depfails;
|
|
my $size = 0;
|
|
my $yes = 0;
|
|
my $target;
|
|
|
|
for ( my $i = 0; $i <= $#ARGV; $i++ ){
|
|
if ( $ARGV[$i] eq 'install' ){
|
|
next;
|
|
}
|
|
elsif ( $ARGV[$i] eq '-y' ){
|
|
$yes++;
|
|
|
|
next;
|
|
}
|
|
|
|
if ( ! $package ){
|
|
$package = $ARGV[$i];
|
|
}
|
|
else{
|
|
$target = $ARGV[$i];
|
|
}
|
|
}
|
|
|
|
if ( ! -f $package ) {
|
|
if ( ! $packages->{$package} ) {
|
|
print STDERR "$package is not a valid snap file"
|
|
. " and not available in any repos\n";
|
|
|
|
exit 1;
|
|
}
|
|
}
|
|
else {
|
|
my $info = info( $package );
|
|
|
|
if ( $installed->{$info->{'info'}{'package'}} &&
|
|
$packages->{$package}{'version'} eq
|
|
$installed->{$info->{'info'}{'package'}} ) {
|
|
print STDERR "$package $info->{'info'}{'version'}"
|
|
. " is already installed\n";
|
|
|
|
exit 1;
|
|
}
|
|
|
|
$packages->{$package} = $info->{'info'};
|
|
}
|
|
|
|
depends( $packages, $package, \@depends );
|
|
|
|
for ( my $i = $#depends; $i >= 0; $i-- ) {
|
|
if ( $installed->{$depends[$i]} ) {
|
|
splice( @depends, $i, 1 );
|
|
}
|
|
}
|
|
|
|
foreach my $pkg ( ( @depends, $package ) ) {
|
|
if ( ! $packages->{$pkg} ) {
|
|
push( @depfails, $pkg );
|
|
}
|
|
else {
|
|
$size += $packages->{$pkg}{'bytes'};
|
|
}
|
|
}
|
|
|
|
if ( @depfails ) {
|
|
print STDERR "The following dependencies are not"
|
|
. " available in any repos:\n";
|
|
|
|
foreach my $depfail ( sort( @depfails ) ) {
|
|
print STDERR " $depfail\n";
|
|
}
|
|
|
|
exit 1;
|
|
}
|
|
|
|
if ( ! $yes ){
|
|
if ( @depends ) {
|
|
print "The following dependencies will need to be"
|
|
. " installed:\n"
|
|
. join( ' ', @depends ) . "\n";
|
|
}
|
|
|
|
print "Total size on disk: " . human( $size )
|
|
. " ($size bytes)\n";
|
|
|
|
if ( $installed->{$package} ) {
|
|
print "Would you like to upgrade $package"
|
|
. " ($installed->{$package}{'version'}"
|
|
. " to $packages->{$package}{'version'})"
|
|
. "? (y/n): ";
|
|
}
|
|
|
|
# if ( $type == -1 ){
|
|
# print "Downgrade $package to $version on $target?"
|
|
# . "(y/n): ";
|
|
# }
|
|
# elsif ( $type == 1 ){
|
|
# print "Upgrade $package to $version on $target?"
|
|
# . "(y/n): ";
|
|
# }
|
|
# else{
|
|
# print "Install $package on $target? (y/n): ";
|
|
# }
|
|
}
|
|
|
|
while( ! $yes ){
|
|
$yes = <STDIN>;
|
|
chomp( $yes );
|
|
|
|
if ( lc( $yes ) eq 'n' ){
|
|
print STDERR "Aborting installation\n";
|
|
|
|
exit 1;
|
|
}
|
|
elsif ( lc( $yes ne 'y' ) ){
|
|
print "Answer 'y' or 'n': ";
|
|
|
|
undef( $yes );
|
|
}
|
|
}
|
|
|
|
print "SIZE: $size\n";
|
|
|
|
exit;
|
|
|
|
if ( ! $target ){
|
|
$target = '/';
|
|
}
|
|
|
|
$manifest .= "$target/var/snap/$infodata->{'info'}{'package'}/manifest";
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
else{
|
|
|
|
############################################
|
|
#
|
|
# Here we use manifest() and snapinfo()
|
|
# to write the manifest and snapinfo
|
|
# files in /var/snap/packagename
|
|
#
|
|
############################################
|
|
|
|
$result = manifest( @ARGV );
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
|
|
$result = snapinfo( @ARGV );
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
}
|
|
|
|
############################################
|
|
#
|
|
# In this section we check to see if
|
|
# $manifest.tmp exists (which means an
|
|
# already installed package is being
|
|
# replaced (reinstall, upgrade, etc).
|
|
# This keeps us from being left with
|
|
# orphaned files.
|
|
#
|
|
############################################
|
|
|
|
if ( -f "$manifest.tmp" ){
|
|
open( TMPMANIFEST, "<$manifest.tmp" ) || die( $! );
|
|
$listdata = list( $package );
|
|
|
|
while ( my $line = <TMPMANIFEST> ){
|
|
my ( $sha256, $perms, $file ) = split( /\s/, $line );
|
|
my $match = 0;
|
|
|
|
foreach my $data ( @{$listdata->{'list'}} ){
|
|
if ( $file eq $data->{'file'} ){
|
|
$match = 1;
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
if ( ! $match ){
|
|
if ( -d "$target/$file"
|
|
&& chkempty( "$target/$file" ) ){
|
|
rmdir( "$target/$file" ) || die( $! );
|
|
}
|
|
elsif ( -f "$target/$file" ){
|
|
unlink( "$target/$file" ) || die( $! );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( TMPMANIFEST );
|
|
unlink( "$manifest.tmp" ) || die( $! );
|
|
}
|
|
|
|
print "Package successfully installed\n\n";
|
|
}
|
|
elsif ( $ARGV[0] eq 'reinstall' ){
|
|
my $result = reinstall( @ARGV );
|
|
my $infodata;
|
|
my $listdata;
|
|
my $manifest;
|
|
my $pkgfile;
|
|
my $target;
|
|
|
|
for ( my $i = $#ARGV; $i >= 0; $i-- ){
|
|
if ( $ARGV[$i] eq '-y' ){
|
|
next;
|
|
}
|
|
elsif ( $ARGV[$i] eq 'reinstall' ){
|
|
next;
|
|
}
|
|
|
|
if ( ! $pkgfile ){
|
|
$pkgfile = $ARGV[$i];
|
|
}
|
|
else{
|
|
$target = $ARGV[$i];
|
|
}
|
|
}
|
|
|
|
$infodata = info( $pkgfile, $target );
|
|
|
|
if ( ! $target ){
|
|
$target = '/';
|
|
}
|
|
|
|
$manifest .= "$target/var/snap/$infodata->{'info'}{'package'}/manifest";
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
else{
|
|
|
|
############################################
|
|
#
|
|
# Here we use manifest() and snapinfo()
|
|
# to write the manifest and snapinfo
|
|
# files in /var/snap/packagename
|
|
#
|
|
############################################
|
|
|
|
$result = manifest( @ARGV );
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
|
|
$result = snapinfo( @ARGV );
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
|
|
############################################
|
|
#
|
|
# In this section we look through the files
|
|
# in the old package and remove them if they
|
|
# aren't in the new package. This
|
|
# functionality should probably be made
|
|
# into a sub at some point.
|
|
#
|
|
############################################
|
|
|
|
open( TMPMANIFEST, "<$manifest.tmp" ) || die( $! );
|
|
$listdata = list( $pkgfile );
|
|
|
|
while ( my $line = <TMPMANIFEST> ){
|
|
my ( $sha256, $perms, $file ) = split( /\s/, $line );
|
|
my $match = 0;
|
|
|
|
foreach my $data ( @{$listdata->{'list'}} ){
|
|
if ( $file eq $data->{'file'} ){
|
|
$match = 1;
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
if ( ! $match ){
|
|
if ( -d "$target/$file"
|
|
&& chkempty( "$target/$file" ) ){
|
|
rmdir( "$target/$file" ) || die( $! );
|
|
}
|
|
elsif ( -f "$target/$file" ){
|
|
unlink( "$target/$file" ) || die( $! );
|
|
}
|
|
}
|
|
}
|
|
|
|
close( TMPMANIFEST );
|
|
unlink( "$manifest.tmp" ) || die( $! );
|
|
|
|
print "Package successfully re-installed\n\n";
|
|
}
|
|
}
|
|
elsif ( $ARGV[0] eq 'refresh' ) {
|
|
foreach my $source ( keys( %{$conf->{'sources'}} ) ) {
|
|
( my $src = "$conf->{'sources'}{$source}" ) =~ s/\/$//;
|
|
my $dest = "/$conf->{'general'}{'snapdir'}/$source-packages.gz";
|
|
my $mode = 0644;
|
|
my $packages;
|
|
|
|
print "Retrieving packages for source '$source'... ";
|
|
|
|
$packages = httpget( "$src/$snapver/packages.gz",
|
|
$dest, $mode );
|
|
|
|
if ( $packages->{'status'} == 200 ) {
|
|
print "Success\n";
|
|
}
|
|
else {
|
|
print "Failed!\nhttpget: $packages->{'stderr'}\n";
|
|
}
|
|
}
|
|
}
|
|
elsif ( $ARGV[0] eq 'remove' ){
|
|
my $result = remove( @ARGV );
|
|
|
|
if ( $result->{'status'} ){
|
|
print STDERR "snap Error: $result->{'stderr'}\n";
|
|
|
|
exit $result->{'status'};
|
|
}
|
|
else{
|
|
print "\nPackage successfully removed\n\n";
|
|
}
|
|
}
|
|
elsif ( $ARGV[0] eq 'repo' ) {
|
|
my $packages = repo();
|
|
|
|
foreach my $package ( sort( keys( %{$packages} ) ) ) {
|
|
print "$package - $packages->{$package}{'description'}\n";
|
|
}
|
|
}
|
|
elsif ( $ARGV[0] eq 'search' ) {
|
|
my $packages = repo();
|
|
|
|
foreach my $package ( sort( keys( %{$packages} ) ) ) {
|
|
if ( index( $package, $ARGV[1] ) != -1 ||
|
|
index( $packages->{$package}{'description'}, $ARGV[1] ) != -1) {
|
|
print "$package - "
|
|
. "$packages->{$package}{'description'}\n";
|
|
}
|
|
}
|
|
}
|
|
else{
|
|
print STDERR "snap Error: $ARGV[0] is not a valid argument\n";
|
|
|
|
exit 1;
|
|
}
|
|
|