diff options
| author | Jacob Pipkin <j@dawnrazor.net> | 2012-08-30 07:20:32 -0500 |
|---|---|---|
| committer | Jacob Pipkin <j@dawnrazor.net> | 2012-08-30 07:20:32 -0500 |
| commit | 38488004c207508834543e02e991e6129669bc8c (patch) | |
| tree | 6191765663783a078fc84aa262ed05cc439071df | |
| parent | cd16a547b321e8a10716868c7788d016531511d8 (diff) | |
| download | sbotools2-38488004c207508834543e02e991e6129669bc8c.tar.xz | |
changes for REQUIRES in SBos for 14, and many cleanups, fixes, enhancements
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib.pm | 699 | ||||
| -rwxr-xr-x | sbocheck | 17 | ||||
| -rwxr-xr-x | sboclean | 30 | ||||
| -rwxr-xr-x | sboconfig | 63 | ||||
| -rwxr-xr-x | sbofind | 53 | ||||
| -rwxr-xr-x | sboinstall | 14 | ||||
| -rwxr-xr-x | sbosnap | 16 | ||||
| -rwxr-xr-x | sboupgrade | 323 | ||||
| -rw-r--r-- | t/SBO/Lib.pm | 668 | ||||
| -rw-r--r-- | t/SBO/Lib.pm~ | 643 | ||||
| -rwxr-xr-x | t/do_tests.sh | 4 | ||||
| -rwxr-xr-x | t/prep.pl | 46 | ||||
| -rwxr-xr-x | t/test.t | 95 | ||||
| -rwxr-xr-x | t/test.t~ | 95 |
14 files changed, 2190 insertions, 576 deletions
diff --git a/SBO-Lib/lib/SBO/Lib.pm b/SBO-Lib/lib/SBO/Lib.pm index 7dc19aa..3db3133 100644 --- a/SBO-Lib/lib/SBO/Lib.pm +++ b/SBO-Lib/lib/SBO/Lib.pm @@ -2,19 +2,23 @@ # # vim: set ts=4:noet # -# sbolib.sh +# Lib.pm # shared functions for the sbo_ scripts. # # author: Jacob Pipkin <j@dawnrazor.net> # date: Setting Orange, the 37th day of Discord in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> -package SBO::Lib 0.7; -my $version = "0.7"; +use 5.16.0; +use warnings FATAL => 'all'; +use strict; + +package SBO::Lib 1.0; +my $version = "1.0"; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw( +our @ISA = qw(Exporter); +our @EXPORT = qw( script_error open_fh open_read @@ -29,10 +33,13 @@ require Exporter; make_distclean do_upgradepkg get_sbo_location + get_from_info + get_tmp_extfn + get_tmp_perlfn ); -use warnings FATAL => 'all'; -use strict; +$< == 0 or die "This script requires root privileges.\n"; + use Tie::File; use Sort::Versions; use Digest::MD5; @@ -41,31 +48,30 @@ use File::Path qw(make_path remove_tree); use Fcntl; use File::Find; use File::Temp qw(tempdir tempfile); - -$< == 0 or die "This script requires root privileges.\n"; +use Data::Dumper; +use Fcntl qw(F_SETFD F_GETFD); our $tempdir = tempdir (CLEANUP => 1); # subroutine for throwing internal script errors -sub script_error { - unless (exists $_[0]) { - die "A fatal script error has occured. Exiting.\n"; - } else { - die "A fatal script error has occured:\n$_[0]\nExiting.\n"; - } +sub script_error (;$) { + exists $_[0] ? die "A fatal script error has occured:\n$_[0]\nExiting.\n" + : die "A fatal script error has occured. Exiting.\n"; } # sub for opening files, second arg is like '<','>', etc -sub open_fh { - exists $_[1] or script_error ('open_fh requires two arguments'); - script_error ('open_fh first argument not a file') unless -f $_[0]; +sub open_fh ($$) { + exists $_[1] or script_error 'open_fh requires two arguments'; + unless ($_[1] eq '>') { + -f $_[0] or script_error 'open_fh first argument not a file'; + } my ($file, $op) = @_; open my $fh, $op, $file or die "Unable to open $file.\n"; return $fh; } -sub open_read { - return open_fh (shift, '<'); +sub open_read ($) { + return open_fh shift, '<'; } # pull in configuration, set sane defaults, etc. @@ -82,7 +88,7 @@ our %config = ( # if the conf file exists, pull all the $key=$value pairs into a hash my %conf_values; if (-f $conf_file) { - my $fh = open_read ($conf_file); + my $fh = open_read $conf_file; my $text = do {local $/; <$fh>}; %conf_values = $text =~ /^(\w+)=(.*)$/mg; close $fh; @@ -91,28 +97,26 @@ if (-f $conf_file) { for my $key (keys %config) { $config{$key} = $conf_values{$key} if exists $conf_values{$key}; } -#$config{$_} = $conf_values{$_} for keys %config; $config{JOBS} = 'FALSE' unless $config{JOBS} =~ /^\d+$/; $config{SBO_HOME} = '/usr/sbo' if $config{SBO_HOME} eq 'FALSE'; +# some stuff we'll need later. my $distfiles = "$config{SBO_HOME}/distfiles"; my $slackbuilds_txt = "$config{SBO_HOME}/SLACKBUILDS.TXT"; - my $name_regex = '\ASLACKBUILD\s+NAME:\s+'; -sub show_version { - print "sbotools version $version\n"; - print "licensed under the WTFPL\n"; - print "<http://sam.zoy.org/wtfpl/COPYING>\n"; +sub show_version () { + say "sbotools version $version"; + say 'licensed under the WTFPL'; + say '<http://sam.zoy.org/wtfpl/COPYING>'; } # %supported maps what's in /etc/slackware-version to what's at SBo -sub get_slack_version { - my %supported = ( - '13.37.0' => '13.37', - '14.0' => '13.37', - ); - my $fh = open_read ('/etc/slackware-version'); +# which is now not needed since this version drops support < 14.0 +# but it's already future-proofed, so leave it. +sub get_slack_version () { + my %supported = ('14.0' => '14.0'); + my $fh = open_read '/etc/slackware-version'; chomp (my $line = <$fh>); close $fh; my $version = ($line =~ /\s+(\d+[^\s]+)$/)[0]; @@ -121,13 +125,13 @@ sub get_slack_version { return $supported{$version}; } -sub check_slackbuilds_txt { - return 1 if -f $slackbuilds_txt; - return; +# does the SLACKBUILDS.TXT file exist in the sbo tree? +sub chk_slackbuilds_txt () { + return -f $slackbuilds_txt ? 1 : 0; } # check for the validity of new $config{SBO_HOME} -sub check_home { +sub check_home () { my $sbo_home = $config{SBO_HOME}; if (-d $sbo_home) { opendir (my $home_handle, $sbo_home); @@ -136,62 +140,63 @@ sub check_home { die "$sbo_home exists and is not empty. Exiting.\n"; } } else { - make_path ($sbo_home) or die "Unable to create $sbo_home. Exiting.\n"; + make_path ($sbo_home) or die "Unable to create $sbo_home.\n"; } } -sub rsync_sbo_tree { - my $slk_version = get_slack_version (); +# rsync the sbo tree from slackbuilds.org to $config{SBO_HOME} +sub rsync_sbo_tree () { + my $slk_version = get_slack_version; my @arg = ('rsync', '-a', '--exclude=*.tar.gz', '--exclude=*.tar.gz.asc'); push @arg, "rsync://slackbuilds.org/slackbuilds/$slk_version/*"; - push @arg, $config{SBO_HOME}; - system @arg; - print "Finished.\n" and return 1; + my $out = system @arg, $config{SBO_HOME}; + say 'Finished.' and return $out; } -sub fetch_tree { - check_home (); - print "Pulling SlackBuilds tree...\n"; - rsync_sbo_tree (), return 1; +# wrappers for differing checks and output +sub fetch_tree () { + check_home; + say 'Pulling SlackBuilds tree...'; + rsync_sbo_tree, return $?; } -sub update_tree { - fetch_tree (), return unless check_slackbuilds_txt (); - print "Updating SlackBuilds tree...\n"; - rsync_sbo_tree (), return 1; +sub update_tree () { + fetch_tree, return unless chk_slackbuilds_txt; + say 'Updating SlackBuilds tree...'; + rsync_sbo_tree, return $?; } # if the SLACKBUILDS.TXT is not in $config{SBO_HOME}, we assume the tree has # not been populated there; prompt the user to automagickally pull the tree. -sub slackbuilds_or_fetch { - unless (check_slackbuilds_txt () ) { - print "It looks like you haven't run \"sbosnap fetch\" yet.\n"; - print "Would you like me to do this now? [y] "; - <STDIN> =~ /^[Yy\n]/ ? fetch_tree () : +sub slackbuilds_or_fetch () { + unless (chk_slackbuilds_txt) { + say 'It looks like you haven\'t run "sbosnap fetch" yet.'; + print 'Would you like me to do this now? [y] '; + <STDIN> =~ /^[Yy\n]/ ? fetch_tree : die "Please run \"sbosnap fetch\"\n"; } return 1; } # pull an array of hashes, each hash containing the name and version of an sbo -# currently installed. starting to think it might be better to only pull an -# array of names, and have another sub to pull the versions. -sub get_installed_sbos { +# currently installed. +sub get_installed_sbos () { my @installed; + # $1 == name, $2 == version + my $regex = qr#/([^/]+)-([^-]+)-[^-]+-[^-]+$#; for my $path (</var/log/packages/*_SBo>) { - my ($name, $version) = - ($path =~ qr#/([^/]+)-([^-]+)-[^-]+-[^-]+$#)[0,1]; + my ($name, $version) = ($path =~ $regex)[0,1]; push @installed, {name => $name, version => $version}; } - return @installed; + return \@installed; } # search the SLACKBUILDS.TXT for a given sbo's directory -sub get_sbo_location { - exists $_[0] or script_error ('get_sbo_location requires an argument.'); +sub get_sbo_location ($) { + exists $_[0] or script_error 'get_sbo_location requires an argument.'; my $sbo = shift; my $regex = qr#LOCATION:\s+\.(/[^/]+/$sbo)$#; - my $fh = open_read ($slackbuilds_txt); + my $fh = open_read $slackbuilds_txt; while (my $line = <$fh>) { if (my $loc = ($line =~ $regex)[0]) { return "$config{SBO_HOME}$loc"; @@ -200,105 +205,144 @@ sub get_sbo_location { return; } +# pull the sbo name from a $location: $config{SBO_HOME}/system/wine, etc. +sub get_sbo_from_loc ($) { + exists $_[0] or script_error 'get_sbo_from_loc requires an argument.'; + return (shift =~ qr#/([^/]+)$#)[0]; +} + +# pull piece(s) of data, GET, from the $sbo.info file under LOCATION. +sub get_from_info (%) { + my %args = ( + LOCATION => '', + GET => '', + @_ + ); + unless ($args{LOCATION} && $args{GET}) { + script_error 'get_from_info requires LOCATION and GET.'; + } + state $vars = {PRGNAM => ['']}; + my $sbo = get_sbo_from_loc $args{LOCATION}; + return $$vars{$args{GET}} if $$vars{PRGNAM}[0] eq $sbo; + # if we're here, we haven't read in the .info file yet. + my $fh = open_read "$args{LOCATION}/$sbo.info"; + # suck it all in, clean it all up, stuff it all in $vars. + my $contents = do {local $/; <$fh>}; + $contents =~ s/("|\\\n)//g; + $vars = {$contents =~ /^(\w+)=(.*)$/mg}; + # fill the hash with array refs - even for single values, + # since consistency here is a lot easier than sorting it out later + for my $key (keys %$vars) { + if ($$vars{$key} =~ /\s/) { + my @array = split ' ', $$vars{$key}; + $$vars{$key} = \@array; + } else { + $$vars{$key} = [$$vars{$key}]; + } + } + return exists $$vars{$args{GET}} ? $$vars{$args{GET}} : 0; +} + +# find the version in the tree for a given sbo (provided a location) +sub get_sbo_version ($) { + exists $_[0] or script_error 'get_sbo_version requires an argument.'; + my $version = get_from_info (LOCATION => shift, GET => 'VERSION'); + return $$version[0] ? $$version[0] : 0; +} + # for each installed sbo, find out whether or not the version in the tree is # newer, and compile an array of hashes containing those which are -sub get_available_updates { +sub get_available_updates () { my @updates; - my @pkg_list = get_installed_sbos (); - FIRST: for my $key (keys @pkg_list) { - my $location = get_sbo_location ($pkg_list[$key]{name}); + my $pkg_list = get_installed_sbos; + FIRST: for my $key (keys @$pkg_list) { + my $location = get_sbo_location $$pkg_list[$key]{name}; # if we can't find a location, assume invalid and skip next FIRST unless defined $location; - my $regex = qr/^VERSION="([^"]+)"/; - my $fh = open_read ("$location/$pkg_list[$key]{name}.info"); - SECOND: while (my $line = <$fh>) { - if (my $sbo_version = ($line =~ $regex)[0]) { - if (versioncmp ($sbo_version, $pkg_list[$key]{version}) == 1) { - push @updates, {name => $pkg_list[$key]{name}, - installed => $pkg_list[$key]{version}, - update => $sbo_version}; - } - last SECOND; - } + my $version = get_sbo_version $location; + if (versioncmp ($version, $$pkg_list[$key]{version}) == 1) { + push @updates, { + name => $$pkg_list[$key]{name}, + installed => $$pkg_list[$key]{version}, + update => $version + }; } - close $fh; } - return @updates; -} - -# pull links or md5sums (type - 'download','md5sum') from a given sbo's .info -# file, first checking for x86_64-specific info we are told to -sub find_download_info { - exists $_[3] or script_error - ('find_download_info requires four arguments.'); - my ($sbo, $location, $type, $x64) = @_; - my @return; - $type =~ tr/a-z/A-Z/; - $type = $x64 ? "${type}_x86_64" : $type; - my $regex = qr/$type="([^"\s]*)("|\s)/; - my $empty_regex = qr/=""$/; - # may be > 1 lines for a given key. - my $back_regex = qr/\\$/; - my $un_regex = qr/^UN(SUPPOR|TES)TED$/; - my $more = 'FALSE'; - my $fh = open_read ("$location/$sbo.info"); - FIRST: while (my $line = <$fh>) { - if ($more eq 'FALSE') { - if ($line =~ $regex) { - last FIRST if $line =~ $empty_regex; - # some sbos have UNSUPPORTED for the x86_64 info - $1 =~ $un_regex ? last FIRST : push @return, $1; - $more = 'TRUE' if $line =~ $back_regex; - } - } else { - $more = 'FALSE' unless $line =~ $back_regex; - # we can assume anything we need will be at least 6 chars long - push @return, ($line =~ /([^\s"]{6,})/)[0]; + return \@updates; +} + +# get downloads and md5sums from an sbo's .info file, first +# checking for x86_64-specific info if we are told to +sub get_download_info (%) { + my %args = ( + LOCATION => 0, + X64 => 1, + @_ + ); + $args{LOCATION} or script_error 'get_download_info requires LOCATION.'; + my ($get, $downs, $md5s, %return); + $get = ($args{X64} ? 'DOWNLOAD_x86_64' : 'DOWNLOAD'); + $downs = get_from_info (LOCATION => $args{LOCATION}, GET => $get); + # did we get nothing back, or UNSUPPORTED/UNTESTED? + if ($args{X64}) { + my $nothing; + if (! $$downs[0]) { + $nothing = 1; + } elsif ($$downs[0] =~ qr/^UN(SUPPOR|TES)TED$/) { + $nothing = 1; + } + if ($nothing) { + $args{X64} = 0; + $downs = get_from_info (LOCATION => $args{LOCATION}, + GET => 'DOWNLOAD'); } } - close $fh; - return @return if exists $return[0]; - return; + # if we still don't have any links, something is really wrong. + return unless $$downs[0]; + # grab the md5s and build a hash + $get = $args{X64} ? 'MD5SUM_x86_64' : 'MD5SUM'; + $md5s = get_from_info (LOCATION => $args{LOCATION}, GET => $get); + return unless $$md5s[0]; + $return{$$downs[$_]} = $$md5s[$_] for (keys @$downs); + return %return; } -sub get_arch { +sub get_arch () { chomp (my $arch = `uname -m`); return $arch; } -# assemble an array of hashes containing links and md5sums for a given sbo, -# with the option of only checking for 32-bit links, for -compat32 packaging -sub get_sbo_downloads { - exists $_[2] or script_error - ('get_sbo_downloads requires three arguments.'); - -d $_[1] or script_error ('get_sbo_downloads given a non-directory.'); - my ($sbo, $location, $only32) = @_; - my $arch = get_arch (); - my (@links, @md5s); +# TODO: should probably combine this with get_download_info +sub get_sbo_downloads (%) { + my %args = ( + LOCATION => '', + 32 => 0, + @_ + ); + $args{LOCATION} or script_error 'get_sbo_downloads requires LOCATION.'; + my $location = $args{LOCATION}; + -d $location or script_error 'get_sbo_downloads given a non-directory.'; + my $arch = get_arch; + my %dl_info; if ($arch eq 'x86_64') { - unless ($only32 eq 'TRUE') { - @links = find_download_info ($sbo, $location, 'download', 1); - @md5s = find_download_info ($sbo, $location, 'md5sum', 1); - } - } - unless (exists $links[0]) { - @links = find_download_info ($sbo, $location, 'download', 0); - @md5s = find_download_info ($sbo, $location, 'md5sum', 0); + %dl_info = get_download_info (LOCATION => $location) unless $args{32}; + } + unless (keys %dl_info > 0) { + %dl_info = get_download_info (LOCATION => $location, X64 => 0); } - my @downloads; - push @downloads, {link => $links[$_], md5sum => $md5s[$_]} for keys @links; - return @downloads; + return %dl_info; } -sub get_filename_from_link { - exists $_[0] or script_error - ('get_filename_from_link requires an argument'); +# given a link, grab the filename from the end of it +sub get_filename_from_link ($) { + exists $_[0] or script_error 'get_filename_from_link requires an argument'; return "$distfiles/". (shift =~ qr#/([^/]+)$#)[0]; } -sub compute_md5sum { - -f $_[0] or script_error ('compute_md5sum requires a file argument.'); - my $fh = open_read (shift); +# for a given file, computer its md5sum +sub compute_md5sum ($) { + -f $_[0] or script_error 'compute_md5sum requires a file argument.'; + my $fh = open_read shift; my $md5 = Digest::MD5->new; $md5->addfile ($fh); my $md5sum = $md5->hexdigest; @@ -306,82 +350,67 @@ sub compute_md5sum { return $md5sum; } +sub compare_md5s ($$) { + exists $_[1] or script_error 'compare_md5s requires two arguments.'; + my ($first, $second) = @_; + return $first eq $second ? 1 : 0; +} + # for a given distfile, see whether or not it exists, and if so, if its md5sum # matches the sbo's .info file -sub check_distfile { - exists $_[1] or script_error ('check_distfile requires two arguments.'); +sub verify_distfile ($$) { + exists $_[1] or script_error 'check_distfile requires two arguments.'; my ($link, $info_md5sum) = @_; - my $filename = get_filename_from_link ($link); + my $filename = get_filename_from_link $link; return unless -d $distfiles; return unless -f $filename; - my $md5sum = compute_md5sum ($filename); - return unless $info_md5sum eq $md5sum; - return 1; + my $md5sum = compute_md5sum $filename; + return compare_md5s $info_md5sum, $md5sum; } # for a given distfile, attempt to retrieve it and, if successful, check its # md5sum against that in the sbo's .info file -sub get_distfile { - exists $_[1] or script_error ('get_distfile requires an argument'); - my ($link, $expected_md5sum) = @_; - my $filename = get_filename_from_link ($link); - mkdir ($distfiles) unless -d $distfiles; - chdir ($distfiles); +sub get_distfile ($$) { + exists $_[1] or script_error 'get_distfile requires an argument'; + my ($link, $exp_md5) = @_; + my $filename = get_filename_from_link $link; + mkdir $distfiles unless -d $distfiles; + chdir $distfiles; system ("wget --no-check-certificate $link") == 0 or die "Unable to wget $link\n"; - my $md5sum = compute_md5sum ($filename); - $md5sum eq $expected_md5sum or die "md5sum failure for $filename.\n"; + my $md5sum = compute_md5sum $filename; + # can't do anything if the link in the .info doesn't lead to a good d/l + compare_md5s $md5sum, $exp_md5 or die "md5sum failure for $filename.\n"; return 1; } -# find the version in the tree for a given sbo -sub get_sbo_version { - exists $_[1] or script_error ('get_sbo_version requires two arguments.'); - my ($sbo, $location) = @_; - my $version; - my $fh = open_read ("$location/$sbo.info"); - my $version_regex = qr/^VERSION="([^"]+)"/; - FIRST: while (my $line = <$fh>) { - last FIRST if $version = ($line =~ $version_regex)[0]; - } - close $fh; - return $version; -} - -# for a given distfile, what will be the full path of the symlink? -sub get_symlink_from_filename { +# for a given distfile, figure out what the full path to its symlink will be +sub get_symlink_from_filename ($$) { exists $_[1] or script_error - ('get_symlink_from_filename requires two arguments'); + 'get_symlink_from_filename requires two arguments'; -f $_[0] or script_error - ('get_symlink_from_filename first argument is not a file'); + 'get_symlink_from_filename first argument is not a file'; my ($filename, $location) = @_; - my @split = split ('/', reverse ($filename), 2); - return "$location/". reverse ($split[0]); + return "$location/". ($filename =~ qr#/([^/]+)$#)[0]; } # determine whether or not a given sbo is 32-bit only -sub check_x32 { - exists $_[1] or script_error ('check_x32 requires two arguments.'); - my ($sbo, $location) = @_; - my $fh = open_read ("$location/$sbo.info"); - my $regex = qr/^DOWNLOAD_x86_64="UN(SUPPOR|TES)TED"/; - while (my $line = <$fh>) { - return 1 if $line =~ $regex; - } - close $fh; - return; +sub check_x32 ($) { + exists $_[0] or script_error 'check_x32 requires an argument.'; + my $dl = get_from_info (LOCATION => shift, GET => 'DOWNLOAD_x86_64'); + return $$dl[0] =~ /UN(SUPPOR|TES)TED/ ? 1 : 0; } # can't do 32-bit on x86_64 without this file, so we'll use it as the test to # to determine whether or not an x86_64 system is setup for multilib -sub check_multilib { +sub check_multilib () { return 1 if -f '/etc/profile.d/32dev.sh'; return; } # make a backup of the existent SlackBuild, and rewrite the original as needed -sub rewrite_slackbuild { - exists $_[1] or script_error ('rewrite_slackbuild requires two arguments.'); +sub rewrite_slackbuild ($$%) { + exists $_[1] or script_error 'rewrite_slackbuild requires two arguments.'; my ($slackbuild, $tempfn, %changes) = @_; copy ($slackbuild, "$slackbuild.orig") or die "Unable to backup $slackbuild to $slackbuild.orig\n"; @@ -389,7 +418,8 @@ sub rewrite_slackbuild { my $makepkg_regex = qr/makepkg/; my $libdir_regex = qr/^\s*LIBDIRSUFFIX="64"\s*$/; my $make_regex = qr/^\s*make(| \Q||\E exit 1)$/; - my $arch_out_regex = qr/\$VERSION-\$ARCH-\$BUILD/; + my $arch_regex = qr/\$VERSION-\$ARCH-\$BUILD/; + # tie the slackbuild, because this is the easiest way to handle this. tie my @sb_file, 'Tie::File', $slackbuild; for my $line (@sb_file) { # get the output of the tar and makepkg commands. hope like hell that v @@ -397,16 +427,15 @@ sub rewrite_slackbuild { if ($line =~ $tar_regex || $line =~ $makepkg_regex) { $line = "$line | tee -a $tempfn"; } - while (my ($key, $value) = each %changes) { - if ($key eq 'libdirsuffix') { - $line =~ s/64/$value/ if $line =~ $libdir_regex; - } - if ($key eq 'make') { - $line =~ s/make/make $value/ if $line =~ $make_regex; - } - if ($key eq 'arch_out') { - $line =~ s/\$ARCH/$value/ if $line =~ $arch_out_regex; - } + # then check for and apply any other %changes + if (exists $changes{libdirsuffix}) { + $line =~ s/64/$changes{libdirsuffix}/ if $line =~ $libdir_regex; + } + if (exists $changes{make}) { + $line =~ s/make/make $changes{make}/ if $line =~ $make_regex; + } + if (exists $changes{arch_out}) { + $line =~ s/\$ARCH/$changes{arch_out}/ if $line =~ $arch_regex; } } untie @sb_file; @@ -414,8 +443,8 @@ sub rewrite_slackbuild { } # move a backed-up .SlackBuild file back into place -sub revert_slackbuild { - exists $_[0] or script_error ('revert_slackbuild requires an argument'); +sub revert_slackbuild ($) { + exists $_[0] or script_error 'revert_slackbuild requires an argument'; my $slackbuild = shift; if (-f "$slackbuild.orig") { unlink $slackbuild if -f $slackbuild; @@ -424,141 +453,199 @@ sub revert_slackbuild { return 1; } +# for each $download, see if we have it, and if the copy we have is good, +# otherwise download a new copy +sub check_distfiles (%) { + exists $_[0] or script_error 'check_distfiles requires an argument.'; + my %dists = @_; + for my $link (keys %dists) { + my $md5sum = $dists{$link}; + unless (verify_distfile $link, $md5sum) { + die unless get_distfile $link, $md5sum; + } + } + return 1; +} + # given a location and a list of download links, assemble a list of symlinks, # and create them. -sub create_symlinks { - exists $_[1] or script_error ('create_symlinks requires two arguments.'); - my ($location, @downloads) = @_; +sub create_symlinks ($%) { + exists $_[1] or script_error 'create_symlinks requires two arguments.'; + my ($location, %downloads) = @_; my @symlinks; - for my $key (keys @downloads) { - my $link = $downloads[$key]{link}; - my $md5sum = $downloads[$key]{md5sum}; - my $filename = get_filename_from_link ($link); - unless (check_distfile ($link, $md5sum) ) { - die unless get_distfile ($link, $md5sum); - } - my $symlink = get_symlink_from_filename ($filename, $location); + for my $link (keys %downloads) { + my $filename = get_filename_from_link $link; + my $symlink = get_symlink_from_filename $filename, $location; push @symlinks, $symlink; - symlink ($filename, $symlink); + symlink $filename, $symlink; } return @symlinks; } -# make a .SlackBuild executable. -sub prep_sbo_file { - exists $_[1] or script_error ('prep_sbo_file requires two arguments'); - my ($sbo, $location) = @_; - chdir ($location); - chmod (0755, "$location/$sbo.SlackBuild"); - return 1; -} - # pull the untarred source directory or created package name from the temp # file (the one we tee'd to) -sub grok_temp_file { - exists $_[1] or script_error ('grok_temp_file requires two arguments'); - my ($tempfn, $find) = @_; +sub grok_temp_file (%) { + my %args = ( + FH => '', + REGEX => '', + CAPTURE => 0, + @_ + ); + unless ($args{FH} && $args{REGEX}) { + script_error 'grok_temp_file requires two arguments'; + } + my $fh = $args{FH}; + seek $fh, 0, 0; my $out; - my $pkg_regex = qr/^Slackware\s+package\s+([^\s]+)\s+created\.$/; - my $src_regex = qr#^([^/]+)/.*$#; - my $fh = open_read ($tempfn); FIRST: while (my $line = <$fh>) { - if ($find eq 'pkg') { - last FIRST if $out = ($line =~ $pkg_regex)[0]; - } elsif ($find eq 'src') { - last FIRST if $out = ($line =~ $src_regex)[0]; + if ($line =~ $args{REGEX}) { + $out = ($line =~ $args{REGEX})[$args{CAPTURE}]; + last FIRST; } } - close $fh; +# close $fh; return $out; } # wrappers around grok_temp_file -sub get_src_dir { - exists $_[0] or script_error ('get_src_dir requires an argument'); - return grok_temp_file (shift, 'src'); +sub get_src_dir ($) { + exists $_[0] or script_error 'get_src_dir requires an argument'; + return grok_temp_file (FH => shift, REGEX => qr#^([^/]+)/#); +} + +sub get_pkg_name ($) { + exists $_[0] or script_error 'get_pkg_name requires an argument'; + return grok_temp_file (FH => shift, + REGEX => qr/^Slackware\s+package\s+([^\s]+)\s+created\.$/); +} + +sub clear_coe_bit ($) { + exists $_[0] or script_error 'clear_coe_bit requires an argument'; + my $fh = shift; + fcntl ($fh, F_SETFD, 0) or die "no unset exec-close thingy\n"; + return $fh; } -sub get_pkg_name { - exists $_[0] or script_error ('get_pkg_name requires an argument'); - return grok_temp_file (shift, 'pkg'); +sub get_tmp_extfn ($) { + exists $_[0] or script_error 'get_tmp_extfn requires an argument.'; + my $fh = clear_coe_bit shift; + return '/dev/fd/'. fileno $fh; +} + +sub get_tmp_perlfn ($) { + exists $_[0] or script_error 'get_tmp_perlfn requires an argument.'; + my $fh = clear_coe_bit shift; + return '+<=&'. fileno $fh; } # prep and run .SlackBuild -sub perform_sbo { - exists $_[6] or script_error ('perform_sbo requires seven arguments'); - my ($opts, $jobs, $sbo, $location, $arch, $c32, $x32) = @_; - prep_sbo_file ($sbo, $location); +sub perform_sbo (%) { + my %args = ( + OPTS => 0, + JOBS => 0, + LOCATION => '', + ARCH => '', + C32 => 0, + X32 => 0, + @_ + ); + unless ($args{LOCATION} && $args{ARCH}) { + script_error 'perform_sbo requires LOCATION and ARCH.'; + } + my $location = $args{LOCATION}; + my $sbo = get_sbo_from_loc $location; my ($cmd, %changes); - $jobs eq 'FALSE' or $changes{make} = "-j $jobs"; - if ($arch eq 'x86_64' and ($c32 eq 'TRUE' || $x32) ) { - if ($c32 eq 'TRUE') { + # figure out any changes we need to make to the .SlackBuild + $changes{make} = "-j $args{JOBS}" if $args{JOBS}; + if ($args{ARCH} eq 'x86_64' and ($args{C32} || $args{X32})) { + if ($args{C32}) { $changes{libdirsuffix} = ''; - } elsif ($x32) { + } elsif ($args{X32}) { $changes{arch_out} = 'i486'; } - $cmd = ". /etc/profile.d/32dev.sh && $location/$sbo.SlackBuild"; - } else { - $cmd = "$location/$sbo.SlackBuild"; + $cmd = ". /etc/profile.d/32dev.sh &&"; } - $cmd = "$opts $cmd" unless $opts eq 'FALSE'; - my ($tempfh, $tempfn) = tempfile (DIR => $tempdir); - close $tempfh; - rewrite_slackbuild ("$location/$sbo.SlackBuild", $tempfn, %changes); - my $out = system $cmd; - revert_slackbuild ("$location/$sbo.SlackBuild"); + $cmd .= "/bin/sh $location/$sbo.SlackBuild"; + $cmd = "$args{OPTS} $cmd" if $args{OPTS}; + my $tempfh = tempfile (DIR => $tempdir); + my $fn = get_tmp_extfn $tempfh; + rewrite_slackbuild "$location/$sbo.SlackBuild", $fn, %changes; + chdir $location, my $out = system $cmd; + revert_slackbuild "$location/$sbo.SlackBuild"; die unless $out == 0; - my $src = get_src_dir ($tempfn); - my $pkg = get_pkg_name ($tempfn); - unlink $tempfn; + my $pkg = get_pkg_name $tempfh; + my $src = get_src_dir $tempfh; return $pkg, $src; } +# run convertpkg on a package to turn it into a -compat32 thing +sub do_convertpkg ($) { + exists $_[0] or script_error 'do_convertpkg requires an argument.'; + my $pkg = shift; + my $tempfh = tempfile (DIR => $tempdir); + my $fn = get_tmp_extfn $tempfh; + my $cmd = "/usr/sbin/convertpkg-compat32 -i $pkg -d /tmp | tee $fn"; + system ($cmd) == 0 or die; + unlink $pkg; + return get_pkg_name $tempfh; +} + # "public interface", sort of thing. -sub do_slackbuild { - exists $_[4] or script_error ('do_slackbuild requires five arguments.'); - my ($opts, $jobs, $sbo, $location, $compat32) = @_; - my $arch = get_arch (); - my $version = get_sbo_version ($sbo, $location); - my @downloads = get_sbo_downloads ($sbo, $location, $compat32); +sub do_slackbuild (%) { + my %args = ( + OPTS => 0, + JOBS => 0, + LOCATION => '', + COMPAT32 => 0, + @_ + ); + $args{LOCATION} or script_error 'do_slackbuild requires LOCATION.'; + my $location = $args{LOCATION}; + my $sbo = get_sbo_from_loc $location; + my $arch = get_arch; + my $multi = check_multilib; + my $version = get_sbo_version $location; my $x32; - if ($compat32 eq 'TRUE') { - unless ($arch eq 'x86_64') { - die "You can only create compat32 packages on x86_64 systems.\n"; - } else { - die "This system does not appear to be setup for multilib.\n" - unless check_multilib (); - die "compat32 pkgs require /usr/sbin/convertpkg-compat32.\n" + # ensure x32 stuff is set correctly, or that we're setup for it + if ($args{COMPAT32}) { + die "compat32 only works on x86_64.\n" unless $arch eq 'x86_64'; + die "compat32 requires multilib.\n" unless $multi; + die "compat32 requires /usr/sbin/convertpkg-compat32.\n" unless -f '/usr/sbin/convertpkg-compat32'; - } } else { if ($arch eq 'x86_64') { - $x32 = check_x32 ($sbo, $location); - if ($x32 && ! check_multilib () ) { - die "$sbo is 32-bit, but this system does not seem to be setup for multilib.\n"; + $x32 = check_x32 $args{LOCATION}; + if ($x32 && ! $multi) { + die "$sbo is 32-bit which requires multilib on x86_64.\n"; } } } - my @symlinks = create_symlinks ($location, @downloads); - my ($pkg, $src) = perform_sbo - ($opts, $jobs, $sbo, $location, $arch, $compat32, $x32); - if ($compat32 eq 'TRUE') { - my ($tempfh, $tempfn) = tempfile (DIR => $tempdir); - close $tempfh; - my $cmd = "/usr/sbin/convertpkg-compat32 -i $pkg -d /tmp | tee $tempfn"; - system ($cmd) == 0 or die; - unlink $pkg; - $pkg = get_pkg_name ($tempfn); - } + # get a hash of downloads and md5sums, ensure we have 'em, symlink 'em + my %downloads = get_sbo_downloads ( + LOCATION => $location, + 32 => $args{COMPAT32} + ); + check_distfiles %downloads; + my @symlinks = create_symlinks $args{LOCATION}, %downloads; + # setup and run the .SlackBuild itself + my ($pkg, $src) = perform_sbo ( + OPTS => $args{OPTS}, + JOBS => $args{JOBS}, + LOCATION => $location, + ARCH => $arch, + C32 => $args{COMPAT32}, + X32 => $x32, + ); + do_convertpkg $pkg if $args{COMPAT32}; unlink $_ for @symlinks; return $version, $pkg, $src; } # remove work directories (source and packaging dirs under /tmp/SBo) -sub make_clean { - exists $_[1] or script_error ('make_clean requires two arguments.'); +sub make_clean ($$$) { + exists $_[2] or script_error 'make_clean requires three arguments.'; my ($sbo, $src, $version) = @_; - print "Cleaning for $sbo-$version...\n"; + say "Cleaning for $sbo-$version..."; my $tmpsbo = "/tmp/SBo"; remove_tree ("$tmpsbo/$src") if -d "$tmpsbo/$src"; remove_tree ("$tmpsbo/package-$sbo") if -d "$tmpsbo/package-$sbo"; @@ -566,23 +653,31 @@ sub make_clean { } # remove distfiles -sub make_distclean { - exists $_[3] or script_error ('make_distclean requires four arguments.'); - my ($sbo, $src, $version, $location) = @_; - make_clean ($sbo, $src, $version); - print "Distcleaning for $sbo-$version...\n"; - my @downloads = get_sbo_downloads ($sbo, $location, 0); - for my $key (keys @downloads) { - my $filename = get_filename_from_link ($downloads[$key]{link}); +sub make_distclean (%) { + my %args = ( + SRC => '', + VERSION => '', + LOCATION => '', + @_ + ); + unless ($args{SRC} && $args{VERSION} && $args{LOCATION}) { + script_error 'make_distclean requires four arguments.'; + } + my $sbo = get_sbo_from_loc $args{LOCATION}; + make_clean $sbo, $args{SRC}, $args{VERSION}; + say "Distcleaning for $sbo-$args{VERSION}..."; + # remove any distfiles for this particular SBo. + my %downloads = get_sbo_downloads (LOCATION => $args{LOCATION}); + for my $key (keys %downloads) { + my $filename = get_filename_from_link $key; unlink $filename if -f $filename; } return 1; } # run upgradepkg for a created package -sub do_upgradepkg { - exists $_[0] or script_error ('do_upgradepkg requires an argument.'); +sub do_upgradepkg ($) { + exists $_[0] or script_error 'do_upgradepkg requires an argument.'; system ('/sbin/upgradepkg', '--reinstall', '--install-new', shift); return 1; } - @@ -9,6 +9,7 @@ # date: Sweetmorn, the 38th day of Discord in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> +use 5.16.0; use SBO::Lib; use File::Basename; use Getopt::Std; @@ -22,18 +23,18 @@ my $self = basename ($0); my %options; getopts ('v',\%options); -show_version () && exit (0) if (exists $options{v}); +show_version && exit 0 if (exists $options{v}); -update_tree (); +update_tree; print "Checking for updated SlackBuilds...\n"; -my @updates = get_available_updates (); +my $updates = get_available_updates; # pretty formatting. my @listing; -for my $key (keys @updates) { - my $string = "$updates[$key]{name}-$updates[$key]{installed}"; - $string .= " < needs updating (SBo has $updates[$key]{update})\n"; +for my $key (keys @$updates) { + my $string = "$$updates[$key]{name}-$$updates[$key]{installed}"; + $string .= " < needs updating (SBo has $$updates[$key]{update})\n"; push @listing, $string; } @@ -41,9 +42,9 @@ if (exists $listing[0]) { my $tab = new Text::Tabulate (); $tab->configure (tab => '\s'); my $output = $tab->format (@listing); - print "\n". $output ."\n"; + say "\n". $output; } else { - print "\nNo updates available.\n"; + say "\nNo updates available."; } exit 0; @@ -9,6 +9,7 @@ # date: Boomtime, the 6th day of Confusion in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> +use 5.16.0; use SBO::Lib; use File::Basename; use Getopt::Std; @@ -19,7 +20,7 @@ use warnings FATAL => 'all'; my %config = %SBO::Lib::config; my $self = basename ($0); -sub show_usage { +sub show_usage () { print <<EOF Usage: $self (options) [package] @@ -36,26 +37,25 @@ EOF my %options; getopts ('hvdwi', \%options); -show_usage () && exit (0) if exists $options{h}; -show_version () && exit (0) if exists $options{v}; -my $clean_dist = exists $options{d} ? 'TRUE' : 'FALSE'; -my $clean_work = exists $options{w} ? 'TRUE' : 'FALSE'; -my $interactive = exists $options{i} ? 'TRUE' : 'FALSE'; +show_usage && exit 0 if exists $options{h}; +show_version && exit 0 if exists $options{v}; +my $clean_dist = exists $options{d} ? 1 : 0; +my $clean_work = exists $options{w} ? 1 : 0; +my $interactive = exists $options{i} ? 1 : 0; -if ($clean_dist eq 'FALSE' && $clean_work eq 'FALSE') { - show_usage (); - die "You must specify at least one of -d or -w.\n"; +unless ($clean_dist || $clean_work) { + show_usage, die "You must specify at least one of -d or -w.\n"; } -sub remove_stuff { - exists $_[0] or script_error ('remove_stuff requires an argument'); - print "Nothing to do.\n" and return 1 unless -d $_[0]; +sub remove_stuff ($) { + exists $_[0] or script_error 'remove_stuff requires an argument'; + say "Nothing to do." and return 1 unless -d $_[0]; my $dir = shift; opendir (my $dh, $dir); FIRST: while (my $ls = readdir $dh) { next FIRST if $ls =~ /^(\.){1,2}$/; my $full = "$dir/$ls"; - if ($interactive eq 'TRUE') { + if ($interactive) { print "Remove $full? [n] "; next FIRST unless <STDIN> =~ /^[Yy]/; } @@ -64,7 +64,7 @@ sub remove_stuff { } } -remove_stuff ($config{SBO_HOME} . '/distfiles') if $clean_dist eq 'TRUE'; -remove_stuff ('/tmp/SBo') if $clean_work eq 'TRUE'; +remove_stuff $config{SBO_HOME} .'/distfiles' if $clean_dist; +remove_stuff '/tmp/SBo' if $clean_work; exit 0; @@ -9,6 +9,7 @@ # date: Pungenday, the 40th day of Discord in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> +use 5.16.0; use strict; use warnings FATAL => 'all'; use SBO::Lib; @@ -21,7 +22,7 @@ use File::Temp qw(tempfile);; my %config = %SBO::Lib::config; my $self = basename ($0); -sub show_usage { +sub show_usage () { print <<EOF Usage: $self [options] [arguments] @@ -48,16 +49,8 @@ EOF my %options; getopts ('hvlc:d:p:s:j:', \%options); -show_usage () and exit (0) if exists $options{h}; -show_version () and exit (0) if exists $options{v}; - -if (exists $options{l}) { - my @keys = sort {$a cmp $b} keys %config; - print "$_=$config{$_}\n" for @keys; - exit 0; -} - -show_usage () and exit (0) unless %options; +show_usage and exit 0 if exists $options{h}; +show_version and exit 0 if exists $options{v}; my %valid_confs = ( c => 'NOCLEAN', @@ -66,7 +59,17 @@ my %valid_confs = ( p => 'PKG_DIR', s => 'SBO_HOME', ); - + +my %params = reverse %valid_confs; + +if (exists $options{l}) { + my @keys = sort {$a cmp $b} keys %config; + say "sboconfig -$params{$_}:\n $_=$config{$_}" for @keys; + exit 0; +} + +show_usage and exit 0 unless %options; + # setup what's being changed. my %changes; while (my ($key, $value) = each %valid_confs) { @@ -77,52 +80,48 @@ if (exists $changes{JOBS}) { ($changes{JOBS} =~ /^\d+$/ || $changes{JOBS} eq 'FALSE'); } -my $conf_dir = $SBO::Lib::conf_dir;; +my $conf_dir = $SBO::Lib::conf_dir; my $conf_file = $SBO::Lib::conf_file; # safely modify our conf file; copy to a temp location, edit the temp file, # move the edited file into place -sub config_write { - exists $_[1] or script_error ('config_write requires two arguments.'); +sub config_write ($$) { + exists $_[1] or script_error 'config_write requires two arguments.'; my ($key, $val) = @_; if (! -d $conf_dir) { - mkdir ($conf_dir) or die "Unable to create $conf_dir. Exiting.\n"; + mkdir $conf_dir or die "Unable to create $conf_dir. Exiting.\n"; } if (-f $conf_file) { - my ($fh, $filename) = tempfile (DIR => $SBO::Lib::tempdir); - close $fh; - copy ($conf_file, $filename); + my $tempfh = tempfile (DIR => $SBO::Lib::tempdir); + my $tempfn = get_tmp_perlfn $tempfh; + copy ($conf_file, $tempfn); # tie the file so that if $key is already there, we just change that # line and untie it - tie my @temp, 'Tie::File', $filename; - my $has = 'FALSE'; + tie my @temp, 'Tie::File', $tempfn; + my $has = 0; my $regex = qr/\A\Q$key\E=/; FIRST: for my $tmpline (@temp) { - if ($tmpline =~ $regex) { - $has = 'TRUE'; - $tmpline = "$key=$val"; - last FIRST; - } + $has++, $tmpline = "$key=$val", last FIRST if $tmpline =~ $regex;; } untie @temp; # otherwise, append our new $key=$value pair - if ($has eq 'FALSE') { - my $fh = open_fh ($filename, '>>'); + unless ($has) { + my $fh = open_fh ($tempfn, '>>'); print {$fh} "$key=$val\n"; close $fh; } - move ($filename, $conf_file); + move ($tempfn, $conf_file); } else { # no config file, easiest case of all. - my $fh = open_fh ($conf_file, '>'); - print {$fh} "$key=$val\n"; + my $fh = open_fh $conf_file, '>'; + say {$fh} "$key=$val"; close $fh; } } while (my ($key, $value) = each %changes) { print "Setting $key to $value...\n"; - config_write ($key, $value); + config_write $key, $value; } exit 0; @@ -9,6 +9,7 @@ # date: Boomtime, the 39th day of Discord in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> +use 5.16.0; use SBO::Lib; use File::Basename; use Getopt::Std; @@ -18,7 +19,7 @@ use warnings FATAL => 'all'; my %config = %SBO::Lib::config; my $self = basename ($0); -sub show_usage { +sub show_usage () { print <<EOF Usage: $self (search_term) @@ -37,40 +38,40 @@ EOF my %options; getopts ('hvir', \%options); -show_usage () and exit (0) if (exists $options{h}); -show_version () and exit (0) if (exists $options{v}); +show_usage and exit 0 if exists $options{h}; +show_version and exit 0 if exists $options{v}; -my $show_readme = exists $options{r} ? 'TRUE' : 'FALSE'; -my $show_info = exists $options{i} ? 'TRUE' : 'FALSE'; +my $show_readme = exists $options{r} ? 1 : 0; +my $show_info = exists $options{i} ? 1 : 0; -show_usage () and exit (1) unless exists $ARGV[0]; +show_usage and exit 1 unless exists $ARGV[0]; my $search = $ARGV[0]; # if we can't find SLACKBUILDS.TXT in $config{HOME}, prompt to fetch the tree -slackbuilds_or_fetch (); +slackbuilds_or_fetch; # find anything with $search in its name -my (@findings, $name); -my $found = 'FALSE'; +my ($findings, $name); +my $found = 0; my $name_regex = qr/NAME:\s+(.*\Q$search\E.*)$/i; my $loc_regex = qr/LOCATION:\s+(.*)$/; -my $fh = open_read ("$config{SBO_HOME}/SLACKBUILDS.TXT"); +my $fh = open_read "$config{SBO_HOME}/SLACKBUILDS.TXT"; FIRST: while (my $line = <$fh>) { - if ($found eq 'FALSE') { - $found = 'TRUE', next FIRST if $name = ($line =~ $name_regex)[0]; + unless ($found) { + $found++, next FIRST if $name = ($line =~ $name_regex)[0]; } else { if (my ($location) = ($line =~ $loc_regex)[0]) { - $found = 'FALSE'; + $found = 0; $location =~ s#^\.##; - push @findings, {$name => $config{SBO_HOME} . $location}; + push @$findings, {$name => $config{SBO_HOME} . $location}; } } } -sub get_file_contents { - exists $_[0] or script_error ('get_file_contents requires an argument'); - -f $_[0] or script_error ('get_file_contents argument is not a file'); - my $fh = open_read (shift); +sub get_file_contents ($) { + exists $_[0] or script_error 'get_file_contents requires an argument'; + -f $_[0] or return "$_[0] doesn't exist.\n"; + my $fh = open_read shift; my $contents = do {local $/; <$fh>}; $contents =~ s/\n/\n /g; $contents =~ s/ $//g; @@ -78,22 +79,22 @@ sub get_file_contents { } # pretty formatting -if (exists $findings[0]) { +if (exists $$findings[0]) { my @listing = ("\n"); - for my $hash (@findings) { - while (my ($key, $value) = each %{$hash}) { + for my $hash (@$findings) { + while (my ($key, $value) = each %$hash) { push @listing, "SBo: $key\n"; push @listing, "Path: $value\n"; - push @listing, "info: ". get_file_contents ("$value/$key.info") - if $show_info eq 'TRUE'; - push @listing, "README: ". get_file_contents ("$value/README") - if $show_readme eq 'TRUE'; + push @listing, "info: ". get_file_contents "$value/$key.info" + if $show_info; + push @listing, "README: ". get_file_contents "$value/README" + if $show_readme; push @listing, "\n"; } } print $_ for @listing; } else { - print "Nothing found for search term: $search\n"; + say "Nothing found for search term: $search"; } exit 0; @@ -9,6 +9,7 @@ # date: Pungenday, the 40th day of Discord in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> +use 5.16.0; use SBO::Lib; use Getopt::Std; use File::Basename; @@ -17,7 +18,7 @@ use warnings FATAL => 'all'; my $self = basename ($0); -sub show_usage { +sub show_usage () { print <<EOF Usage: $self [options] sbo @@ -38,10 +39,10 @@ EOF my %options; getopts ('hvcdripj:R', \%options); -show_usage () and exit (0) if exists $options{h}; -show_version () and exit (0) if exists $options{v}; +show_usage and exit 0 if exists $options{h}; +show_version and exit 0 if exists $options{v}; -show_usage () and exit (0) unless exists $ARGV[0]; +show_usage and exit 0 unless exists $ARGV[0]; # setup any options which do not require arguments my @opts1 = ('c', 'd', 'r', 'i', 'p', 'R'); @@ -55,6 +56,7 @@ for my $opt (@opts2) { unshift @ARGV, "-$opt $options{$opt}" if exists $options{$opt}; } -unshift @ARGV, '/usr/sbin/sboupgrade', '-oN'; -system @ARGV; +system '/usr/sbin/sboupgrade', '-oN', @ARGV; + exit 0; + @@ -12,10 +12,10 @@ # changelog: # .01: initial creation. +use 5.16.0; use SBO::Lib; use File::Basename; use Getopt::Std; -use feature switch; use warnings FATAL => 'all'; use strict; @@ -23,7 +23,7 @@ my %config = %SBO::Lib::config; my $sbo_home = $config{SBO_HOME}; my $self = basename ($0); -sub show_usage { +sub show_usage () { print <<EOF Usage: $self [options|command] @@ -39,25 +39,25 @@ Commands: EOF } -show_usage () and exit (1) unless exists $ARGV[0]; +show_usage and exit 1 unless exists $ARGV[0]; my %options; getopts ('hv', \%options); -show_usage () and exit (0) if exists $options{h}; -show_version () and exit (0) if exists $options{v}; +show_usage and exit 0 if exists $options{h}; +show_version and exit 0 if exists $options{v}; # check for a command and, if found, execute it my $command; if ($ARGV[0] =~ /fetch|update/) { $command = $ARGV[0]; } else { - show_usage () and exit 1; + show_usage and exit 1; } given ($command) { - when ('fetch') { fetch_tree () } - when ('update') { update_tree () } + when ('fetch') {fetch_tree} + when ('update') {update_tree} } exit 0; @@ -9,6 +9,7 @@ # date: Boomtime, the 39th day of Discord in the YOLD 3178 # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> +use 5.16.0; use SBO::Lib; use File::Basename; use Getopt::Std; @@ -19,7 +20,7 @@ use warnings FATAL => 'all'; my %config = %SBO::Lib::config; my $self = basename ($0); -sub show_usage { +sub show_usage () { print <<EOF Usage: $self (options) [package] @@ -45,17 +46,17 @@ EOF my %options; getopts ('hvacdfj:NriopR', \%options); -show_usage () && exit (0) if exists $options{h}; -show_version () && exit (0) if exists $options{v}; +show_usage && exit 0 if exists $options{h}; +show_version && exit 0 if exists $options{v}; my $noclean = exists $options{c} ? 'TRUE' : $config{NOCLEAN}; my $distclean = exists $options{d} ? 'TRUE' : $config{DISTCLEAN}; -my $force = exists $options{f} ? 'TRUE' : 'FALSE'; -my $install_new = exists $options{N} ? 'TRUE' : 'FALSE'; -my $no_readme = exists $options{r} ? 'TRUE' : 'FALSE'; -my $no_install = exists $options{i} ? 'TRUE' : 'FALSE'; -my $only_new = exists $options{o} ? 'TRUE' : 'FALSE'; -my $compat32 = exists $options{p} ? 'TRUE' : 'FALSE'; -my $no_reqs = exists $options{R} ? 'TRUE' : 'FALSE'; +my $force = exists $options{f} ? 1 : 0; +my $install_new = exists $options{N} ? 1 : 0; +my $no_readme = exists $options{r} ? 1 : 0; +my $no_install = exists $options{i} ? 1 : 0; +my $only_new = exists $options{o} ? 1 : 0; +my $compat32 = exists $options{p} ? 1 : 0; +my $no_reqs = exists $options{R} ? 1 : 0; if (exists $options{j}) { die "You have provided an invalid parameter for -j\n" unless @@ -63,103 +64,71 @@ if (exists $options{j}) { } my $jobs = exists $options{j} ? $options{j} : $config{JOBS}; -show_usage () and exit (1) unless exists $ARGV[0]; +show_usage and exit 1 unless exists $ARGV[0]; # if we can't find SLACKBUILDS.TXT in $config{HOME}, prompt to fetch the tree -slackbuilds_or_fetch (); +slackbuilds_or_fetch; # build a hash of locations for each item provided on command line, at the same # time verifying each item is a valid slackbuild my %locations; for my $sbo_name (@ARGV) { - $locations{$sbo_name} = get_sbo_location ($sbo_name); + $locations{$sbo_name} = get_sbo_location $sbo_name; die "Unable to locate $sbo_name in the SlackBuilds.org tree.\n" unless defined $locations{$sbo_name}; } -sub get_readme_path { - exists $_[0] or script_error ('get_readme_path requires an argument.'); +sub get_readme_path ($) { + exists $_[0] or script_error 'get_readme_path requires an argument.'; my $sbo = shift; return $locations{$sbo} .'/README'; } -# this subroutine may be getting a little out of hand. -sub grok_requirements { - exists $_[1] or script_error ('grok_requirements requires two arguments'); - return if $no_reqs eq 'TRUE'; - my ($sbo, $readme) = @_; - my $readme_orig = $readme; - for ($readme) { - # deal with and at end of line - s/and/and /g; - # work around missing period at end of list of requirements (given 2 - # \ns), or no period at end of whole thing. - s/$/./; - # yet another nasty hack. yanh! - s/[Oo]ptional/./g; - s/\n\n/./g; - s/\n//g; - } - return unless my $string = - ($readme =~ /([Tt]his|\Q$sbo\E|)\s*[Rr]equire(s|)(|:)\s+([^\.]+)/)[3]; - for ($string) { - # remove anything in brackets or parens - s/(\s)*\[[^\]]+\](\s)*//g; - s/(\s)*\([^\)]+\)(\s)*//g; - # convert and to comma - s/(\s+|,)and\s+/,/g; - s/,\s+/,/g; - } - my @deps = split /,/, $string; - # if anything has a space, we didn't parse correctly, so remove it, also - # remove anything that's blank or has an equal sign in - my @remove; - for my $key (keys @deps) { - push @remove, $key if ($deps[$key] =~ /[\s=]/ || $deps[$key] =~ /^$/); - } - for my $rem (@remove) { - splice @deps, $rem, 1; - $_-- for @remove; - } - return unless exists $deps[0]; - FIRST: for my $need (@deps) { - # compare against installed slackbuilds - my $tempname = $compat32 eq 'TRUE' ? "$need-compat32" : $need; - my @inst = get_installed_sbos (); - SECOND: for my $key (keys @inst) { - next FIRST if $tempname eq $inst[$key]{name}; - } - print "\n". $readme_orig; - print "\nIt looks like this slackbuild requires $tempname; shall I"; - print " attempt to install it first? [y] "; - if (<STDIN> =~ /^[Yy\n]/) { - my @args = ("/usr/sbin/sboupgrade", '-oN'); - # populate args so that they carry over correctly - push @args, "-c" if exists $options{c}; - push @args, "-d" if exists $options{d}; - push @args, "-j $options{j}" if exists $options{j}; - push @args, "-p" if $compat32 eq 'TRUE'; - push @args, $need; - system (@args) == 0 or - die "Requirement failure, unable to proceed.\n"; +# for a ref to an array of hashes of installed packages, return an array ref +# consisting of just their names +sub get_inst_names ($) { + exists $_[0] or script_error 'get_inst_names requires an argument.'; + my $inst = shift; + my $installed; + push @$installed, $$_{name} for @$inst; + return $installed; +} + +# pull list of requirements, offer to install them +sub grok_requirements ($$$) { + exists $_[1] or script_error 'grok_requirements requires an argument.'; + my ($sbo, $location, $readme) = @_; + my $requires = get_from_info (LOCATION => $location, GET => 'REQUIRES'); + return unless $$requires[0]; + for my $req (@$requires) { + my $inst = get_installed_sbos; + my $inst_names= get_inst_names $inst;; + unless ($req ~~ @$inst_names) { + say $readme; + say "$sbo has $req listed as a requirement."; + print "Shall I attempt to install it first? [y] "; + if (<STDIN> =~ /^[Yy\n]/) { + my @cmd = ('/usr/sbin/sboupgrade', '-oN', $req); + system (@cmd) == 0 or die "$req failed to install.\n"; + } } } - return; + return 1; } # look for any (user|group)add commands in the README -sub grok_user_group { - exists $_[0] or script_error ('grok_user_group requires an argument'); +sub grok_user_group ($) { + exists $_[0] or script_error 'grok_user_group requires an argument'; my $readme = shift; - my @readme_array = split /\n/, $readme; - my @cmds; + my $readme_array = [split /\n/, $readme]; my $cmd_regex = qr/^\s*#\s+((user|group)add.*)/; - push @cmds, ($_ =~ $cmd_regex)[0] for @readme_array; + my @cmds; + push @cmds, ($_ =~ $cmd_regex)[0] for @$readme_array; return unless exists $cmds[0]; - print "\n". $readme ."\n";; + say "\n". $readme; print "\nIt looks like this slackbuild requires the following command(s)"; - print " to be run first:\n"; - print " # $_\n" for @cmds; + say " to be run first:"; + say " # $_" for @cmds; print "Shall I run it/them now? [y] "; if (<STDIN> =~ /^[Yy\n]/) { for my $cmd (@cmds) { @@ -170,73 +139,81 @@ sub grok_user_group { } # see if the README mentions any options -sub grok_options { - exists $_[0] or script_error ('grok_options requires an argument'); +sub grok_options ($) { + exists $_[0] or script_error 'grok_options requires an argument'; my $readme = shift; - return 7 unless $readme =~ /[A-Z]+=[^\s]/; - my @readme_array = split /\n/, $readme; - print "\n". $readme; + return unless $readme =~ /[A-Z]+=[^\s]/; + say "\n". $readme; print "\nIt looks this slackbuilds has options; would you like to set any"; print " when the slackbuild is run? [n] "; if (<STDIN> =~ /^[Yy]/) { - my $ask = sub { + my $ask = sub () { print "\nPlease supply any options here, or enter to skip: "; chomp (my $opts = <STDIN>); - return 7 if $opts =~ /^$/; - return $opts; }; + return if $opts =~ /^$/; + return $opts; + }; my $kv_regex = qr/[A-Z]+=[^\s]+(|\s([A-Z]+=[^\s]+){0,})/; - my $opts = &$ask (); + my $opts = &$ask; FIRST: while ($opts !~ $kv_regex) { warn "Invalid input received.\n"; - $opts = &$ask (); - return 7 if $opts eq "7"; + $opts = &$ask; } return $opts; } - return 7; + return; } -# prompt for the readme, and grok the readme at this time also. -sub readme_prompt { - exists $_[0] or script_error ('readme_prompt requires an argument.'); - my $sbo = shift; - my $fh = open_read (get_readme_path ($sbo) ); +# prompt for the readme +sub readme_prompt ($$) { + exists $_[0] or script_error 'readme_prompt requires an argument.'; + my ($sbo, $location) = @_; + my $fh = open_read (get_readme_path $sbo); my $readme = do {local $/; <$fh>}; close $fh; - grok_requirements ($sbo, $readme); - grok_user_group ($readme); - my $opts = grok_options ($readme); - print "\n". $readme if ($opts eq "7" || ! $opts); - my $name = $compat32 eq 'TRUE' ? "$sbo-compat32" : $sbo; + # check for requirements, useradd/groupadd, options + grok_requirements $sbo, $location, $readme; + grok_user_group $readme; + my $opts = grok_options $readme; + print "\n". $readme unless $opts; + # present the name as -compat32 if appropriate + my $name = $compat32 ? "$sbo-compat32" : $sbo; print "\nProceed with $name? [y]: "; exit 0 unless <STDIN> =~ /^[Yy\n]/; - return $opts if defined $opts; - return 1; + return $opts; } # do the things with the provided sbos - whether upgrades or new installs. sub process_sbos { - exists $_[0] or script_error ('process_sbos requires an argument.'); - my @todo = @_; + exists $_[0] or script_error 'process_sbos requires an argument.'; + my $todo = shift; my @failures; - FIRST: for my $sbo (@todo) { + FIRST: for my $sbo (keys %$todo) { my $opts = 0; - $opts = readme_prompt ($sbo) unless $no_readme eq 'TRUE'; - $opts = 'FALSE' if ($opts =~ /\d+/ || ! $opts); + $opts = readme_prompt $sbo, $$todo{$sbo} unless $no_readme; # switch compat32 on if upgrading a -compat32 - $compat32 = 'TRUE' if $sbo =~ /-compat32$/; + $compat32 = 1 if $sbo =~ /-compat32$/; my ($version, $pkg, $src); - my @sb_args = ($opts, $jobs, $sbo, $locations{$sbo}, $compat32); - eval { ($version, $pkg, $src) = do_slackbuild (@sb_args); }; + eval { ($version, $pkg, $src) = do_slackbuild ( + OPTS => $opts, + JOBS => $jobs, + LOCATION => $locations{$sbo}, + COMPAT32 => $compat32, + ); }; if ($@) { push @failures, $sbo; } else { unless ($distclean eq 'TRUE') { - make_clean ($sbo, $src, $version) if $noclean eq 'FALSE'; + make_clean $sbo, $src, $version unless $noclean eq 'TRUE'; } else { - make_distclean ($sbo, $src, $version, $locations{$sbo}); + make_distclean ( + SBO => $sbo, + SRC => $src, + VERSION => $version, + LOCATION => $locations{$sbo}, + ); } - do_upgradepkg ($pkg) unless $no_install eq 'TRUE'; + do_upgradepkg $pkg unless $no_install; # move package to $config{PKG_DIR} if defined unless ($config{PKG_DIR} eq 'FALSE') { my $dir = $config{PKG_DIR}; @@ -244,7 +221,7 @@ sub process_sbos { mkdir ($dir) or warn "Unable to create $dir\n"; } if (-d $dir) { - move ($pkg, $dir), print "$pkg stored in $dir\n"; + move ($pkg, $dir), say "$pkg stored in $dir"; } else { warn "$pkg left in /tmp\n"; } @@ -256,80 +233,68 @@ sub process_sbos { return @failures; } -my @failed; - -sub print_failures { - if (exists $failed[0]) { - print "Failures:\n"; - print " $_\n" for @failed; +sub print_failures (;@) { + if (exists $_[0]) { + say "Failures:"; + say " $_" for @_; exit 1; } } # deal with any updates prior to any new installs. # no reason to bother if only_new is specified, ie running from sboinstall. -unless ($only_new eq 'TRUE') { - # doesn't matter what's updatable and what's not if force is specified - my @updates unless $force eq 'TRUE'; - unless ($force eq 'TRUE') { - my @updates_array = get_available_updates (); - push @updates, $updates_array[$_]{name} for keys @updates_array; +goto INSTALL_NEW if $only_new; + +# doesn't matter what's updatable and what's not if force is specified +my @updates unless $force; +unless ($force) { + my $updates = get_available_updates; + push @updates, $$_{name} for @$updates; +} +my $todo_upgrade; +# but without force, we only want to update what there are updates for +unless ($force) { + for my $sbo (@ARGV) { + $$todo_upgrade{$sbo} = $locations{$sbo} if $sbo ~~ @updates; } - my @todo_upgrade; - # but without force, we only want to update what there are updates for - unless ($force eq 'TRUE') { - for my $sbo (@ARGV) { - push @todo_upgrade, $sbo if $sbo ~~ @updates; - } - } else { - my @inst = get_installed_sbos (); - FIRST: for my $sbo (@ARGV) { - SECOND: for my $key (keys @inst) { - if ($sbo eq $inst[$key]{name}) { - push @todo_upgrade, $sbo; - last SECOND; - } - } +} else { + my $inst = get_installed_sbos; + my $inst_names= get_inst_names $inst;; + FIRST: for my $sbo (@ARGV) { + if ($sbo ~~ @$inst_names) { + $$todo_upgrade{$sbo} = $locations{$sbo}; } } - @failed = process_sbos (@todo_upgrade) if exists $todo_upgrade[0]; - print_failures () unless $install_new eq 'TRUE'; } +my @failures = process_sbos $todo_upgrade if keys %$todo_upgrade > 0; +print_failures @failures; -if ($install_new eq 'TRUE') { - my @todo_install; - FIRST: for my $sbo (@ARGV) { - my $has = 'FALSE'; - my $name = $compat32 eq 'TRUE' ? "$sbo-compat32" : $sbo; - my @inst = get_installed_sbos (); - SECOND: for my $key (keys @inst) { - $has = 'TRUE', last SECOND if $name eq $inst[$key]{name}; - } - # if compat32 is TRUE, we need to see if the non-compat version exists. - if ($compat32 eq 'TRUE') { - my $has64 = 'FALSE'; - my @inst = get_installed_sbos (); - THIRD: for my $key (keys @inst) { - $has64 = 'TRUE', last THIRD if $sbo eq $inst[$key]{name}; - } - unless ($has64 eq 'TRUE') { - print "\nYou are attempting to install $sbo-compat32, however,"; - print " $sbo is not yet installed. Shall I install it first?"; - print " [y] "; - if (<STDIN> =~ /^[Yy\n]/) { - my @args = ('/usr/sbin/sboupgrade', '-oN', $sbo); - system (@args) == 0 or exit 1; - } else { - print "Please install $sbo\n" and exit 0; - } +INSTALL_NEW: +exit 0 unless $install_new; +my $todo_install; +FIRST: for my $sbo (@ARGV) { + my $name = $compat32 ? "$sbo-compat32" : $sbo; + my $inst = get_installed_sbos; + my $inst_names = get_inst_names $inst;; + warn "$name already installed\n", next FIRST if $name ~~ @$inst_names; + # if compat32 is TRUE, we need to see if the non-compat version exists. + if ($compat32) { + my $inst = get_installed_sbos; + my $inst_names = get_inst_names $inst; + unless ($sbo ~~ @$inst_names) { + print "\nYou are attempting to install $name, however, $sbo is not"; + print " yet installed. Shall I install it first? [y] "; + if (<STDIN> =~ /^[Yy\n]/) { + my @args = ('/usr/sbin/sboupgrade', '-oN', $sbo); + system (@args) == 0 or exit 1; + } else { + warn "Please install $sbo\n" and exit 0; } } - $has eq 'TRUE' ? warn "$name already installed.\n" : - push @todo_install, $sbo; } - @failed = process_sbos (@todo_install) if exists $todo_install[0]; - print_failures (); + $$todo_install{$sbo} = $locations{$sbo}; } +@failures = process_sbos $todo_install if keys %$todo_install > 0; +print_failures @failures; -exit 1 if exists $failed[0]; exit 0; diff --git a/t/SBO/Lib.pm b/t/SBO/Lib.pm new file mode 100644 index 0000000..398e6a3 --- /dev/null +++ b/t/SBO/Lib.pm @@ -0,0 +1,668 @@ +#!/usr/bin/env perl +# +# vim: set ts=4:noet +# +# Lib.pm +# shared functions for the sbo_ scripts. +# +# author: Jacob Pipkin <j@dawnrazor.net> +# date: Setting Orange, the 37th day of Discord in the YOLD 3178 +# license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> + +use 5.16.0; +use warnings FATAL => 'all'; +use strict; + +package SBO::Lib 1.0; +my $version = "1.0"; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(get_slack_version chk_slackbuilds_txt check_home rsync_sbo_tree get_sbo_from_loc get_sbo_version get_download_info get_arch get_sbo_downloads get_filename_from_link compute_md5sum compare_md5s verify_distfile get_distfile get_symlink_from_filename check_x32 check_multilib rewrite_slackbuild revert_slackbuild check_distfiles create_symlinks grok_temp_file get_src_dir get_pkg_name perform_sbo do_convertpkg + script_error + open_fh + open_read + show_version + slackbuilds_or_fetch + fetch_tree + update_tree + get_installed_sbos + get_available_updates + do_slackbuild + make_clean + make_distclean + do_upgradepkg + get_sbo_location + get_from_info + get_tmp_fn +); + +#$< == 0 or die "This script requires root privileges.\n"; + +use Tie::File; +use Sort::Versions; +use Digest::MD5; +use File::Copy; +use File::Path qw(make_path remove_tree); +use Fcntl; +use File::Find; +use File::Temp qw(tempdir tempfile); +use Data::Dumper; +use Fcntl qw(F_SETFD F_GETFD); + +our $tempdir = tempdir (CLEANUP => 1); + +# subroutine for throwing internal script errors +sub script_error (;$) { + exists $_[0] ? die "A fatal script error has occured:\n$_[0]\nExiting.\n" + : die "A fatal script error has occured. Exiting.\n"; +} + +# sub for opening files, second arg is like '<','>', etc +sub open_fh ($$) { + exists $_[1] or script_error 'open_fh requires two arguments'; + -f $_[0] or script_error 'open_fh first argument not a file'; + my ($file, $op) = @_; + open my $fh, $op, $file or die "Unable to open $file.\n"; + return $fh; +} + +sub open_read ($) { + return open_fh shift, '<'; +} + +# pull in configuration, set sane defaults, etc. +our $conf_dir = '/etc/sbotools'; +our $conf_file = "$conf_dir/sbotools.conf"; +our %config = ( + NOCLEAN => 'FALSE', + DISTCLEAN => 'FALSE', + JOBS => 'FALSE', + PKG_DIR => 'FALSE', + SBO_HOME => 'FALSE', +); + +# if the conf file exists, pull all the $key=$value pairs into a hash +my %conf_values; +if (-f $conf_file) { + my $fh = open_read $conf_file; + my $text = do {local $/; <$fh>}; + %conf_values = $text =~ /^(\w+)=(.*)$/mg; + close $fh; +} + +for my $key (keys %config) { + $config{$key} = $conf_values{$key} if exists $conf_values{$key}; +} +$config{JOBS} = 'FALSE' unless $config{JOBS} =~ /^\d+$/; +$config{SBO_HOME} = '/usr/sbo' if $config{SBO_HOME} eq 'FALSE'; + +# some stuff we'll need later. +my $distfiles = "$config{SBO_HOME}/distfiles"; +my $slackbuilds_txt = "$config{SBO_HOME}/SLACKBUILDS.TXT"; +my $name_regex = '\ASLACKBUILD\s+NAME:\s+'; + +sub show_version () { + say "sbotools version $version"; + say 'licensed under the WTFPL'; + say '<http://sam.zoy.org/wtfpl/COPYING>'; +} + +# %supported maps what's in /etc/slackware-version to what's at SBo +# which is now not needed since this version drops support < 14.0 +# but it's already future-proofed, so leave it. +sub get_slack_version () { + my %supported = ('14.0' => '14.0'); + my $fh = open_read '/etc/slackware-version'; + chomp (my $line = <$fh>); + close $fh; + my $version = ($line =~ /\s+(\d+[^\s]+)$/)[0]; + die "Unsupported Slackware version: $version\n" + unless $version ~~ %supported; + return $supported{$version}; +} + +# does the SLACKBUILDS.TXT file exist in the sbo tree? +sub chk_slackbuilds_txt () { + return -f $slackbuilds_txt ? 1 : 0; +} + +# check for the validity of new $config{SBO_HOME} +sub check_home () { + my $sbo_home = $config{SBO_HOME}; + if (-d $sbo_home) { + opendir (my $home_handle, $sbo_home); + FIRST: while (readdir $home_handle) { + next FIRST if /^\.[\.]{0,1}$/; + die "$sbo_home exists and is not empty. Exiting.\n"; + } + } else { + make_path ($sbo_home) or die "Unable to create $sbo_home.\n"; + } +} + +# rsync the sbo tree from slackbuilds.org to $config{SBO_HOME} +sub rsync_sbo_tree () { + my $slk_version = get_slack_version; + my @arg = ('rsync', '-a', '--exclude=*.tar.gz', '--exclude=*.tar.gz.asc'); + push @arg, "rsync://slackbuilds.org/slackbuilds/$slk_version/*"; + my $out = system @arg, $config{SBO_HOME}; + say 'Finished.' and return $out; +} + +# wrappers for differing checks and output +sub fetch_tree () { + check_home; + say 'Pulling SlackBuilds tree...'; + rsync_sbo_tree, return $?; +} + +sub update_tree () { + fetch_tree, return unless chk_slackbuilds_txt; + say 'Updating SlackBuilds tree...'; + rsync_sbo_tree, return $?; +} + +# if the SLACKBUILDS.TXT is not in $config{SBO_HOME}, we assume the tree has +# not been populated there; prompt the user to automagickally pull the tree. +sub slackbuilds_or_fetch () { + unless (chk_slackbuilds_txt) { + say 'It looks like you haven\'t run "sbosnap fetch" yet.'; + print 'Would you like me to do this now? [y] '; + <STDIN> =~ /^[Yy\n]/ ? fetch_tree : + die "Please run \"sbosnap fetch\"\n"; + } + return 1; +} + +# pull an array of hashes, each hash containing the name and version of an sbo +# currently installed. +sub get_installed_sbos () { + my @installed; + # $1 == name, $2 == version + my $regex = qr#/([^/]+)-([^-]+)-[^-]+-[^-]+$#; + for my $path (</var/log/packages/*_SBo>) { + my ($name, $version) = ($path =~ $regex)[0,1]; + push @installed, {name => $name, version => $version}; + } + return \@installed; +} + +# search the SLACKBUILDS.TXT for a given sbo's directory +sub get_sbo_location ($) { + exists $_[0] or script_error 'get_sbo_location requires an argument.'; + my $sbo = shift; + my $regex = qr#LOCATION:\s+\.(/[^/]+/$sbo)$#; + my $fh = open_read $slackbuilds_txt; + while (my $line = <$fh>) { + if (my $loc = ($line =~ $regex)[0]) { + return "$config{SBO_HOME}$loc"; + } + } + return; +} + +# pull the sbo name from a $location: $config{SBO_HOME}/system/wine, etc. +sub get_sbo_from_loc ($) { + exists $_[0] or script_error 'get_sbo_from_loc requires an argument.'; + return (shift =~ qr#/([^/]+)$#)[0]; +} + +# pull piece(s) of data, GET, from the $sbo.info file under LOCATION. +sub get_from_info (%) { + my %args = ( + LOCATION => '', + GET => '', + @_ + ); + unless ($args{LOCATION} && $args{GET}) { + script_error 'get_from_info requires LOCATION and GET.'; + } + state $vars = {PRGNAM => ['']}; + my $sbo = get_sbo_from_loc $args{LOCATION}; + return $$vars{$args{GET}} if $$vars{PRGNAM}[0] eq $sbo; + # if we're here, we haven't read in the .info file yet. + my $fh = open_read "$args{LOCATION}/$sbo.info"; + # suck it all in, clean it all up, stuff it all in $vars. + my $contents = do {local $/; <$fh>}; + $contents =~ s/("|\\\n)//g; + $vars = {$contents =~ /^(\w+)=(.*)$/mg}; + # fill the hash with array refs - even for single values, + # since consistency here is a lot easier than sorting it out later + for my $key (keys %$vars) { + if ($$vars{$key} =~ /\s/) { + my @array = split ' ', $$vars{$key}; + $$vars{$key} = \@array; + } else { + $$vars{$key} = [$$vars{$key}]; + } + } + return exists $$vars{$args{GET}} ? $$vars{$args{GET}} : 0; +} + +# find the version in the tree for a given sbo (provided a location) +sub get_sbo_version ($) { + exists $_[0] or script_error 'get_sbo_version requires an argument.'; + my $version = get_from_info (LOCATION => shift, GET => 'VERSION'); + return $$version[0] ? $$version[0] : 0; +} + +# for each installed sbo, find out whether or not the version in the tree is +# newer, and compile an array of hashes containing those which are +sub get_available_updates () { + my @updates; + my $pkg_list = get_installed_sbos; + FIRST: for my $key (keys @$pkg_list) { + my $location = get_sbo_location $$pkg_list[$key]{name}; + # if we can't find a location, assume invalid and skip + next FIRST unless defined $location; + my $version = get_sbo_version $location; + if (versioncmp ($version, $$pkg_list[$key]{version}) == 1) { + push @updates, { + name => $$pkg_list[$key]{name}, + installed => $$pkg_list[$key]{version}, + update => $version + }; + } + } + return \@updates; +} + +# get downloads and md5sums from an sbo's .info file, first +# checking for x86_64-specific info if we are told to +sub get_download_info (%) { + my %args = ( + LOCATION => 0, + X64 => 1, + @_ + ); + $args{LOCATION} or script_error 'get_download_info requires LOCATION.'; + my ($get, $downs, $md5s, %return); + $get = ($args{X64} ? 'DOWNLOAD_x86_64' : 'DOWNLOAD'); + $downs = get_from_info (LOCATION => $args{LOCATION}, GET => $get); + # did we get nothing back, or UNSUPPORTED/UNTESTED? + if ($args{X64}) { + my $nothing; + if (! $$downs[0]) { + $nothing = 1; + } elsif ($$downs[0] =~ qr/^UN(SUPPOR|TES)TED$/) { + $nothing = 1; + } + if ($nothing) { + $args{X64} = 0; + $downs = get_from_info (LOCATION => $args{LOCATION}, + GET => 'DOWNLOAD'); + } + } + # if we still don't have any links, something is really wrong. + return unless $$downs[0]; + # grab the md5s and build a hash + $get = $args{X64} ? 'MD5SUM_x86_64' : 'MD5SUM'; + $md5s = get_from_info (LOCATION => $args{LOCATION}, GET => $get); + return unless $$md5s[0]; + $return{$$downs[$_]} = $$md5s[$_] for (keys @$downs); + return %return; +} + +sub get_arch () { + chomp (my $arch = `uname -m`); + return $arch; +} + +# TODO: should probably combine this with get_download_info +sub get_sbo_downloads (%) { + my %args = ( + LOCATION => '', + 32 => 0, + @_ + ); + $args{LOCATION} or script_error 'get_sbo_downloads requires LOCATION.'; + my $location = $args{LOCATION}; + -d $location or script_error 'get_sbo_downloads given a non-directory.'; + my $arch = get_arch; + my %dl_info; + if ($arch eq 'x86_64') { + %dl_info = get_download_info (LOCATION => $location) unless $args{32}; + } + unless (keys %dl_info > 0) { + %dl_info = get_download_info (LOCATION => $location, X64 => 0); + } + return %dl_info; +} + +# given a link, grab the filename from the end of it +sub get_filename_from_link ($) { + exists $_[0] or script_error 'get_filename_from_link requires an argument'; + return "$distfiles/". (shift =~ qr#/([^/]+)$#)[0]; +} + +# for a given file, computer its md5sum +sub compute_md5sum ($) { + -f $_[0] or script_error 'compute_md5sum requires a file argument.'; + my $fh = open_read shift; + my $md5 = Digest::MD5->new; + $md5->addfile ($fh); + my $md5sum = $md5->hexdigest; + close $fh; + return $md5sum; +} + +sub compare_md5s ($$) { + exists $_[1] or script_error 'compare_md5s requires two arguments.'; + my ($first, $second) = @_; + return $first eq $second ? 1 : 0; +} + +# for a given distfile, see whether or not it exists, and if so, if its md5sum +# matches the sbo's .info file +sub verify_distfile ($$) { + exists $_[1] or script_error 'check_distfile requires two arguments.'; + my ($link, $info_md5sum) = @_; + my $filename = get_filename_from_link $link; + return unless -d $distfiles; + return unless -f $filename; + my $md5sum = compute_md5sum $filename; + return compare_md5s $info_md5sum, $md5sum; +} + +# for a given distfile, attempt to retrieve it and, if successful, check its +# md5sum against that in the sbo's .info file +sub get_distfile ($$) { + exists $_[1] or script_error 'get_distfile requires an argument'; + my ($link, $exp_md5) = @_; + my $filename = get_filename_from_link $link; + mkdir $distfiles unless -d $distfiles; + chdir $distfiles; + system ("wget --no-check-certificate $link") == 0 or + die "Unable to wget $link\n"; + my $md5sum = compute_md5sum $filename; + # can't do anything if the link in the .info doesn't lead to a good d/l + compare_md5s $md5sum, $exp_md5 or die "md5sum failure for $filename.\n"; + return 1; +} + +# for a given distfile, figure out what the full path to its symlink will be +sub get_symlink_from_filename ($$) { + exists $_[1] or script_error + 'get_symlink_from_filename requires two arguments'; + -f $_[0] or script_error + 'get_symlink_from_filename first argument is not a file'; + my ($filename, $location) = @_; + return "$location/". ($filename =~ qr#/([^/]+)$#)[0]; +} + +# determine whether or not a given sbo is 32-bit only +sub check_x32 ($) { + exists $_[0] or script_error 'check_x32 requires an argument.'; + my $dl = get_from_info (LOCATION => shift, GET => 'DOWNLOAD_x86_64'); + return $$dl[0] =~ /UN(SUPPOR|TES)TED/ ? 1 : 0; +} + +# can't do 32-bit on x86_64 without this file, so we'll use it as the test to +# to determine whether or not an x86_64 system is setup for multilib +sub check_multilib () { + return 1 if -f '/etc/profile.d/32dev.sh'; + return; +} + +# make a backup of the existent SlackBuild, and rewrite the original as needed +sub rewrite_slackbuild ($$%) { + exists $_[1] or script_error 'rewrite_slackbuild requires two arguments.'; + my ($slackbuild, $tempfn, %changes) = @_; + copy ($slackbuild, "$slackbuild.orig") or + die "Unable to backup $slackbuild to $slackbuild.orig\n"; + my $tar_regex = qr/(un|)tar .*$/; + my $makepkg_regex = qr/makepkg/; + my $libdir_regex = qr/^\s*LIBDIRSUFFIX="64"\s*$/; + my $make_regex = qr/^\s*make(| \Q||\E exit 1)$/; + my $arch_regex = qr/\$VERSION-\$ARCH-\$BUILD/; + # tie the slackbuild, because this is the easiest way to handle this. + tie my @sb_file, 'Tie::File', $slackbuild; + for my $line (@sb_file) { + # get the output of the tar and makepkg commands. hope like hell that v + # is specified among tar's arguments + if ($line =~ $tar_regex || $line =~ $makepkg_regex) { + $line = "$line | tee -a $tempfn"; + } + # then check for and apply any other %changes + if (exists $changes{libdirsuffix}) { + $line =~ s/64/$changes{libdirsuffix}/ if $line =~ $libdir_regex; + } + if (exists $changes{make}) { + $line =~ s/make/make $changes{make}/ if $line =~ $make_regex; + } + if (exists $changes{arch_out}) { + $line =~ s/\$ARCH/$changes{arch_out}/ if $line =~ $arch_regex; + } + } + untie @sb_file; + return 1; +} + +# move a backed-up .SlackBuild file back into place +sub revert_slackbuild ($) { + exists $_[0] or script_error 'revert_slackbuild requires an argument'; + my $slackbuild = shift; + if (-f "$slackbuild.orig") { + unlink $slackbuild if -f $slackbuild; + rename ("$slackbuild.orig", $slackbuild); + } + return 1; +} + +# for each $download, see if we have it, and if the copy we have is good, +# otherwise download a new copy +sub check_distfiles (%) { + exists $_[0] or script_error 'check_distfiles requires an argument.'; + my %dists = @_; + for my $link (keys %dists) { + my $md5sum = $dists{$link}; + unless (verify_distfile $link, $md5sum) { + die unless get_distfile $link, $md5sum; + } + } + return 1; +} + +# given a location and a list of download links, assemble a list of symlinks, +# and create them. +sub create_symlinks ($%) { + exists $_[1] or script_error 'create_symlinks requires two arguments.'; + my ($location, %downloads) = @_; + my @symlinks; + for my $link (keys %downloads) { + my $filename = get_filename_from_link $link; + my $symlink = get_symlink_from_filename $filename, $location; + push @symlinks, $symlink; + symlink $filename, $symlink; + } + return @symlinks; +} + +# pull the untarred source directory or created package name from the temp +# file (the one we tee'd to) +sub grok_temp_file (%) { + my %args = ( + FH => '', + REGEX => '', + CAPTURE => 0, + @_ + ); + unless ($args{FH} && $args{REGEX}) { + script_error 'grok_temp_file requires two arguments'; + } + my $fh = $args{FH}; + seek $fh, 0, 0; + my $out; + FIRST: while (my $line = <$fh>) { + if ($line =~ $args{REGEX}) { + $out = ($line =~ $args{REGEX})[$args{CAPTURE}]; + last FIRST; + } + } +# close $fh; + return $out; +} + +# wrappers around grok_temp_file +sub get_src_dir ($) { + exists $_[0] or script_error 'get_src_dir requires an argument'; + return grok_temp_file (FH => shift, REGEX => qr#^([^/]+)/#); +} + +sub get_pkg_name ($) { + exists $_[0] or script_error 'get_pkg_name requires an argument'; + return grok_temp_file (FH => shift, + REGEX => qr/^Slackware\s+package\s+([^\s]+)\s+created\.$/); +} + +sub get_tmp_fn ($) { + exists $_[0] or script_error 'get_tmp_fn requires an argument.'; + my $fh = shift; + fcntl ($fh, F_SETFD, 0) or die "no unset exec-close thingy\n"; + return "/dev/fd/". fileno $fh; +} + +# prep and run .SlackBuild +sub perform_sbo (%) { + my %args = ( + OPTS => 0, + JOBS => 0, + LOCATION => '', + ARCH => '', + C32 => 0, + X32 => 0, + @_ + ); + unless ($args{LOCATION} && $args{ARCH}) { + script_error 'perform_sbo requires LOCATION and ARCH.'; + } + my $location = $args{LOCATION}; + my $sbo = get_sbo_from_loc $location; + my ($cmd, %changes); + # figure out any changes we need to make to the .SlackBuild + $changes{make} = "-j $args{JOBS}" if $args{JOBS}; + if ($args{ARCH} eq 'x86_64' and ($args{C32} || $args{X32})) { + if ($args{C32}) { + $changes{libdirsuffix} = ''; + } elsif ($args{X32}) { + $changes{arch_out} = 'i486'; + } + $cmd = ". /etc/profile.d/32dev.sh &&"; + } + $cmd .= "/bin/sh $location/$sbo.SlackBuild"; + $cmd = "$args{OPTS} $cmd" if $args{OPTS}; + my $tempfh = tempfile (DIR => $tempdir); + my $fn = get_tmp_fn $tempfh; + rewrite_slackbuild "$location/$sbo.SlackBuild", $fn, %changes; + chdir $location, my $out = system $cmd; + revert_slackbuild "$location/$sbo.SlackBuild"; + die unless $out == 0; + my $pkg = get_pkg_name $tempfh; + my $src = get_src_dir $tempfh; + return $pkg, $src; +} + +# run convertpkg on a package to turn it into a -compat32 thing +sub do_convertpkg ($) { + exists $_[0] or script_error 'do_convertpkg requires an argument.'; + my $pkg = shift; + my $tempfh = tempfile (DIR => $tempdir); + my $fn = get_tmp_fn $tempfh; + my $cmd = "/usr/sbin/convertpkg-compat32 -i $pkg -d /tmp | tee $fn"; + system ($cmd) == 0 or die; + unlink $pkg; + return get_pkg_name $tempfh; +} + +# "public interface", sort of thing. +sub do_slackbuild (%) { + my %args = ( + OPTS => 0, + JOBS => 0, + LOCATION => '', + COMPAT32 => 0, + @_ + ); + $args{LOCATION} or script_error 'do_slackbuild requires LOCATION.'; + my $location = $args{LOCATION}; + my $sbo = get_sbo_from_loc $location; + my $arch = get_arch; + my $multi = check_multilib; + my $version = get_sbo_version $location; + my $x32; + # ensure x32 stuff is set correctly, or that we're setup for it + if ($args{COMPAT32}) { + die "compat32 only works on x86_64.\n" unless $arch eq 'x86_64'; + die "compat32 requires multilib.\n" unless $multi; + die "compat32 requires /usr/sbin/convertpkg-compat32.\n" + unless -f '/usr/sbin/convertpkg-compat32'; + } else { + if ($arch eq 'x86_64') { + $x32 = check_x32 $args{LOCATION}; + if ($x32 && ! $multi) { + die "$sbo is 32-bit which requires multilib on x86_64.\n"; + } + } + } + # get a hash of downloads and md5sums, ensure we have 'em, symlink 'em + my %downloads = get_sbo_downloads ( + LOCATION => $location, + 32 => $args{COMPAT32} + ); + check_distfiles %downloads; + my @symlinks = create_symlinks $args{LOCATION}, %downloads; + # setup and run the .SlackBuild itself + my ($pkg, $src) = perform_sbo ( + OPTS => $args{OPTS}, + JOBS => $args{JOBS}, + LOCATION => $location, + ARCH => $arch, + C32 => $args{COMPAT32}, + X32 => $x32, + ); + do_convertpkg $pkg if $args{COMPAT32}; + unlink $_ for @symlinks; + return $version, $pkg, $src; +} + +# remove work directories (source and packaging dirs under /tmp/SBo) +sub make_clean ($$$) { + exists $_[2] or script_error 'make_clean requires three arguments.'; + my ($sbo, $src, $version) = @_; + say "Cleaning for $sbo-$version..."; + my $tmpsbo = "/tmp/SBo"; + remove_tree ("$tmpsbo/$src") if -d "$tmpsbo/$src"; + remove_tree ("$tmpsbo/package-$sbo") if -d "$tmpsbo/package-$sbo"; + return 1; +} + +# remove distfiles +sub make_distclean (%) { + my %args = ( + SRC => '', + VERSION => '', + LOCATION => '', + @_ + ); + unless ($args{SRC} && $args{VERSION} && $args{LOCATION}) { + script_error 'make_distclean requires four arguments.'; + } + my $sbo = get_sbo_from_loc $args{LOCATION}; + make_clean $sbo, $args{SRC}, $args{VERSION}; + say "Distcleaning for $sbo-$args{VERSION}..."; + # remove any distfiles for this particular SBo. + my %downloads = get_sbo_downloads (LOCATION => $args{LOCATION}); + for my $key (keys %downloads) { + my $filename = get_filename_from_link $key; + unlink $filename if -f $filename; + } + return 1; +} + +# run upgradepkg for a created package +sub do_upgradepkg ($) { + exists $_[0] or script_error 'do_upgradepkg requires an argument.'; + system ('/sbin/upgradepkg', '--reinstall', '--install-new', shift); + return 1; +} diff --git a/t/SBO/Lib.pm~ b/t/SBO/Lib.pm~ new file mode 100644 index 0000000..be29986 --- /dev/null +++ b/t/SBO/Lib.pm~ @@ -0,0 +1,643 @@ +#!/usr/bin/env perl +# +# vim: set ts=4:noet +# +# Lib.pm +# shared functions for the sbo_ scripts. +# +# author: Jacob Pipkin <j@dawnrazor.net> +# date: Setting Orange, the 37th day of Discord in the YOLD 3178 +# license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> + +use 5.16.0; +use warnings FATAL => 'all'; +use strict; + +package SBO::Lib 1.0; +my $version = "1.0"; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(get_slack_version chk_slackbuilds_txt check_home rsync_sbo_tree get_sbo_from_loc get_sbo_version get_download_info get_arch get_sbo_downloads get_filename_from_link compute_md5sum compare_md5s check_distfile get_distfile get_symlink_from_filename check_x32 check_multilib rewrite_slackbuild revert_slackbuild create_symlinks grok_temp_file get_src_dir get_pkg_name perform_sbo + script_error + open_fh + open_read + show_version + slackbuilds_or_fetch + fetch_tree + update_tree + get_installed_sbos + get_available_updates + do_slackbuild + make_clean + make_distclean + do_upgradepkg + get_sbo_location + get_from_info +); + +#$< == 0 or die "This script requires root privileges.\n"; + +use Tie::File; +use Sort::Versions; +use Digest::MD5; +use File::Copy; +use File::Path qw(make_path remove_tree); +use Fcntl; +use File::Find; +use File::Temp qw(tempdir tempfile); +use Data::Dumper; + +our $tempdir = tempdir (CLEANUP => 1); + +# subroutine for throwing internal script errors +sub script_error (;$) { + exists $_[0] ? die "A fatal script error has occured:\n$_[0]\nExiting.\n" + : die "A fatal script error has occured. Exiting.\n"; +} + +# sub for opening files, second arg is like '<','>', etc +sub open_fh ($$) { + exists $_[1] or script_error 'open_fh requires two arguments'; + -f $_[0] or script_error 'open_fh first argument not a file'; + my ($file, $op) = @_; + open my $fh, $op, $file or die "Unable to open $file.\n"; + return $fh; +} + +sub open_read ($) { + return open_fh shift, '<'; +} + +# pull in configuration, set sane defaults, etc. +our $conf_dir = '/etc/sbotools'; +our $conf_file = "$conf_dir/sbotools.conf"; +our %config = ( + NOCLEAN => 'FALSE', + DISTCLEAN => 'FALSE', + JOBS => 'FALSE', + PKG_DIR => 'FALSE', + SBO_HOME => 'FALSE', +); + +# if the conf file exists, pull all the $key=$value pairs into a hash +my %conf_values; +if (-f $conf_file) { + my $fh = open_read $conf_file; + my $text = do {local $/; <$fh>}; + %conf_values = $text =~ /^(\w+)=(.*)$/mg; + close $fh; +} + +for my $key (keys %config) { + $config{$key} = $conf_values{$key} if exists $conf_values{$key}; +} +$config{JOBS} = 'FALSE' unless $config{JOBS} =~ /^\d+$/; +$config{SBO_HOME} = '/usr/sbo' if $config{SBO_HOME} eq 'FALSE'; + +# some stuff we'll need later. +my $distfiles = "$config{SBO_HOME}/distfiles"; +my $slackbuilds_txt = "$config{SBO_HOME}/SLACKBUILDS.TXT"; +my $name_regex = '\ASLACKBUILD\s+NAME:\s+'; + +sub show_version () { + print "sbotools version $version\n"; + print "licensed under the WTFPL\n"; + print "<http://sam.zoy.org/wtfpl/COPYING>\n"; +} + +# %supported maps what's in /etc/slackware-version to what's at SBo +# which is now not needed since this version drops support < 14.0 +# but it's already future-proofed, so leave it. +sub get_slack_version () { + my %supported = ('14.0' => '14.0'); + my $fh = open_read '/etc/slackware-version'; + chomp (my $line = <$fh>); + close $fh; + my $version = ($line =~ /\s+(\d+[^\s]+)$/)[0]; + die "Unsupported Slackware version: $version\n" + unless $version ~~ %supported; + return $supported{$version}; +} + +# does the SLACKBUILDS.TXT file exist in the sbo tree? +sub chk_slackbuilds_txt () { + return -f $slackbuilds_txt ? 1 : 0; +} + +# check for the validity of new $config{SBO_HOME} +sub check_home () { + my $sbo_home = $config{SBO_HOME}; + if (-d $sbo_home) { + opendir (my $home_handle, $sbo_home); + FIRST: while (readdir $home_handle) { + next FIRST if /^\.[\.]{0,1}$/; + die "$sbo_home exists and is not empty. Exiting.\n"; + } + } else { + make_path ($sbo_home) or die "Unable to create $sbo_home.\n"; + } +} + +# rsync the sbo tree from slackbuilds.org to $config{SBO_HOME} +sub rsync_sbo_tree () { + my $slk_version = get_slack_version; + my @arg = ('rsync', '-a', '--exclude=*.tar.gz', '--exclude=*.tar.gz.asc'); + push @arg, "rsync://slackbuilds.org/slackbuilds/$slk_version/*"; + my $out = system @arg, $config{SBO_HOME}; + print "Finished.\n" and return $out; +} + +# wrappers for differing checks and output +sub fetch_tree () { + check_home; + print "Pulling SlackBuilds tree...\n"; + rsync_sbo_tree, return $?; +} + +sub update_tree () { + fetch_tree, return unless chk_slackbuilds_txt; + print "Updating SlackBuilds tree...\n"; + rsync_sbo_tree, return $?; +} + +# if the SLACKBUILDS.TXT is not in $config{SBO_HOME}, we assume the tree has +# not been populated there; prompt the user to automagickally pull the tree. +sub slackbuilds_or_fetch () { + unless (chk_slackbuilds_txt) { + print "It looks like you haven't run \"sbosnap fetch\" yet.\n"; + print "Would you like me to do this now? [y] "; + <STDIN> =~ /^[Yy\n]/ ? fetch_tree : + die "Please run \"sbosnap fetch\"\n"; + } + return 1; +} + +# pull an array of hashes, each hash containing the name and version of an sbo +# currently installed. +sub get_installed_sbos () { + my @installed; + # $1 == name, $2 == version + my $regex = qr#/([^/]+)-([^-]+)-[^-]+-[^-]+$#; + for my $path (</var/log/packages/*_SBo>) { + my ($name, $version) = ($path =~ $regex)[0,1]; + push @installed, {name => $name, version => $version}; + } + return \@installed; +} + +# search the SLACKBUILDS.TXT for a given sbo's directory +sub get_sbo_location ($) { + exists $_[0] or script_error 'get_sbo_location requires an argument.'; + my $sbo = shift; + my $regex = qr#LOCATION:\s+\.(/[^/]+/$sbo)$#; + my $fh = open_read $slackbuilds_txt; + while (my $line = <$fh>) { + if (my $loc = ($line =~ $regex)[0]) { + return "$config{SBO_HOME}$loc"; + } + } + return; +} + +# pull the sbo name from a $location: $config{SBO_HOME}/system/wine, etc. +sub get_sbo_from_loc ($) { + exists $_[0] or script_error 'get_sbo_from_loc requires an argument.'; + return (shift =~ qr#/([^/]+)$#)[0]; +} + +# pull piece(s) of data, GET, from the $sbo.info file under LOCATION. +sub get_from_info { + warn " * * * * * * * * * * in get_from_info sub * * * * * * * * * *\n"; + my %args = ( + LOCATION => '', + GET => '', + @_ + ); + unless ($args{LOCATION} && $args{GET}) { + script_error 'get_from_info requires LOCATION and GET.'; + } + state $vars = {PKGNAM => ['']}; + my $sbo = get_sbo_from_loc $args{LOCATION}; + print Dumper ($vars); + return $$vars{$args{GET}} if $$vars{PKGNAM}[0] eq $sbo; + # if we haven't read in the .info file yet, do so now. + warn " * * * * * * * * * * parsing $sbo.info file * * * * * * * * * *\n"; + my $fh = open_read "$args{LOCATION}/$sbo.info"; + # suck it all in and join up the \ lines... + my $contents = do {local $/; <$fh>}; + $contents =~ s/("|\\\n)//g; + my %tmp = $contents =~ /^(\w+)=(.*)$/mg; + $vars = \%tmp; + # fill the hash with array refs - even for single values, + # since consistency here is a lot easier than sorting it out later + for my $key (keys %$vars) { + if ($$vars{$key} =~ /\s/) { + my @array = split ' ', $$vars{$key}; + $$vars{$key} = \@array; + } else { + $$vars{$key} = [$$vars{$key}]; + } + } + return $$vars{$args{GET}}; +} + +# find the version in the tree for a given sbo (provided a location) +sub get_sbo_version ($) { + exists $_[0] or script_error 'get_sbo_version requires an argument.'; + my $version = get_from_info (LOCATION => shift, GET => 'VERSION'); + return $$version[0] ? $$version[0] : 0; +} + +# for each installed sbo, find out whether or not the version in the tree is +# newer, and compile an array of hashes containing those which are +sub get_available_updates () { + my @updates; + my $pkg_list = get_installed_sbos; + FIRST: for my $key (keys @$pkg_list) { + my $location = get_sbo_location $$pkg_list[$key]{name}; + # if we can't find a location, assume invalid and skip + next FIRST unless defined $location; + my $version = get_sbo_version $location; + if (versioncmp ($version, $$pkg_list[$key]{version}) == 1) { + push @updates, { + name => $$pkg_list[$key]{name}, + installed => $$pkg_list[$key]{version}, + update => $version + }; + } + } + return \@updates; +} + +# get downloads and md5sums from an sbo's .info file, first +# checking for x86_64-specific info if we are told to +sub get_download_info { + my %args = ( + LOCATION => 0, + X64 => 1, + @_ + ); + $args{LOCATION} or script_error 'get_download_info requires LOCATION.'; + my ($get, $downs, $md5s, %return); + $get = ($args{X64} ? 'DOWNLOAD_x86_64' : 'DOWNLOAD'); + $downs = get_from_info (LOCATION => $args{LOCATION}, GET => $get); + # did we get nothing back, or UNSUPPORTED/UNTESTED? + if ($args{X64}) { + my $nothing; + if (! $$downs[0]) { + $nothing = 1; + } elsif ($$downs[0] =~ qr/^UN(SUPPOR|TES)TED$/) { + $nothing = 1; + } + if ($nothing) { + $args{X64} = 0; + $downs = get_from_info (LOCATION => $args{LOCATION}, + GET => 'DOWNLOAD'); + } + } + # if we still don't have any links, something is really wrong. + return unless $$downs[0]; + # grab the md5s and build a hash + $get = $args{X64} ? 'MD5SUM_x86_64' : 'MD5SUM'; + $md5s = get_from_info (LOCATION => $args{LOCATION}, GET => $get); + return unless $$md5s[0]; + $return{$$downs[$_]} = $$md5s[$_] for (keys @$downs); + return %return; +} + +sub get_arch () { + chomp (my $arch = `uname -m`); + return $arch; +} + +# TODO: should probably combine this with get_download_info +sub get_sbo_downloads { + my %args = ( + LOCATION => '', + 32 => 0, + @_ + ); + $args{LOCATION} or script_error 'get_sbo_downloads requires LOCATION.'; + my $location = $args{LOCATION}; + -d $location or script_error 'get_sbo_downloads given a non-directory.'; + my $arch = get_arch; + my %dl_info; + if ($arch eq 'x86_64') { + %dl_info = get_download_info (LOCATION => $location) unless $args{32}; + } + unless (keys %dl_info > 0) { + %dl_info = get_download_info (LOCATION => $location, X64 => 0); + } + return %dl_info; +} + +# given a link, grab the filename from the end of it +sub get_filename_from_link ($) { + exists $_[0] or script_error 'get_filename_from_link requires an argument'; + return "$distfiles/". (shift =~ qr#/([^/]+)$#)[0]; +} + +# for a given file, computer its md5sum +sub compute_md5sum ($) { + -f $_[0] or script_error 'compute_md5sum requires a file argument.'; + my $fh = open_read shift; + my $md5 = Digest::MD5->new; + $md5->addfile ($fh); + my $md5sum = $md5->hexdigest; + close $fh; + return $md5sum; +} + +sub compare_md5s ($$) { + exists $_[1] or script_error 'compare_md5s requires two arguments.'; + my ($first, $second) = @_; + return $first eq $second ? 1 : 0; +} + +# for a given distfile, see whether or not it exists, and if so, if its md5sum +# matches the sbo's .info file +sub check_distfile ($$) { + exists $_[1] or script_error 'check_distfile requires two arguments.'; + my ($link, $info_md5sum) = @_; + my $filename = get_filename_from_link $link; + return unless -d $distfiles; + return unless -f $filename; + my $md5sum = compute_md5sum $filename; + return compare_md5s $info_md5sum, $md5sum; +} + +# for a given distfile, attempt to retrieve it and, if successful, check its +# md5sum against that in the sbo's .info file +sub get_distfile ($$) { + exists $_[1] or script_error 'get_distfile requires an argument'; + my ($link, $exp_md5) = @_; + my $filename = get_filename_from_link $link; + mkdir $distfiles unless -d $distfiles; + chdir $distfiles; + system ("wget --no-check-certificate $link") == 0 or + die "Unable to wget $link\n"; + my $md5sum = compute_md5sum $filename; + # can't do anything if the link in the .info doesn't lead to a good d/l + compare_md5s $md5sum, $exp_md5 or die "md5sum failure for $filename.\n"; + return 1; +} + +# for a given distfile, figure out what the full path to its symlink will be +sub get_symlink_from_filename ($$) { + exists $_[1] or script_error + 'get_symlink_from_filename requires two arguments'; + -f $_[0] or script_error + 'get_symlink_from_filename first argument is not a file'; + my ($filename, $location) = @_; + return "$location/". ($filename =~ qr#/([^/]+)$#)[0]; +} + +# determine whether or not a given sbo is 32-bit only +sub check_x32 ($) { + exists $_[0] or script_error 'check_x32 requires an argument.'; + my $dl = get_from_info (LOCATION => shift, GET => 'DOWNLOAD_x86_64'); + return $$dl[0] =~ /UN(SUPPOR|TES)TED/ ? 1 : 0; +} + +# can't do 32-bit on x86_64 without this file, so we'll use it as the test to +# to determine whether or not an x86_64 system is setup for multilib +sub check_multilib () { + return 1 if -f '/etc/profile.d/32dev.sh'; + return; +} + +# make a backup of the existent SlackBuild, and rewrite the original as needed +sub rewrite_slackbuild ($$%) { + exists $_[1] or script_error 'rewrite_slackbuild requires two arguments.'; + my ($slackbuild, $tempfn, %changes) = @_; + copy ($slackbuild, "$slackbuild.orig") or + die "Unable to backup $slackbuild to $slackbuild.orig\n"; + my $tar_regex = qr/(un|)tar .*$/; + my $makepkg_regex = qr/makepkg/; + my $libdir_regex = qr/^\s*LIBDIRSUFFIX="64"\s*$/; + my $make_regex = qr/^\s*make(| \Q||\E exit 1)$/; + my $arch_regex = qr/\$VERSION-\$ARCH-\$BUILD/; + # tie the slackbuild, because this is the easiest way to handle this. + tie my @sb_file, 'Tie::File', $slackbuild; + for my $line (@sb_file) { + # get the output of the tar and makepkg commands. hope like hell that v + # is specified among tar's arguments + if ($line =~ $tar_regex || $line =~ $makepkg_regex) { + $line = "$line | tee -a $tempfn"; + } + # then check for and apply any other %changes + if (exists $changes{libdirsuffix}) { + $line =~ s/64/$changes{libdirsuffix}/ if $line =~ $libdir_regex; + } + if (exists $changes{make}) { + $line =~ s/make/make $changes{make}/ if $line =~ $make_regex; + } + if (exists $changes{arch_out}) { + $line =~ s/\$ARCH/$changes{arch_out}/ if $line =~ $arch_regex; + } + } + untie @sb_file; + return 1; +} + +# move a backed-up .SlackBuild file back into place +sub revert_slackbuild ($) { + exists $_[0] or script_error 'revert_slackbuild requires an argument'; + my $slackbuild = shift; + if (-f "$slackbuild.orig") { + unlink $slackbuild if -f $slackbuild; + rename ("$slackbuild.orig", $slackbuild); + } + return 1; +} + +# given a location and a list of download links, assemble a list of symlinks, +# and create them. +sub create_symlinks ($%) { + exists $_[1] or script_error 'create_symlinks requires two arguments.'; + my ($location, %downloads) = @_; + my @symlinks; + for my $link (keys %downloads) { + my $md5sum = $downloads{$link}; + unless (check_distfile $link, $md5sum) { + die unless get_distfile $link, $md5sum; + } + my $filename = get_filename_from_link $link; + my $symlink = get_symlink_from_filename $filename, $location; + push @symlinks, $symlink; + symlink $filename, $symlink; + } + return @symlinks; +} + +# pull the untarred source directory or created package name from the temp +# file (the one we tee'd to) +sub grok_temp_file { + my %args = ( + TEMPFN => '', + REGEX => '', + CAPTURE => 0, + @_ + ); + unless ($args{TEMPFN} && $args{REGEX}) { + script_error 'grok_temp_file requires two arguments'; + } + my $out; + my $fh = open_read $args{TEMPFN}; + FIRST: while (my $line = <$fh>) { + if ($line =~ $args{REGEX}) { + $out = ($line =~ $args{REGEX})[$args{CAPTURE}]; + last FIRST; + } + } + close $fh; + return $out; +} + +# wrappers around grok_temp_file +sub get_src_dir ($) { + exists $_[0] or script_error 'get_src_dir requires an argument'; + return grok_temp_file (TEMPFN => shift, REGEX => qr#^([^/]+)/#); +} + +sub get_pkg_name ($) { + exists $_[0] or script_error 'get_pkg_name requires an argument'; + return grok_temp_file (TEMPFN => shift, + REGEX => qr/^Slackware\s+package\s+([^\s]+)\s+created\.$/); +} + +# prep and run .SlackBuild +sub perform_sbo { + my %args = ( + OPTS => 0, + JOBS => 0, + LOCATION => '', + ARCH => '', + C32 => 0, + X32 => 0, + @_ + ); + unless ($args{LOCATION} && $args{ARCH}) { + script_error 'perform_sbo requires LOCATION and ARCH.'; + } + my $location = $args{LOCATION}; + my $sbo = get_sbo_from_loc $location; + my ($cmd, %changes); + $changes{make} = "-j $args{JOBS}" if $args{JOBS}; + if ($args{ARCH} eq 'x86_64' and ($args{C32} || $args{X32}) ) { + if ($args{C32}) { + $changes{libdirsuffix} = ''; + } elsif ($args{X32}) { + $changes{arch_out} = 'i486'; + } + $cmd = ". /etc/profile.d/32dev.sh &&"; + } + $cmd .= "/bin/sh $location/$sbo.SlackBuild"; + $cmd = "$args{OPTS} $cmd" if $args{OPTS}; + my ($tempfh, $tempfn) = tempfile (DIR => $tempdir); + close $tempfh; + rewrite_slackbuild "$location/$sbo.SlackBuild", $tempfn, %changes; + chdir $location, my $out = system $cmd; + revert_slackbuild "$location/$sbo.SlackBuild"; + die unless $out == 0; + my $src = get_src_dir $tempfn; + my $pkg = get_pkg_name $tempfn; + unlink $tempfn; + return $pkg, $src; +} + +# "public interface", sort of thing. +sub do_slackbuild { + my %args = ( + OPTS => 0, + JOBS => 0, + LOCATION => '', + COMPAT32 => 0, + @_ + ); + $args{LOCATION} or script_error 'do_slackbuild requires LOCATION.'; + my $location = $args{LOCATION}; + my $sbo = get_sbo_from_loc $location; + my $arch = get_arch; + my $multi = check_multilib; + my $version = get_sbo_version $location; + my $x32; + if ($args{COMPAT32}) { + die "compat32 only works on x86_64.\n" unless $arch eq 'x86_64'; + die "compat32 requires multilib.\n" unless $multi; + die "compat32 requires /usr/sbin/convertpkg-compat32.\n" + unless -f '/usr/sbin/convertpkg-compat32'; + } else { + if ($arch eq 'x86_64') { + $x32 = check_x32 $args{LOCATION}; + if ($x32 && ! $multi) { + die "$sbo is 32-bit which requires multilib on x86_64.\n"; + } + } + } + my %downloads = get_sbo_downloads ( + LOCATION => $location, + 32 => $args{COMPAT32} + ); + my @symlinks = create_symlinks $args{LOCATION}, %downloads; + my ($pkg, $src) = perform_sbo ( + OPTS => $args{OPTS}, + JOBS => $args{JOBS}, + LOCATION => $location, + ARCH => $arch, + C32 => $args{COMPAT32}, + X32 => $x32, + ); + if ($args{COMPAT32}) { + my ($tempfh, $tempfn) = tempfile (DIR => $tempdir); + close $tempfh; + my $cmd = "/usr/sbin/convertpkg-compat32 -i $pkg -d /tmp | tee $tempfn"; + system ($cmd) == 0 or die; + unlink $pkg; + $pkg = get_pkg_name $tempfn; + } + unlink $_ for @symlinks; + return $version, $pkg, $src; +} + +# remove work directories (source and packaging dirs under /tmp/SBo) +sub make_clean ($$$) { + exists $_[2] or script_error 'make_clean requires three arguments.'; + my ($sbo, $src, $version) = @_; + print "Cleaning for $sbo-$version...\n"; + my $tmpsbo = "/tmp/SBo"; + remove_tree ("$tmpsbo/$src") if -d "$tmpsbo/$src"; + remove_tree ("$tmpsbo/package-$sbo") if -d "$tmpsbo/package-$sbo"; + return 1; +} + +# remove distfiles +sub make_distclean { + my %args = ( + SRC => '', + VERSION => '', + LOCATION => '', + @_ + ); + unless ($args{SRC} && $args{VERSION} && $args{LOCATION}) { + script_error 'make_distclean requires four arguments.'; + } + my $sbo = get_sbo_from_loc $args{LOCATION}; + make_clean $sbo, $args{SRC}, $args{VERSION}; + print "Distcleaning for $sbo-$args{VERSION}...\n"; + # remove any distfiles for this particular SBo. + my %downloads = get_sbo_downloads (LOCATION => $args{LOCATION}); + for my $key (keys %downloads) { + my $filename = get_filename_from_link $key; + unlink $filename if -f $filename; + } + return 1; +} + +# run upgradepkg for a created package +sub do_upgradepkg ($) { + exists $_[0] or script_error 'do_upgradepkg requires an argument.'; + system ('/sbin/upgradepkg', '--reinstall', '--install-new', shift); + return 1; +} diff --git a/t/do_tests.sh b/t/do_tests.sh new file mode 100755 index 0000000..54222db --- /dev/null +++ b/t/do_tests.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +./prep.pl +./test.t diff --git a/t/prep.pl b/t/prep.pl new file mode 100755 index 0000000..e2fe9bf --- /dev/null +++ b/t/prep.pl @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +use strict; +use warnings FATAL => 'all'; +use File::Copy; +use Tie::File; + +chomp (my $pwd = `pwd`); +mkdir "$pwd/SBO" unless -d "$pwd/SBO"; +copy ('/home/d4wnr4z0r/projects/sbotools/SBO-Lib/lib/SBO/Lib.pm', "$pwd/SBO"); +my @subs; +open my $file_h, '<', "$pwd/SBO/Lib.pm"; +my $regex = qr/^sub\s+([^\s]+)\s+/; +while (my $line = <$file_h>) { + if (my $sub = ($line =~ $regex)[0]) { + push @subs, $sub; + } +} + +seek $file_h, 0, 0; +my @not_exported; +FIRST: for my $sub (@subs) { + my $found = 'FALSE'; + my $has = 'FALSE'; + SECOND: while (my $line = <$file_h>) { + if ($found eq 'FALSE') { + $found = 'TRUE', next SECOND if $line =~ /\@EXPORT/; + } else { + last SECOND if $line =~ /^\);$/; + $has = 'TRUE', last SECOND if $line =~ /$sub/; + } + } + push @not_exported, $sub unless $has eq 'TRUE'; + seek $file_h, 0, 0; +} + +close $file_h; +tie my @file, 'Tie::File', "$pwd/SBO/Lib.pm"; +FIRST: for my $line (@file) { + if ($line =~ /\@EXPORT/) { + $line = "our \@EXPORT = qw(". join ' ', @not_exported; + } + $line = "#$line" if $line =~ /root privileges/; +} + + diff --git a/t/test.t b/t/test.t new file mode 100755 index 0000000..71eca1d --- /dev/null +++ b/t/test.t @@ -0,0 +1,95 @@ +#!/usr/bin/perl -I/home/d4wnr4z0r/projects/sbotools/t + +use 5.16.0; +use strict; +use warnings FATAL => 'all'; +use File::Temp qw(tempdir tempfile); +use Test::More tests => 39; +use SBO::Lib; + +ok (defined $SBO::Lib::tempdir, '$tempdir is defined'); + +my $fh = open_read ('/home/d4wnr4z0r/projects/sbotools/t/test.t'); +ok (ref ($fh) eq 'GLOB', 'open_read works'); +close $fh; + +ok ($SBO::Lib::config{DISTCLEAN} eq 'FALSE', 'config{DISTCLEAN} is good'); +ok ($SBO::Lib::config{JOBS} == 2, 'config{JOBS} is good'); +ok ($SBO::Lib::config{NOCLEAN} eq 'TRUE', 'config{NOCLEAN} is good'); +ok ($SBO::Lib::config{PKG_DIR} eq 'FALSE', 'config{PKG_DIR} is good'); +ok ($SBO::Lib::config{SBO_HOME} eq '/usr/sbo', 'config{SBO_HOME} is good'); + +ok (show_version == 1, 'show_version is good'); +ok (get_slack_version eq '14.0', 'get_slack_version is good'); +ok (chk_slackbuilds_txt == 1, 'check_slackbuilds_txt is good'); +#ok (rsync_sbo_tree == 1, 'rsync_sbo_tree is good'); +#ok (update_tree == 1, 'update_tree is good'); +ok (slackbuilds_or_fetch == 1, 'slackbuilds_or_fetch is good'); + +print "pseudo-random sampling of get_installed_sbos output...\n"; +my $installed = get_installed_sbos; +for my $key (keys @$installed) { + is ($$installed[$key]{version}, '1.13') if $$installed[$key]{name} eq 'OpenAL'; + is ($$installed[$key]{version}, '9.5.1_enu') if $$installed[$key]{name} eq 'adobe-reader'; + is ($$installed[$key]{version}, '4.1.3') if $$installed[$key]{name} eq 'libdvdnav'; + is ($$installed[$key]{version}, '0.8.8.4') if $$installed[$key]{name} eq 'libmodplug'; + is ($$installed[$key]{version}, '3.12.4') if $$installed[$key]{name} eq 'mozilla-nss'; + is ($$installed[$key]{version}, '2.5.0') if $$installed[$key]{name} eq 'zdoom'; +} +print "completed pseudo-random testing of get_installed_sbos \n"; + +is (get_sbo_location 'nginx', '/usr/sbo/network/nginx', 'get_sbo_location is good'); + +my $updates = get_available_updates; +for my $key (keys @$updates) { + is ($$updates[$key]{installed}, '1.15', '$$updates[$key]{installed} good for mutagen') if $$updates[$key]{name} eq 'mutagen'; + is ($$updates[$key]{update}, '1.20', '$$updates[$key]{update} good for mutagen') if $$updates[$key]{name} eq 'mutagen'; +} + +ok (get_arch eq 'x86_64', 'get_arch is good'); + +my %dl_info = get_download_info (LOCATION => '/usr/sbo/system/wine', X64 => 0); +my $link = 'http://downloads.sf.net/wine/source/1.4/wine-1.4.1.tar.bz2'; +is ($dl_info{$link}, '0c28702ed478df7a1c097f3a9c4cabd6', 'get_download_info test 01 good.'); +$link = 'http://www.unrealize.co.uk/source/dibeng-max-2010-11-12.zip'; +is ($dl_info{$link}, '97159d77631da13952fe87e846cf1f3b', 'get_download_info test 02 good.'); + +%dl_info = get_sbo_downloads (LOCATION => '/usr/sbo/system/wine'); +$link = 'http://downloads.sf.net/wine/source/1.4/wine-1.4.1.tar.bz2'; +is ($dl_info{$link}, '0c28702ed478df7a1c097f3a9c4cabd6', 'get_sbo_downloads test 01 good.'); +$link = 'http://www.unrealize.co.uk/source/dibeng-max-2010-11-12.zip'; +is ($dl_info{$link}, '97159d77631da13952fe87e846cf1f3b', 'get_sbo_downloads test 02 good.'); + +my %downloads = get_sbo_downloads (LOCATION => '/usr/sbo/system/ifuse'); +$link = 'http://www.libimobiledevice.org/downloads/ifuse-1.1.1.tar.bz2'; +is ($downloads{$link}, '8d528a79de024b91f12f8ac67965c37c', 'get_sbo_downloads test 03 good.'); + +is (get_filename_from_link 'http://www.libimobiledevice.org/downloads/ifuse-1.1.1.tar.bz2', '/usr/sbo/distfiles/ifuse-1.1.1.tar.bz2', 'get_file_from_link good'); +is (compute_md5sum '/usr/sbo/distfiles//laptop-mode-tools_1.61.tar.gz', '6685af5dbb34c3d51ca27933b58f484e', 'compute_md5sum good'); +is ((verify_distfile '/usr/sbo/distfiles/laptop-mode-tools_1.61.tar.gz', '6685af5dbb34c3d51ca27933b58f484e'), 1, 'verify_distfile good'); +is (get_sbo_version '/usr/sbo/system/wine', '1.4.1', 'get_sbo_version good'); +is ((get_symlink_from_filename '/usr/sbo/distfiles/laptop-mode-tools_1.61.tar.gz', '/usr/sbo/system/laptop-mode-tools'), '/usr/sbo/system/laptop-mode-tools/laptop-mode-tools_1.61.tar.gz', 'get_symlink_from_filename good'); +ok (check_x32 '/usr/sbo/system/wine', 'check_x32 true for 32-bit only wine'); +ok (!(check_x32 '/usr/sbo/system/ifuse'), 'check_x32 false for not-32-bit-only ifuse'); +ok (check_multilib, 'check_multilib good'); + +# TODO: find a way to write a test for rewrite_slackbuild, revert_slackbuild. + +%downloads = get_sbo_downloads (LOCATION => '/usr/sbo/system/wine', 32 => 1); +my @symlinks = create_symlinks '/usr/sbo/system/wine', %downloads; +is ($symlinks[0], '/usr/sbo/system/wine/wine-1.4.1.tar.bz2', '$symlinks[0] good for create_symlinks'); +is ($symlinks[1], '/usr/sbo/system/wine/dibeng-max-2010-11-12.zip', '$symlinks[1] good for create_symlinks'); + +my $tempdir = tempdir (CLEANUP => 1); +my $tempfh = tempfile (DIR => $tempdir); +my $lmt = 'laptop-mode-tools_1.60'; +print {$tempfh} "$lmt/COPYING\n"; +print {$tempfh} "$lmt/Documentation/\n"; +print {$tempfh} "$lmt/README\n"; +print {$tempfh} "Slackware package skype-2.2.0.35-i486-1_SBo.tgz created.\n"; +#close $tempfh; +is (get_src_dir $tempfh, 'laptop-mode-tools_1.60', 'get_src_dir good'); +is (get_pkg_name $tempfh, 'skype-2.2.0.35-i486-1_SBo.tgz', 'get_pkg_name good'); +%downloads = get_sbo_downloads (LOCATION => '/usr/sbo/system/wine', 32 => 1); +is ((check_distfiles %downloads), 1, 'check_distfiles good'); +#is (do_convertpkg ($package), "$package-compat32", 'do_convertpkg good'); diff --git a/t/test.t~ b/t/test.t~ new file mode 100755 index 0000000..9b0a256 --- /dev/null +++ b/t/test.t~ @@ -0,0 +1,95 @@ +#!/usr/bin/perl -I/home/d4wnr4z0r/projects/sbotools/t + +use 5.16.0; +use strict; +use warnings FATAL => 'all'; +use File::Temp qw(tempdir tempfile); +use Test::More tests => 39; +use SBO::Lib; + +ok (defined $SBO::Lib::tempdir, '$tempdir is defined'); + +my $fh = open_read ('/home/d4wnr4z0r/projects/sbotools/t/test.t'); +ok (ref ($fh) eq 'GLOB', 'open_read works'); +close $fh; + +ok ($SBO::Lib::config{DISTCLEAN} eq 'FALSE', 'config{DISTCLEAN} is good'); +ok ($SBO::Lib::config{JOBS} == 2, 'config{JOBS} is good'); +ok ($SBO::Lib::config{NOCLEAN} eq 'TRUE', 'config{NOCLEAN} is good'); +ok ($SBO::Lib::config{PKG_DIR} eq 'FALSE', 'config{PKG_DIR} is good'); +ok ($SBO::Lib::config{SBO_HOME} eq '/usr/sbo', 'config{SBO_HOME} is good'); + +ok (show_version == 1, 'show_version is good'); +ok (get_slack_version eq '14.0', 'get_slack_version is good'); +ok (chk_slackbuilds_txt == 1, 'check_slackbuilds_txt is good'); +#ok (rsync_sbo_tree == 1, 'rsync_sbo_tree is good'); +#ok (update_tree == 1, 'update_tree is good'); +ok (slackbuilds_or_fetch == 1, 'slackbuilds_or_fetch is good'); + +print "pseudo-random sampling of get_installed_sbos output...\n"; +my $installed = get_installed_sbos; +for my $key (keys @$installed) { + is ($$installed[$key]{version}, '1.13') if $$installed[$key]{name} eq 'OpenAL'; + is ($$installed[$key]{version}, '9.5.1_enu') if $$installed[$key]{name} eq 'adobe-reader'; + is ($$installed[$key]{version}, '4.1.3') if $$installed[$key]{name} eq 'libdvdnav'; + is ($$installed[$key]{version}, '0.8.8.4') if $$installed[$key]{name} eq 'libmodplug'; + is ($$installed[$key]{version}, '3.12.4') if $$installed[$key]{name} eq 'mozilla-nss'; + is ($$installed[$key]{version}, '2.5.0') if $$installed[$key]{name} eq 'zdoom'; +} +print "completed pseudo-random testing of get_installed_sbos \n"; + +is (get_sbo_location 'nginx', '/usr/sbo/network/nginx', 'get_sbo_location is good'); + +my $updates = get_available_updates; +for my $key (keys @$updates) { + is ($$updates[$key]{installed}, '1.15', '$$updates[$key]{installed} good for mutagen') if $$updates[$key]{name} eq 'mutagen'; + is ($$updates[$key]{update}, '1.20', '$$updates[$key]{update} good for mutagen') if $$updates[$key]{name} eq 'mutagen'; +} + +ok (get_arch eq 'x86_64', 'get_arch is good'); + +my %dl_info = get_download_info (LOCATION => '/usr/sbo/system/wine', X64 => 0); +my $link = 'http://downloads.sf.net/wine/source/1.4/wine-1.4.1.tar.bz2'; +is ($dl_info{$link}, '0c28702ed478df7a1c097f3a9c4cabd6', 'get_download_info test 01 good.'); +$link = 'http://www.unrealize.co.uk/source/dibeng-max-2010-11-12.zip'; +is ($dl_info{$link}, '97159d77631da13952fe87e846cf1f3b', 'get_download_info test 02 good.'); + +%dl_info = get_sbo_downloads (LOCATION => '/usr/sbo/system/wine'); +$link = 'http://downloads.sf.net/wine/source/1.4/wine-1.4.1.tar.bz2'; +is ($dl_info{$link}, '0c28702ed478df7a1c097f3a9c4cabd6', 'get_sbo_downloads test 01 good.'); +$link = 'http://www.unrealize.co.uk/source/dibeng-max-2010-11-12.zip'; +is ($dl_info{$link}, '97159d77631da13952fe87e846cf1f3b', 'get_sbo_downloads test 02 good.'); + +my %downloads = get_sbo_downloads (LOCATION => '/usr/sbo/system/ifuse'); +$link = 'http://www.libimobiledevice.org/downloads/ifuse-1.1.1.tar.bz2'; +is ($downloads{$link}, '8d528a79de024b91f12f8ac67965c37c', 'get_sbo_downloads test 03 good.'); + +is (get_filename_from_link 'http://www.libimobiledevice.org/downloads/ifuse-1.1.1.tar.bz2', '/usr/sbo/distfiles/ifuse-1.1.1.tar.bz2', 'get_file_from_link good'); +is (compute_md5sum '/usr/sbo/distfiles//laptop-mode-tools_1.61.tar.gz', '6685af5dbb34c3d51ca27933b58f484e', 'compute_md5sum good'); +is ((verify_distfile '/usr/sbo/distfiles/laptop-mode-tools_1.61.tar.gz', '6685af5dbb34c3d51ca27933b58f484e'), 1, 'verify_distfile good'); +is (get_sbo_version '/usr/sbo/system/wine', '1.4.1', 'get_sbo_version good'); +is ((get_symlink_from_filename '/usr/sbo/distfiles/laptop-mode-tools_1.61.tar.gz', '/usr/sbo/system/laptop-mode-tools'), '/usr/sbo/system/laptop-mode-tools/laptop-mode-tools_1.61.tar.gz', 'get_symlink_from_filename good'); +ok (check_x32 '/usr/sbo/system/wine', 'check_x32 true for 32-bit only wine'); +ok (!(check_x32 '/usr/sbo/system/ifuse'), 'check_x32 false for not-32-bit-only ifuse'); +ok (check_multilib, 'check_multilib good'); + +# TODO: find a way to write a test for rewrite_slackbuild, revert_slackbuild. + +%downloads = get_sbo_downloads (LOCATION => '/usr/sbo/system/wine', 32 => 1); +my @symlinks = create_symlinks '/usr/sbo/system/wine', %downloads; +is ($symlinks[0], '/usr/sbo/system/wine/wine-1.4.1.tar.bz2', '$symlinks[0] good for create_symlinks'); +is ($symlinks[1], '/usr/sbo/system/wine/dibeng-max-2010-11-12.zip', '$symlinks[1] good for create_symlinks'); + +my $tempdir = tempdir (CLEANUP => 1); +my $tempfh = tempfile (DIR => $tempdir); +my $lmt = 'laptop-mode-tools_1.60'; +print {$tempfh} "$lmt/COPYING\n"; +print {$tempfh} "$lmt/Documentation/\n"; +print {$tempfh} "$lmt/README\n"; +print {$tempfh} "Slackware package skype-2.2.0.35-i486-1_SBo.tgz created.\n"; +#close $tempfh; +is (get_src_dir $tempfh, 'laptop-mode-tools_1.60', 'get_src_dir good'); +is (get_pkg_name $tempfh, 'skype-2.2.0.35-i486-1_SBo.tgz', 'get_pkg_name good'); +%downloads = get_sbo_downloads (LOCATION => '/usr/sbo/system/wine', 32 => 1); +is (check_distfiles %downloads, 1, 'check_distfiles good'); +#is (do_convertpkg ($package), "$package-compat32", 'do_convertpkg good'); |