Jay Larson
6b62f87bf6
* Cleaned up some output and variable assignments * Added additional error handling/output * Implemented 'source' command (git clones) * More variable requirements for Makefile.snaplinux * Package.pm is now more sane in dealing with the package object * Added chroot/fakechroot (will likely need further tweaking!) * Improved locking * Added ability to use templates for snapinstall (will be expanded!)
988 lines
20 KiB
Perl
988 lines
20 KiB
Perl
package Snap;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Snap::Commands;
|
|
use Snap::Package;
|
|
use Snap::Sources;
|
|
|
|
use Fcntl qw( :flock );
|
|
use IPC::Open3;
|
|
use IO::Socket::INET;
|
|
use Digest::SHA qw( sha256_hex );
|
|
use POSIX;
|
|
use Data::Dumper;
|
|
|
|
use parent 'Exporter';
|
|
our @EXPORT = qw(
|
|
chkyes
|
|
error
|
|
genpkg
|
|
httpget
|
|
human
|
|
list
|
|
listfiles
|
|
virtfs
|
|
readconf
|
|
refresh
|
|
setup
|
|
sha
|
|
sha256
|
|
target
|
|
termsize
|
|
vercmp
|
|
);
|
|
|
|
use constant DEBUG => eval {
|
|
for ( my $i = 0; $i <= $#ARGV; $i++ ) {
|
|
if ( $ARGV[$i] eq '--debug' ) {
|
|
splice( @ARGV, $i, 1 );
|
|
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
return( 0 );
|
|
};
|
|
use constant TARGET => eval {
|
|
my $target = '';
|
|
|
|
for ( my $i = 0; $i <= $#ARGV; $i++ ) {
|
|
if ( $ARGV[$i] eq '-t' ) {
|
|
$target = $ARGV[$i+1];
|
|
|
|
splice( @ARGV, $i, 2 );
|
|
}
|
|
elsif ( $ARGV[$i] =~ /^-t(\S+)/ ) {
|
|
$target = $1;
|
|
|
|
splice( @ARGV, $i, 1 );
|
|
}
|
|
}
|
|
|
|
$target =~ s/(\/+){2}/\//g;
|
|
$target =~ s/\/$//;
|
|
|
|
return( $target );
|
|
};
|
|
use constant CONFFILE => eval {
|
|
if ( -f TARGET . '/etc/snap.conf' ) {
|
|
return( TARGET . '/etc/snap.conf' );
|
|
}
|
|
elsif ( -f '/etc/snap.conf' ) {
|
|
return( '/etc/snap.conf' );
|
|
}
|
|
else {
|
|
Snap->error( -1, 'No valid snap.conf found' );
|
|
}
|
|
};
|
|
use constant VERFILE => eval {
|
|
if ( -f TARGET . '/etc/snap_version' ) {
|
|
return( TARGET . '/etc/snap_version' );
|
|
}
|
|
elsif ( -f '/etc/snap_version' ) {
|
|
return( '/etc/snap_version' );
|
|
}
|
|
else {
|
|
Snap->error( -1, 'No valid snap_version found' );
|
|
}
|
|
};
|
|
use constant {
|
|
VERSION => '0.12',
|
|
SNAPDIR => TARGET . '/var/lib/snap',
|
|
PKGDIR => TARGET . '/var/lib/snap/packages',
|
|
INSTDIR => TARGET . '/var/lib/snap/installed',
|
|
SRCDIR => TARGET . '/var/lib/snap/sources'
|
|
};
|
|
use constant SNAPVER => eval {
|
|
my $version;
|
|
|
|
open( FILE, VERFILE ) || Snap->error( int( $! ), "open(): $!" );
|
|
$version = <FILE>;
|
|
close( FILE ) || Snap->error( int( $! ), "open(): $!" );
|
|
chomp( $version );
|
|
|
|
return( $version );
|
|
};
|
|
use constant LOCKFILE => TARGET . '/.snap';
|
|
|
|
############################################################
|
|
#
|
|
# Set the process name
|
|
#
|
|
############################################################
|
|
|
|
$0 =~ s/.*\///;
|
|
|
|
############################################################
|
|
#
|
|
# Make sure we bring back the cursor if we're killed
|
|
#
|
|
############################################################
|
|
|
|
$SIG{INT} = sub{
|
|
if ( TARGET ) {
|
|
virtfs( 'umount' );
|
|
}
|
|
|
|
print "\e[?25h\n";
|
|
|
|
exit( -1 );
|
|
};
|
|
|
|
############################################################
|
|
#
|
|
# Export TARGET to the environment for usher
|
|
#
|
|
############################################################
|
|
|
|
$ENV{TARGET} = TARGET;
|
|
|
|
sub chkreq {
|
|
my $class = shift;
|
|
my $req = shift;
|
|
my $version = shift;
|
|
|
|
if ( $req eq $version ) {
|
|
return( 1 );
|
|
}
|
|
elsif ( $req && $req =~ /^((<|>)=?|=)\s*(.*)/ ) {
|
|
my $op = $1;
|
|
my $ver = $3;
|
|
my $chk = Snap->vercmp( $version, $ver );
|
|
|
|
if ( $op &&
|
|
( $op eq '<' && $chk == -1 ) ||
|
|
( $op eq '<=' && $chk <= 0 ) ||
|
|
( $op eq '>' && $chk == 1 ) ||
|
|
( $op eq '>=' && $chk >= 0 ) ||
|
|
( $op eq '=' && $chk == 0 ) ) {
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
return( 0 );
|
|
}
|
|
|
|
sub chkyes {
|
|
my $yes = '';
|
|
|
|
while( ! $yes ){
|
|
$yes = <STDIN>;
|
|
chomp( $yes );
|
|
|
|
if ( lc( $yes ) eq 'n' ){
|
|
print STDERR "\nAborting!\n";
|
|
|
|
exit( 1 );
|
|
}
|
|
elsif ( lc( $yes ne 'y' ) ){
|
|
print "Answer 'y' or 'n': ";
|
|
|
|
undef( $yes );
|
|
}
|
|
}
|
|
}
|
|
|
|
### error() ################################################
|
|
#
|
|
# All errors should be sent here. This sub takes a status
|
|
# and error string as args. The status code is used as
|
|
# the exit code. This also iterates through the call stack
|
|
# which is dumped to STDERR
|
|
#
|
|
############################################################
|
|
|
|
sub error {
|
|
my $class = shift;
|
|
my $status = shift;
|
|
my $errstr = shift;
|
|
my $level = 1;
|
|
my @stack = ();
|
|
|
|
chomp( $errstr );
|
|
|
|
print "\e[?25h\n";
|
|
|
|
print STDERR ( caller() )[1] .":\n $errstr at line "
|
|
. ( caller() )[2] . "\n";
|
|
|
|
if ( DEBUG ) {
|
|
if ( caller( $level ) ) {
|
|
print "\n=== Stack Trace ===\n";
|
|
}
|
|
|
|
while ( my @trace = caller( $level++ ) ) {
|
|
print STDERR " $trace[1]:\n"
|
|
. " $trace[3]() called at line $trace[2]\n";
|
|
}
|
|
}
|
|
|
|
print "\n";
|
|
|
|
if ( $status ) {
|
|
virtfs( 'umount' );
|
|
|
|
exit( $status );
|
|
}
|
|
}
|
|
|
|
### genpkg () ##############################################
|
|
#
|
|
# This sub generates a skeleton of directories and files
|
|
# that can be used as a starting point for creating a
|
|
# package.
|
|
#
|
|
############################################################
|
|
|
|
sub genpkg{
|
|
my $pkgname = shift;
|
|
my $skelfile = '/usr/share/snap/Makefile.skel';
|
|
my $snapreadme = "This is the directory where the manifest, snapinfo,\n"
|
|
. "and files.tar.gz files will be created. It is also\n"
|
|
. "where the usher file should be placed if it is\n"
|
|
. "required by the package. Any other files that need\n"
|
|
. "to be included could also be placed here.\n";
|
|
my $patchreadme = "Place any patch files here and preface each with a\n"
|
|
. "number indicating the order of execution. Patch\n"
|
|
. "files are expected to use a .patch extension.\n";
|
|
|
|
mkdir( $pkgname, 0755 ) ||
|
|
Snap->error( int( $! ), "mkdir: $pkgname: $!" );
|
|
mkdir( "$pkgname/SNAP", 0755 ) || Snap->error( int( $! ), $! );
|
|
mkdir( "$pkgname/SRC", 0755 ) || Snap->error( int( $! ), $! );
|
|
mkdir( "$pkgname/SRC/patches", 0755 ) || Snap->error( int( $! ), $! );
|
|
|
|
open( SKEL, "<$skelfile" ) || Snap->error( int( $! ), $! );
|
|
open( MAKEFILE, ">$pkgname/Makefile" ) || Snap->error( int( $! ), $! );
|
|
|
|
while ( <SKEL> ) {
|
|
print MAKEFILE $_;
|
|
}
|
|
|
|
close( MAKEFILE );
|
|
close( SKEL );
|
|
|
|
open( README, ">$pkgname/SNAP/README" ) || Snap->error( int( $! ), $! );
|
|
print README $snapreadme;
|
|
close( README );
|
|
|
|
open( README, ">$pkgname/SRC/patches/README" )
|
|
|| Snap->error( int( $! ), $! );
|
|
print README $patchreadme;
|
|
close( README );
|
|
}
|
|
|
|
sub httpget {
|
|
my $class = shift;
|
|
my $url = shift;
|
|
my $dest = shift;
|
|
my $mode = shift;
|
|
( my $host = $url ) =~ s/^https?:\/\/|\/.*//g;
|
|
( my $file = $url ) =~ s/.*$host//;
|
|
( my $filename = $url ) =~ s/.*\///;
|
|
my %httpget = (
|
|
'status' => 0,
|
|
'stdout' => '',
|
|
'stderr' => '',
|
|
'length' => 0,
|
|
'type' => '',
|
|
'dflag' => 0,
|
|
'pct' => 0
|
|
);
|
|
my $sock = IO::Socket::INET->new(
|
|
PeerAddr => $host,
|
|
PeerPort => 'http(80)',
|
|
Proto => 'tcp'
|
|
) || Snap->error( int( $! ), "IO::Socket::Inet->new(): $!" );
|
|
my $bytes = 0;
|
|
my @wheel = qw( - \ | / );
|
|
my $p = 0;
|
|
|
|
local $| = 1;
|
|
|
|
$sock->send( "GET $file HTTP/1.0\r\n" );
|
|
$sock->send( "Host: $host\r\n" );
|
|
$sock->send( "\r\n" );
|
|
|
|
if ( ! $mode ) {
|
|
$mode = '0644';
|
|
}
|
|
|
|
if ( $dest ) {
|
|
sysopen( DEST, $dest, O_RDWR|O_TRUNC|O_CREAT, $mode ) ||
|
|
Snap->error( int( $! ), "sysopen(): $dest: $!" );
|
|
|
|
print "\e[?25l";
|
|
}
|
|
|
|
while ( <$sock> ) {
|
|
if ( $dest ) {
|
|
$bytes += length( $_ );
|
|
}
|
|
|
|
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'}++;
|
|
}
|
|
}
|
|
elsif ( $dest ) {
|
|
print DEST $_;
|
|
}
|
|
else {
|
|
$httpget{'stdout'} .= $_;
|
|
}
|
|
|
|
if ( $dest && $httpget{'length'} &&
|
|
$bytes < $httpget{'length'} ) {
|
|
if ( $bytes ) {
|
|
$httpget{'pct'} = int( $bytes /
|
|
$httpget{'length'} * 100 );
|
|
}
|
|
|
|
printf( "%-50.50s [%-20s] %s\r",
|
|
" $wheel[$p] Downloading $filename",
|
|
'*' x int( $httpget{'pct'} / 5 ),
|
|
"$httpget{'pct'}%" );
|
|
|
|
if ( $p >= $#wheel ) {
|
|
$p = 0;
|
|
}
|
|
else {
|
|
$p++;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( $dest ) {
|
|
printf( "%-50.50s [%-20s] %s\e[?25h\n",
|
|
" * Downloaded $filename",
|
|
'*' x 20,
|
|
'100%' );
|
|
|
|
close( DEST );
|
|
}
|
|
|
|
close( $sock );
|
|
chomp( $httpget{'stdout'} );
|
|
|
|
return( $httpget{'stdout'} );
|
|
}
|
|
|
|
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 ismountpoint {
|
|
my $dir = shift;
|
|
my $statA;
|
|
my $statB;
|
|
|
|
if ( ! -d $dir ) {
|
|
return( 0 );
|
|
}
|
|
|
|
$statA = ( stat( $dir ) )[0];
|
|
$statB = ( stat( "$dir/.." ) )[0];
|
|
|
|
if ( $statA == $statB ) {
|
|
return( 0 );
|
|
}
|
|
else {
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
sub issnap {
|
|
my $class = shift;
|
|
my $file = shift;
|
|
my $lines = 0;
|
|
my $snapinfo = 0;
|
|
my $name = 0;
|
|
my $version = 0;
|
|
my $issnap = 0;
|
|
|
|
open( FILE, "<$file" ) || Snap->error( -1, "open(): $file: $!" );
|
|
|
|
while ( <FILE> ) {
|
|
if ( substr( $_, 0, 9 ) eq 'snapinfo/' ) {
|
|
$snapinfo++;
|
|
}
|
|
elsif ( substr( $_, 0, 5 ) eq 'name:' ) {
|
|
$name++;
|
|
}
|
|
elsif ( substr( $_, 0, 8 ) eq 'version:' ) {
|
|
$version++;
|
|
}
|
|
|
|
$lines++;
|
|
|
|
if ( $lines >= 12 ) {
|
|
last;
|
|
}
|
|
}
|
|
|
|
close( FILE ) || Snap->error( -1, "close(): $file: $!" );
|
|
|
|
if ( $snapinfo && $name && $version ) {
|
|
return( 1 );
|
|
}
|
|
|
|
return( 0 );
|
|
}
|
|
|
|
sub list {
|
|
my $listpackages = shift;
|
|
my $packages = {};
|
|
my $package = {};
|
|
|
|
opendir( DIR, INSTDIR ) || Snap->error( -1, "opendir(): "
|
|
. INSTDIR . ": $!" );
|
|
|
|
foreach my $dir ( sort { $a cmp $b } readdir( DIR ) ) {
|
|
if ( $dir =~ /^\.{1,2}$/ || ! -f INSTDIR . "/$dir/snapinfo" ||
|
|
$listpackages->[0] && ! grep( $dir =~ /$_/, @$listpackages ) ) {
|
|
next;
|
|
}
|
|
|
|
open( SNAPINFO, "<", INSTDIR . "/$dir/snapinfo" )
|
|
|| Snap->error( int( $! ), "open: $!" );
|
|
|
|
while ( <SNAPINFO> ) {
|
|
####################################
|
|
#
|
|
# Temporary fix!!! Will need to
|
|
# remove after all packages are
|
|
# corrected...
|
|
#
|
|
####################################
|
|
|
|
$_ =~ s/^package:/name:/;
|
|
|
|
if ( $_ =~ /^(\S+):\s+(.*)$/ ) {
|
|
$package->{$1} = $2;
|
|
}
|
|
}
|
|
|
|
$packages->{$dir} = Snap::Package->new( $package );
|
|
|
|
close( SNAPINFO );
|
|
}
|
|
|
|
close( DIR );
|
|
|
|
return( $packages );
|
|
}
|
|
|
|
sub listfiles {
|
|
my $packages = list();
|
|
my $listfiles = {};
|
|
|
|
foreach my $package ( @{$packages} ) {
|
|
my $manifest = Snap->INSTDIR
|
|
. "/$package->{'name'}/manifest";
|
|
|
|
open( MANIFEST, "<$manifest" ) ||
|
|
Snap->error( int( $! ), "open(): $manifest: $!" );
|
|
|
|
while ( <MANIFEST> ) {
|
|
my ( $shasum, $perms, $file ) = split( /\s/, $_ );
|
|
$listfiles->{$file}{'name'} = $package;
|
|
$listfiles->{$file}{'shasum'} = $shasum;
|
|
$listfiles->{$file}{'perms'} = $perms;
|
|
}
|
|
|
|
close( MANIFEST ) ||
|
|
Snap->error( int( $! ), "open(): $manifest: $!" );
|
|
}
|
|
|
|
return( $listfiles );
|
|
}
|
|
|
|
sub lock {
|
|
open( LOCK, '>', LOCKFILE ) || Snap->error( int( $! ), "open(): "
|
|
. LOCKFILE . ": Unable to open lock file" );
|
|
flock( LOCK, LOCK_EX|LOCK_NB ) || Snap->error( int( $! ), "flock(): "
|
|
. LOCKFILE . ": Unable to lock file" );
|
|
}
|
|
|
|
sub mkdirp{
|
|
( my $dir = shift ) =~ s/\/^//;
|
|
my $mode = shift;
|
|
( my $parent = $dir ) =~ s/\/[^\/]+$//;
|
|
|
|
if ( -d $dir ){
|
|
return;
|
|
}
|
|
|
|
mkdirp( $parent, $mode );
|
|
|
|
mkdir( $dir, $mode ) || Snap->error( int( $! ), "mkdir(): $dir: $!" );
|
|
}
|
|
|
|
### readconf() #############################################
|
|
#
|
|
# reads INI style files and builds a data structure with the
|
|
# parsed values.
|
|
#
|
|
# The config file can 'include' additional directories.
|
|
# Files in these directories will be parsed and added to
|
|
# the the data structure.
|
|
#
|
|
# Files ending in .conf will be parsed into the root of the
|
|
# data structure while .spt (snap package template) files
|
|
# will be stored in 'templates'
|
|
#
|
|
############################################################
|
|
|
|
sub readconf {
|
|
my $conffile = shift || CONFFILE;
|
|
my $data = shift || {};
|
|
my $section = '';
|
|
my $line = 0;
|
|
my $type;
|
|
|
|
if ( $conffile =~ /\.spt$/ ) {
|
|
$type = 'template';
|
|
}
|
|
elsif ( $conffile =~ /\.conf$/ ) {
|
|
$type = 'config';
|
|
}
|
|
|
|
open( my $fh, "<", $conffile ) || Snap->error( int( $! ),
|
|
"open(): $conffile: $!\n" );
|
|
|
|
while ( <$fh> ) {
|
|
chomp( $_ );
|
|
|
|
if ( $_ =~ /^\s*#/ || $_ =~ /^$/ ) {
|
|
next;
|
|
}
|
|
elsif ( $_ =~ /\s*include\s+(.*)$/ ) {
|
|
foreach my $dir ( split( ' ', $1 ) ) {
|
|
opendir( my $dh, $dir ) ||
|
|
Snap->error( int( $! ),
|
|
"opendir(): $dir: $!" );
|
|
|
|
while ( my $file = readdir( $dh ) ) {
|
|
if ( -f "$dir/$file" ) {
|
|
readconf( "$dir/$file", $data );
|
|
}
|
|
}
|
|
|
|
closedir( $dh ) || Snap->error( int( $! ),
|
|
"closedir(): $dir: $!" );
|
|
}
|
|
}
|
|
elsif ( $_ =~ /\s*\[(\S+)\]\s*/ ) {
|
|
$section = $1;
|
|
|
|
if ( $section eq 'sources' ) {
|
|
$data->{$section} = [];
|
|
}
|
|
}
|
|
elsif ( $section eq 'sources' ) {
|
|
push( @{$data->{$section}}, $_ );
|
|
}
|
|
elsif ( $section && $type eq 'template' ) {
|
|
if ( ! $data->{'templates'}{$section} ) {
|
|
$data->{'templates'}{$section} = [];
|
|
}
|
|
|
|
push( @{$data->{'templates'}{$section}}, $_ );
|
|
}
|
|
elsif ( $_ =~ /(\S+)\s*=\s*(.*)$/ ) {
|
|
$data->{$section}{$1} = $2;
|
|
}
|
|
}
|
|
|
|
close( $fh );
|
|
|
|
return( $data );
|
|
}
|
|
|
|
### setup() ################################################
|
|
#
|
|
# This should be called if any of the expected environment
|
|
# is found not to be present. This includes the directories
|
|
# in /var/lib/snap, /etc/snap.conf, and /etc/snap_version
|
|
#
|
|
############################################################
|
|
|
|
sub setup {
|
|
my $chkfails = 0;
|
|
my $target = 0;
|
|
my $snapdir = 0;
|
|
my $pkgdir = 0;
|
|
my $instdir = 0;
|
|
my $srcdir = 0;
|
|
my $yes = '';
|
|
|
|
if ( TARGET && ! -e TARGET ) {
|
|
$target++;
|
|
$chkfails++;
|
|
}
|
|
if ( ! -e SNAPDIR ) {
|
|
$snapdir++;
|
|
$chkfails++;
|
|
}
|
|
if ( ! -e PKGDIR ) {
|
|
$pkgdir++;
|
|
$chkfails++;
|
|
}
|
|
if ( ! -e INSTDIR ) {
|
|
$instdir++;
|
|
$chkfails++;
|
|
}
|
|
if ( ! -e SRCDIR ) {
|
|
$srcdir++;
|
|
$chkfails++;
|
|
}
|
|
|
|
if ( $target ) {
|
|
mkdir( TARGET, 0755 ) || Snap->error( int( $! ), "mkdir: $!" );
|
|
}
|
|
if ( $snapdir ) {
|
|
mkdirp( SNAPDIR, 0755 );
|
|
}
|
|
if ( $pkgdir ) {
|
|
mkdir( PKGDIR, 0755 ) || Snap->error( int( $! ),
|
|
"mkdir(): " . PKGDIR . ": $!" );
|
|
}
|
|
if ( $instdir ) {
|
|
mkdir( INSTDIR, 0755 ) || Snap->error( int( $! ),
|
|
"mkdir(): " . INSTDIR . ": $!" );
|
|
}
|
|
if ( $srcdir ) {
|
|
my $conf = readconf();
|
|
my $sources = Snap::Sources->new( $conf->{'sources'} );
|
|
|
|
mkdir( SRCDIR, 0755 ) || Snap->error( int( $! ),
|
|
"mkdir(): " . SRCDIR . ": $!" );
|
|
|
|
$sources->refresh();
|
|
}
|
|
}
|
|
|
|
sub sha {
|
|
my $file = shift;
|
|
my $digest = eval {
|
|
Digest::SHA->new( 1 )->addfile( $file );
|
|
} || Snap->error( -1, "sha(): $file: $!\n" );
|
|
|
|
return( $digest->hexdigest );
|
|
}
|
|
|
|
### sha256() ###############################################
|
|
#
|
|
# This sub returns a hex sha256 hash of a supplied file
|
|
#
|
|
############################################################
|
|
|
|
sub sha256 {
|
|
my $class = shift;
|
|
my $file = shift;
|
|
my $digest = eval {
|
|
Digest::SHA->new( 256 )->addfile( $file );
|
|
} || Snap->error( -1, "sha256(): $file: $!\n" );
|
|
|
|
return( $digest->hexdigest );
|
|
}
|
|
|
|
sub termsize {
|
|
my $row = 24;
|
|
my $col = 80;
|
|
my $sel = IO::Select->new();
|
|
my $stdout;
|
|
my $stderr;
|
|
my $stat;
|
|
my $pid;
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"stty size -F /dev/tty" );
|
|
} || return( { row => $row, col => $col } );
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
$stdout .= <$fh>;
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stdout =~ /(\d+)\s+(\d+)/ ) {
|
|
$row = $1;
|
|
$col = $2;
|
|
}
|
|
|
|
return( { row => $row, col => $col } );
|
|
}
|
|
|
|
sub unlock {
|
|
if ( -f LOCKFILE ) {
|
|
unlink( LOCKFILE ) || Snap->error( int( $! ), "unlink(): "
|
|
. LOCKFILE . ": Unable to remove lock file" );
|
|
}
|
|
}
|
|
|
|
### 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 and license
|
|
# information 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.
|
|
#
|
|
# Return values:
|
|
#
|
|
# -1: A < B
|
|
# 0: match
|
|
# 1: A > B
|
|
#
|
|
############################################################
|
|
|
|
sub vercmp {
|
|
my $class = shift;
|
|
|
|
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;
|
|
}
|
|
|
|
### virtfs() ###############################################
|
|
#
|
|
# Need to try and figure out a solution for user installs
|
|
#
|
|
# The user may not be able to mount the virt filesystems,
|
|
# so perhaps it could do some kind of linking instead?
|
|
#
|
|
# Also remember you might want to move chroot out of usher
|
|
# and into here! We could also try to do fakechroot as well
|
|
#
|
|
############################################################
|
|
|
|
sub virtfs {
|
|
my $command = shift;
|
|
my $virtfs = {
|
|
dev => {
|
|
fs => 'devtmpfs',
|
|
dev => 'none',
|
|
dir => TARGET . '/dev'
|
|
},
|
|
proc => {
|
|
fs => 'proc',
|
|
dev => 'none',
|
|
dir => TARGET . '/proc'
|
|
},
|
|
sys => {
|
|
fs => 'sysfs',
|
|
dev => 'none',
|
|
dir => TARGET .'/sys'
|
|
}
|
|
};
|
|
|
|
if ( $> || ! TARGET ) {
|
|
return;
|
|
}
|
|
|
|
foreach my $fs ( sort( keys( %$virtfs ) ) ) {
|
|
my $sel;
|
|
my $cmd;
|
|
my $stdout = '';
|
|
my $stderr = '';
|
|
my $stat = 0;
|
|
my $pid;
|
|
|
|
|
|
if ( ! -d $virtfs->{$fs}{'dir'} ) {
|
|
next;
|
|
}
|
|
|
|
if ( $command eq 'mount' ) {
|
|
if ( ismountpoint( $virtfs->{$fs}{'dir'} ) ) {
|
|
next;
|
|
}
|
|
|
|
$cmd = "mount -t $virtfs->{$fs}{'fs'}"
|
|
. " $virtfs->{$fs}{'dev'}"
|
|
. " $virtfs->{$fs}{'dir'}";
|
|
}
|
|
elsif ( $command eq 'umount' ) {
|
|
if ( ! ismountpoint( $virtfs->{$fs}{'dir'} ) ) {
|
|
next;
|
|
}
|
|
|
|
$cmd = "umount $virtfs->{$fs}{'dir'}";
|
|
}
|
|
else {
|
|
Snap->error( -1, "virtfs(): $command:"
|
|
. " not a valid command" );
|
|
}
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR, $cmd );
|
|
} || Snap->error( int( $! ), "open3(): $cmd: $!" );
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
$stdout .= <$fh>;
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
Snap->error( $stat, "Failed $command for"
|
|
. " $virtfs->{$fs}{'dir'}: $stderr" );
|
|
}
|
|
}
|
|
|
|
foreach my $fs ( sort( keys( %$virtfs ) ) ) {
|
|
if ( ! ismountpoint( $virtfs->{$fs}{'dir'} ) ) {
|
|
return( 0 );
|
|
}
|
|
}
|
|
|
|
return( 1 );
|
|
}
|
|
|
|
1;
|