First check in after re-naming snap to sl. This involved a lot of variable renaming and there are likely a number of other little hacks and tweaks.
This commit is contained in:
1388
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL.pm
Normal file
1388
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL.pm
Normal file
File diff suppressed because it is too large
Load Diff
159
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Commands.pm
Normal file
159
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Commands.pm
Normal file
@@ -0,0 +1,159 @@
|
||||
package SL::Commands;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use parent 'SL';
|
||||
|
||||
sub new {
|
||||
my( $class, $commands ) = @_;
|
||||
|
||||
return( bless( $commands, $class ) );
|
||||
}
|
||||
|
||||
sub commandhelp {
|
||||
my $self = shift;
|
||||
my $command = shift;
|
||||
my $optcount = 0;
|
||||
|
||||
if ( ! $self->{$command} ) {
|
||||
SL->error( 2, "help(): Invalid command '$command'" );
|
||||
}
|
||||
|
||||
my $options = $self->{$command}{'options'};
|
||||
my $help = $self->{$command}{'help'};
|
||||
|
||||
print "$0 $command";
|
||||
|
||||
foreach ( @{$self->{$command}{'options'}} ) {
|
||||
if ( $_ =~ /^(<|\[[A-Z])/ ) {
|
||||
print " $_";
|
||||
}
|
||||
elsif ( substr( $_, 0, 1 ) eq '[' ) {
|
||||
$optcount++;
|
||||
}
|
||||
}
|
||||
|
||||
if ( $optcount ) {
|
||||
print ' [OPTIONS]';
|
||||
}
|
||||
|
||||
print "\n\n$self->{$command}{'brief'}\n";
|
||||
|
||||
for ( my $i = 0; $i <= $#{$options}; $i++ ) {
|
||||
my $charcnt = 0;
|
||||
printf( "\n %-32s", $options->[$i] );
|
||||
|
||||
foreach ( split( ' ', $help->[$i] ) ) {
|
||||
$charcnt += length( $_ ) + 1;
|
||||
|
||||
if ( $charcnt >= 34 ) {
|
||||
$charcnt = 0;
|
||||
|
||||
print "\n" . ( ' ' x 34 ) . "$_ ";
|
||||
}
|
||||
else {
|
||||
print "$_ ";
|
||||
}
|
||||
}
|
||||
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub help {
|
||||
my ( $self, $opts ) = @_;
|
||||
my $cnt = 0;
|
||||
|
||||
print "Usage: $0 <COMMAND> <ARGS>\n\n"
|
||||
. "sl is the Snaplinux package management utility\n\n"
|
||||
. "COMMANDS\n\n";
|
||||
|
||||
if ( $opts->{'all'} ) {
|
||||
foreach my $command ( sort( keys( %$self ) ) ) {
|
||||
if ( $cnt ) {
|
||||
print "\n";
|
||||
}
|
||||
|
||||
$self->commandhelp( $command );
|
||||
|
||||
$cnt++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
foreach my $command ( sort( keys( %$self ) ) ) {
|
||||
print " $command \t\t\t$self->{$command}{'brief'}\n"
|
||||
}
|
||||
}
|
||||
|
||||
print "\nTo view more information for commands run:\n"
|
||||
. "sl <COMMAND> -h|--help\n";
|
||||
}
|
||||
|
||||
sub parseopts {
|
||||
my ( $self, $command ) = @_;
|
||||
my $opts = {};
|
||||
|
||||
if ( ! $command ) {
|
||||
SL->error( 0, "parseopts(): Missing COMMAND" );
|
||||
$self->help();
|
||||
exit( 2 );
|
||||
}
|
||||
elsif ( ! $self->{$command} ) {
|
||||
SL->error( 0, "parseopts(): '$command': Invalid COMMAND" );
|
||||
$self->help();
|
||||
exit( 2 );
|
||||
}
|
||||
|
||||
foreach ( my $i = $#ARGV; $i >= 0; $i-- ) {
|
||||
if ( $ARGV[$i] =~ /^\-([a-z]{2,})/ ) {
|
||||
my @chars = split( '', $1 );
|
||||
|
||||
splice( @ARGV, $i, 1 );
|
||||
|
||||
foreach ( @chars ) {
|
||||
push( @ARGV, "-$_" );
|
||||
|
||||
$i = $#ARGV;
|
||||
}
|
||||
}
|
||||
|
||||
if ( substr( $ARGV[$i], 0, 1 ) eq '-' &&
|
||||
! grep( $_ =~ /(\[$ARGV[$i],|\[\-[a-z],$ARGV[$i]( |\]))/,
|
||||
@{$self->{$command}{'options'}} ) ) {
|
||||
SL->error( 2, "$ARGV[$i]: invalid argument" );
|
||||
}
|
||||
}
|
||||
|
||||
foreach ( @{$self->{$command}{'options'}} ) {
|
||||
my( $short, $long, $arg2 ) = '';
|
||||
my $tmpopts = {};
|
||||
|
||||
if ( $_ =~ /^\[(\-[a-z]),(\-\-([a-z]+))( (\S+)\]|\])/ ) {
|
||||
$short = $1 || SL->error( 1, "Malformed short arg"
|
||||
. " definition" );
|
||||
$long = $2 || SL->error( 1, "Malformed long arg"
|
||||
. " definition" );
|
||||
$arg2 = $5 || '';
|
||||
|
||||
$tmpopts = SL->pullarg( {
|
||||
short => $short,
|
||||
long => $long,
|
||||
arg2 => $arg2
|
||||
} );
|
||||
|
||||
if ( ref( $tmpopts ) ) {
|
||||
foreach my $key ( %$tmpopts ) {
|
||||
$opts->{$key} = $tmpopts->{$key};
|
||||
}
|
||||
}
|
||||
else {
|
||||
$opts->{$3} = $tmpopts;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return( $opts );
|
||||
}
|
||||
|
||||
1;
|
||||
2039
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Package.pm
Normal file
2039
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Package.pm
Normal file
File diff suppressed because it is too large
Load Diff
382
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Sources.pm
Normal file
382
ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Sources.pm
Normal file
@@ -0,0 +1,382 @@
|
||||
package SL::Sources;
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Compress::Zlib;
|
||||
|
||||
use parent 'SL';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $srcconf = shift;
|
||||
my $sources = {};
|
||||
|
||||
foreach my $source ( @$srcconf ) {
|
||||
if ( $source =~ /^(\S+)\s*=\s*(\S+?)\/*\s+(\S.*)$/ ) {
|
||||
$sources->{'config'}{$1}{'url'} = "$2/"
|
||||
. $SL::sl->{'slver'};
|
||||
$sources->{'config'}{$1}{'order'} =
|
||||
keys( %{$sources->{'config'}} );
|
||||
|
||||
foreach ( split( /\s+/, $3 ) ) {
|
||||
$sources->{'config'}{$1}{'repos'}{$_} = {};
|
||||
}
|
||||
}
|
||||
else {
|
||||
SL->error( int( $! ), "SL::Sources->new():"
|
||||
. " Invalid source format: $source" );
|
||||
}
|
||||
}
|
||||
|
||||
return( bless( $sources, $class ) );
|
||||
}
|
||||
|
||||
### latest() ###############################################
|
||||
#
|
||||
# This *should* be a pretty much guaranteed method of
|
||||
# retrieving the latest version of a package
|
||||
#
|
||||
############################################################
|
||||
|
||||
sub latest {
|
||||
my ( $self, $pkgname ) = @_;
|
||||
my $package;
|
||||
|
||||
foreach ( sort { SL->vercmp( $a->{'version'},
|
||||
$b->{'version'} ) } @{$self->{'pkgs'}{$pkgname}} ) {
|
||||
$package = $_;
|
||||
}
|
||||
|
||||
return( $package );
|
||||
}
|
||||
|
||||
sub readpkgs {
|
||||
my $self = shift;
|
||||
$self->{'status'} = {};
|
||||
|
||||
opendir( DIR, $SL::sl->{'statdir'} ) ||
|
||||
SL->error( 1, "opendir(): $SL::sl->{'statdir'}: $!" );
|
||||
|
||||
foreach my $pkgname ( readdir( DIR ) ) {
|
||||
my $slinfo = "$SL::sl->{'statdir'}/$pkgname/slinfo";
|
||||
my $package;
|
||||
|
||||
if ( $pkgname =~ /^\.{1,2}$/ || ! -f $slinfo ) {
|
||||
next;
|
||||
}
|
||||
|
||||
$package = SL::Package->new( $pkgname );
|
||||
|
||||
$self->{'status'}{$pkgname} = $package;
|
||||
}
|
||||
|
||||
close( DIR );
|
||||
|
||||
foreach my $source ( sort { $self->{'config'}{$a}{'order'} <=>
|
||||
$self->{'config'}{$b}{'order'} } ( keys( %{$self->{'config'}} ) ) ) {
|
||||
my $repos = $self->{'config'}{$source}{'repos'};
|
||||
|
||||
foreach my $repo ( keys( %$repos ) ) {
|
||||
my $repopath = "$self->{'config'}{$source}{'url'}"
|
||||
. "/$repo";
|
||||
my $file = "$SL::sl->{'srcdir'}/$source/"
|
||||
. "$repo-packages.gz";
|
||||
my $gz = gzopen( $file, 'r' ) ||
|
||||
SL->error( int( $! ), "gzopen: $file: $!" );
|
||||
my $buff;
|
||||
my $pkg = {};
|
||||
|
||||
while ( $gz->gzreadline( $buff ) ) {
|
||||
if ( $pkg->{'name'} &&
|
||||
! $self->{'pkgs'}{$pkg->{'name'}} ) {
|
||||
$self->{'pkgs'}{$pkg->{'name'}} = [];
|
||||
}
|
||||
|
||||
if ( $buff =~ /^name:\s*(.*)$/ ) {
|
||||
$pkg = {};
|
||||
$pkg->{'name'} = $1;
|
||||
}
|
||||
elsif ( $buff =~ /^(\S+):\s+(.*)$/ ) {
|
||||
$pkg->{$1} = $2;
|
||||
}
|
||||
elsif ( $buff =~ /^$/ && $pkg->{'name'} ) {
|
||||
$pkg->{'source'} = $source;
|
||||
$pkg->{'path'} = $repopath
|
||||
. "/$pkg->{'path'}";
|
||||
|
||||
push( @{$self->{'pkgs'}{$pkg->{'name'}}}
|
||||
,SL::Package->new( $pkg ) );
|
||||
|
||||
$pkg = {};
|
||||
}
|
||||
elsif ( $buff =~ /^$/ ) {
|
||||
next;
|
||||
}
|
||||
else {
|
||||
SL->error( -1, "readpkgs():"
|
||||
. "$file: malformed package"
|
||||
. " list" );
|
||||
}
|
||||
}
|
||||
|
||||
$gz->gzclose();
|
||||
}
|
||||
}
|
||||
|
||||
return( 1 );
|
||||
}
|
||||
|
||||
sub refresh {
|
||||
my $self = shift;
|
||||
my $cnt;
|
||||
|
||||
foreach my $srcname ( sort { $self->{'config'}{$a}{'order'} <=>
|
||||
$self->{'config'}{$b}{'order'} }( keys( %{$self->{'config'}} ) ) ) {
|
||||
my $source = $self->{'config'}{$srcname};
|
||||
my $srcdir = "$SL::sl->{'srcdir'}/$srcname";
|
||||
|
||||
if ( ! -d $srcdir ) {
|
||||
mkdir( $srcdir, 0755 ) || SL->error( int( $! ),
|
||||
"mkdir(): $srcdir: $!" );
|
||||
}
|
||||
|
||||
if ( $cnt ) {
|
||||
print "\n";
|
||||
}
|
||||
|
||||
print "Refreshing $srcname\n\n";
|
||||
|
||||
foreach my $repo ( sort( keys( %{$source->{'repos'}} ) ) ) {
|
||||
my $remotepkgs = "$source->{'url'}/"
|
||||
. "/$repo-packages.gz";
|
||||
my $remotesha256 = "$source->{'url'}/"
|
||||
. "/$repo-packages.gz.sha256";
|
||||
my $localpkgs = "$srcdir/$repo-packages.gz";
|
||||
my $shaget = SL->httpget( $remotesha256, 0, 0644 );
|
||||
|
||||
SL->httpget( $remotepkgs, $localpkgs, 0644 );
|
||||
|
||||
if ( SL->sha256( $localpkgs ) ne $shaget ) {
|
||||
SL->error( -1, "sha256(): incorrect SHA256"
|
||||
. " calculated for $localpkgs!" );
|
||||
}
|
||||
}
|
||||
|
||||
$cnt++;
|
||||
}
|
||||
}
|
||||
|
||||
### search() ###############################################
|
||||
#
|
||||
# This searches the packages from all sources and returns
|
||||
# an array reference with all matching packages. Should
|
||||
# be generally accepting of regex type stuff
|
||||
#
|
||||
# It seems to me to be a bit kludgy, I'd like to make it
|
||||
# more elegant, but it works for now...
|
||||
#
|
||||
# If $opts->{'all'} isn't set (as in with arg -a/--all) and
|
||||
# there is an exact match with a package name in the search
|
||||
# string the most recent version of the package is returned.
|
||||
#
|
||||
############################################################
|
||||
|
||||
sub search {
|
||||
my $self = shift;
|
||||
my $opts = shift;
|
||||
my $packages = [];
|
||||
my $cnt;
|
||||
|
||||
if ( ! $opts->{'all'} && ! $opts->{'keys'} && $opts->{'search'} &&
|
||||
$self->{'pkgs'}{$opts->{'search'}} ) {
|
||||
return( [ $self->{'pkgs'}{$opts->{'search'}}[-1] ] );
|
||||
}
|
||||
|
||||
if ( $opts->{'keys'} ) {
|
||||
foreach ( split( /,| /, $opts->{'keys'} ) ) {
|
||||
if ( $_ =~ /^(\S+):(\S+)$/ ) {
|
||||
if ( ! grep( $_ eq $1,
|
||||
&SL::Package::FIELDS ) ) {
|
||||
SL->error( -1, "search(): $1:"
|
||||
. " Invalid key\n" );
|
||||
}
|
||||
|
||||
$opts->{$1} = $2;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ( $opts->{'search'} && $opts->{'search'} =~
|
||||
/^([a-zA-Z0-9]+)([<>=]+\S+)/ ) {
|
||||
$opts->{'name'} = $1;
|
||||
$opts->{'version'} = $2;
|
||||
}
|
||||
|
||||
foreach my $pkgname ( sort( keys( %{$self->{'pkgs'}} ) ) ) {
|
||||
my $package;
|
||||
|
||||
if ( $opts->{'name'} && $pkgname ne $opts->{'name'} ) {
|
||||
next;
|
||||
}
|
||||
|
||||
foreach ( sort { SL->vercmp( $a->{'version'},
|
||||
$b->{'version'} ) } ( @{$self->{'pkgs'}{$pkgname}} ) ) {
|
||||
if ( $opts->{'version'} && $opts->{'version'} =~
|
||||
/^((<|>)=?|=)\s*(.*)/ ) {
|
||||
my $op = $1;
|
||||
my $ver = $3;
|
||||
my $chk = SL->vercmp( $_->{'version'}, $ver );
|
||||
|
||||
if ( $op eq '<' && $chk != -1 ) {
|
||||
next;
|
||||
}
|
||||
if ( $op eq '<=' && $chk > 0 ) {
|
||||
next;
|
||||
}
|
||||
if ( $op eq '>' && $chk != 1 ) {
|
||||
next;
|
||||
}
|
||||
if ( $op eq '>=' && $chk < 0 ) {
|
||||
next;
|
||||
}
|
||||
if ( $op eq '=' && $chk != 0 ) {
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif ( $opts->{'version'} && $_->{'version'} ne
|
||||
$opts->{'version'} ) {
|
||||
next;
|
||||
}
|
||||
elsif ( $opts->{'depends'} && $_->{'depends'} !~
|
||||
/$opts->{'depends'}/ ) {
|
||||
next;
|
||||
}
|
||||
elsif ( $opts->{'source'} && $_->{'source'} ne
|
||||
$opts->{'source'} ) {
|
||||
next;
|
||||
}
|
||||
elsif ( $opts->{'repo'} && $_->{'repo'} ne
|
||||
$opts->{'repo'} ) {
|
||||
next;
|
||||
}
|
||||
elsif ( $opts->{'search'} && ( $_->{'name'} !~
|
||||
/$opts->{'search'}/ && $_->{'description'} !~
|
||||
/$opts->{'search'}/ ) ) {
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $opts->{'all'} ) {
|
||||
push( @$packages, $_ );
|
||||
}
|
||||
elsif ( ! $package || SL->vercmp( $_->{'version'},
|
||||
$package->{'version'} ) ) {
|
||||
$package = $_;
|
||||
}
|
||||
}
|
||||
|
||||
if ( $package ) {
|
||||
push( @$packages, $package );
|
||||
}
|
||||
}
|
||||
|
||||
return( $packages );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SL::Sources - Interface for Snaplinux package sources
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is not intended to be used directly, rather it is included with the parent SL.pm module. It is separated into its own module only to logically separate the code.
|
||||
|
||||
SL::Sources includes all functions for retrieving, parsing, and searching through package lists. The structure of package objects is defined in SL::Package.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
$sources = SL::Sources->new( $arrayref )
|
||||
|
||||
If $arrayref contains a list of valid sources the $sources object will be built. The $arrayref is intended to be populated with values parsed from /etc/sl.conf. The syntax for sources is as follows:
|
||||
|
||||
[sources]
|
||||
source1 = http://packages.snaplinux.org core dev util
|
||||
|
||||
Each item listed under the [sources] section is added to $sources->{'config'}. The following describes the structure:
|
||||
|
||||
$sources => {
|
||||
config => {
|
||||
source1 => {
|
||||
url => 'http://packages.snaplinux.org/0.1',
|
||||
order => 1,
|
||||
repos => {
|
||||
dev => {},
|
||||
core => {},
|
||||
util => {}
|
||||
|
||||
=head2 readpkgs
|
||||
|
||||
$sources->readpkgs()
|
||||
|
||||
Parses all source/repo files and builds a list of packages which is available in $sources->{'pkgs'}. Also reads all installed and removed packages and adds them to $sources->{'status'}. The list is built with the following structure:
|
||||
|
||||
$sources => {
|
||||
pkgs => {
|
||||
<PKGNAME> => [
|
||||
SL::Package->{'version'} => 1
|
||||
SL::Package->{'version'} => 2
|
||||
]
|
||||
}
|
||||
installed => {
|
||||
<PKGNAME> => SL::Package
|
||||
|
||||
=head2 search
|
||||
|
||||
$sources->search( $searchterms )
|
||||
|
||||
This will search all sources and repos in the $sources object for the search terms and either print the output, or if { quiet => 1 } is supplied as an arg it will return the highest version of the matched package. The quiet option is only intended for internal routines rather than for queries intended to display output on the command line.
|
||||
|
||||
Other available options that can be set (using key => value pairs):
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
This will only return packages where the name matches exactly
|
||||
|
||||
=item version
|
||||
|
||||
The operators <, <=, >, >=, = can all be used to retrieve the desired package version. The operator should preface the version string.
|
||||
|
||||
=item depends
|
||||
|
||||
The supplied string will be used as a patter to match dependencies in packages.
|
||||
|
||||
=item source
|
||||
|
||||
Return only packages available from the specified source.
|
||||
|
||||
=item repo
|
||||
|
||||
Return only packages from the specified repo
|
||||
|
||||
=item string
|
||||
|
||||
The supplied string will be used to match against either the package name, or the package description.
|
||||
|
||||
=back
|
||||
|
||||
=head2 refresh
|
||||
|
||||
$sources->refresh()
|
||||
|
||||
This will download all package information for the repos defined in $sources->{'config'}. The data will be stored in /var/lib/sl/sources/<SOURCENAME>
|
||||
|
||||
=cut
|
||||
|
||||
Reference in New Issue
Block a user