diff options
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib.pm | 247 | ||||
| -rwxr-xr-x | sbocheck | 20 | ||||
| -rwxr-xr-x | sboclean | 28 | ||||
| -rwxr-xr-x | sboconfig | 24 | ||||
| -rwxr-xr-x | sbofind | 30 | ||||
| -rwxr-xr-x | sboinstall | 20 | ||||
| -rwxr-xr-x | sboremove | 18 | ||||
| -rwxr-xr-x | sbosnap | 14 | ||||
| -rwxr-xr-x | sboupgrade | 26 |
9 files changed, 214 insertions, 213 deletions
diff --git a/SBO-Lib/lib/SBO/Lib.pm b/SBO-Lib/lib/SBO/Lib.pm index a38cfc1..fadcbba 100644 --- a/SBO-Lib/lib/SBO/Lib.pm +++ b/SBO-Lib/lib/SBO/Lib.pm @@ -100,14 +100,14 @@ our $tempdir = tempdir(CLEANUP => 1, DIR => $tmpd); our $pkg_db = '/var/log/packages'; # subroutine for throwing internal script errors -sub script_error(;$) { +sub script_error { exists $_[0] ? warn "A fatal script error has occurred:\n$_[0]\nExiting.\n" : warn "A fatal script error has occurred. Exiting.\n"; exit _ERR_SCRIPT; } # subroutine for usage errors -sub usage_error($) { +sub usage_error { warn shift ."\n"; exit _ERR_USAGE; } @@ -128,7 +128,7 @@ sub open_fh { return $fh; } -sub open_read($) { +sub open_read { return open_fh(shift, '<'); } @@ -144,7 +144,7 @@ our %config = ( ); # subroutine to suck in config in order to facilitate unit testing -sub read_config() { +sub read_config { my %conf_values; if (-f $conf_file) { my ($fh, $exit) = open_read $conf_file; @@ -164,14 +164,14 @@ sub read_config() { $config{SBO_HOME} = '/usr/sbo' if $config{SBO_HOME} eq 'FALSE'; } -read_config; +read_config(); # some stuff we'll need later - define first two as our for unit testing our $distfiles = "$config{SBO_HOME}/distfiles"; our $slackbuilds_txt = "$config{SBO_HOME}/SLACKBUILDS.TXT"; my $name_regex = '\ASLACKBUILD\s+NAME:\s+'; -sub show_version() { +sub show_version { say "sbotools version $VERSION"; say 'licensed under the WTFPL'; say '<http://sam.zoy.org/wtfpl/COPYING>'; @@ -180,12 +180,12 @@ sub show_version() { # %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() { +sub get_slack_version { my %supported = ( '14.0' => '14.0', '14.1' => '14.1', ); - my ($fh, $exit) = open_read '/etc/slackware-version'; + my ($fh, $exit) = open_read('/etc/slackware-version'); if ($exit) { warn $fh; exit $exit; @@ -193,34 +193,34 @@ sub get_slack_version() { chomp(my $line = <$fh>); close $fh; my $version = ($line =~ /\s+(\d+[^\s]+)$/)[0]; - usage_error "Unsupported Slackware version: $version\n" + usage_error("Unsupported Slackware version: $version\n") unless $supported{$version}; return $supported{$version}; } # does the SLACKBUILDS.TXT file exist in the sbo tree? -sub chk_slackbuilds_txt() { +sub chk_slackbuilds_txt { return -f $slackbuilds_txt ? 1 : undef; } # 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); FIRST: while (readdir $home_handle) { next FIRST if /^\.[\.]{0,1}$/; - usage_error "$sbo_home exists and is not empty. Exiting.\n"; + usage_error("$sbo_home exists and is not empty. Exiting.\n"); } } else { - make_path($sbo_home) or usage_error "Unable to create $sbo_home.\n"; + make_path($sbo_home) or usage_error("Unable to create $sbo_home.\n"); } return 1; } # rsync the sbo tree from slackbuilds.org to $config{SBO_HOME} -sub rsync_sbo_tree() { - my $slk_version = get_slack_version; +sub rsync_sbo_tree { + my $slk_version = get_slack_version(); my @arg = ('rsync', '-a', '--exclude=*.tar.gz', '--exclude=*.tar.gz.asc'); push @arg, '--delete', "rsync://slackbuilds.org/slackbuilds/$slk_version/*"; my $out = system @arg, $config{SBO_HOME}; @@ -233,26 +233,26 @@ sub rsync_sbo_tree() { } # wrappers for differing checks and output -sub fetch_tree() { - check_home; +sub fetch_tree { + check_home(); say 'Pulling SlackBuilds tree...'; - rsync_sbo_tree, return 1; + rsync_sbo_tree(), return 1; } -sub update_tree() { - fetch_tree, return unless chk_slackbuilds_txt; +sub update_tree { + fetch_tree(), return unless chk_slackbuilds_txt(); say 'Updating SlackBuilds tree...'; - rsync_sbo_tree, return 1; + rsync_sbo_tree(), return 1; } # 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) { +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] '; if (<STDIN> =~ /^[Yy\n]/) { - fetch_tree; + fetch_tree(); } else { say 'Please run "sbosnap fetch"'; exit 0; @@ -263,8 +263,8 @@ sub slackbuilds_or_fetch() { # pull an array of hashes, each hash containing the name and version of a # package currently installed. Gets filtered using STD, SBO or ALL. -sub get_installed_packages($) { - exists $_[0] or script_error 'get_installed_packages requires an argument.'; +sub get_installed_packages { + exists $_[0] or script_error('get_installed_packages requires an argument.'); my $filter = shift; my @installed; @@ -288,8 +288,8 @@ sub get_installed_packages($) { # 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.'; +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; @@ -298,19 +298,20 @@ sub get_inst_names($) { # 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.'; + exists $_[0] or script_error('get_sbo_location requires an argument.'); my @sbos = @_; if (ref $sbos[0] eq 'ARRAY') { my $tmp = $sbos[0]; @sbos = @$tmp; } state $store = {}; + ## NOTE this might cause a problem now that prototypes are removed # if scalar context and we already have the location, return it now. unless (wantarray) { return $$store{$sbos[0]} if exists $$store{$sbos[0]}; } my %locations; - my ($fh, $exit) = open_read $slackbuilds_txt; + my ($fh, $exit) = open_read($slackbuilds_txt); if ($exit) { warn $fh; exit $exit; @@ -333,8 +334,8 @@ sub get_sbo_location { } # 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.'; +sub get_sbo_from_loc { + exists $_[0] or script_error('get_sbo_from_loc requires an argument.'); return (shift =~ qr#/([^/]+)$#)[0]; } @@ -346,13 +347,13 @@ sub get_from_info { @_ ); unless ($args{LOCATION} && $args{GET}) { - script_error 'get_from_info requires LOCATION and GET.'; + script_error('get_from_info requires LOCATION and GET.'); } state $store = {PRGNAM => ['']}; - my $sbo = get_sbo_from_loc $args{LOCATION}; + my $sbo = get_sbo_from_loc($args{LOCATION}); return $$store{$args{GET}} if $$store{PRGNAM}[0] eq $sbo; # if we're here, we haven't read in the .info file yet. - my ($fh, $exit) = open_read "$args{LOCATION}/$sbo.info"; + my ($fh, $exit) = open_read("$args{LOCATION}/$sbo.info"); return if $exit; # suck it all in, clean it all up, stuff it all in $store. my $contents = do {local $/; <$fh>}; @@ -372,22 +373,22 @@ sub get_from_info { } # 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.'; +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] : undef; } # 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_packages 'SBO'; + my $pkg_list = get_installed_packages('SBO'); 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 $location; - my $version = get_sbo_version $location; + my $version = get_sbo_version($location); if (versioncmp($version, $$pkg_list[$key]{version}) == 1) { push @updates, { name => $$pkg_list[$key]{name}, @@ -407,7 +408,7 @@ sub get_download_info { X64 => 1, @_ ); - $args{LOCATION} or script_error 'get_download_info requires LOCATION.'; + $args{LOCATION} or script_error('get_download_info requires LOCATION.'); my ($get, $downs, $exit, $md5s, %return); $get = ($args{X64} ? 'DOWNLOAD_x86_64' : 'DOWNLOAD'); $downs = get_from_info(LOCATION => $args{LOCATION}, GET => $get); @@ -429,7 +430,7 @@ sub get_download_info { return \%return; } -sub get_arch() { +sub get_arch { chomp(my $arch = `uname -m`); return $arch; } @@ -441,10 +442,10 @@ sub get_sbo_downloads { 32 => 0, @_ ); - $args{LOCATION} or script_error 'get_sbo_downloads requires LOCATION.'; + $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; + -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}; @@ -456,8 +457,8 @@ sub get_sbo_downloads { } # given a link, grab the filename from it and prepend $distfiles -sub get_filename_from_link($) { - exists $_[0] or script_error 'get_filename_from_link requires an argument'; +sub get_filename_from_link { + exists $_[0] or script_error('get_filename_from_link requires an argument'); my $fn = shift; my $regex = qr#/([^/]+)$#; my $filename = $fn =~ $regex ? $distfiles .'/'. ($fn =~ $regex)[0] : undef; @@ -466,9 +467,9 @@ sub get_filename_from_link($) { } # for a given file, compute its md5sum -sub compute_md5sum($) { - -f $_[0] or script_error 'compute_md5sum requires a file argument.'; - my ($fh, $exit) = open_read shift; +sub compute_md5sum { + -f $_[0] or script_error('compute_md5sum requires a file argument.'); + my ($fh, $exit) = open_read(shift); my $md5 = Digest::MD5->new; $md5->addfile($fh); my $md5sum = $md5->hexdigest; @@ -479,20 +480,20 @@ sub compute_md5sum($) { # 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 'verify_distfile requires two arguments.'; + exists $_[1] or script_error('verify_distfile requires two arguments.'); my ($link, $info_md5) = @_; - my $filename = get_filename_from_link $link; + my $filename = get_filename_from_link($link); return unless -f $filename; - my $md5sum = compute_md5sum $filename; + my $md5sum = compute_md5sum($filename); return $info_md5 eq $md5sum ? 1 : 0; } # 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'; + exists $_[1] or script_error('get_distfile requires an argument'); my ($link, $info_md5) = @_; - my $filename = get_filename_from_link $link; + my $filename = get_filename_from_link($link); mkdir $distfiles unless -d $distfiles; chdir $distfiles; unlink $filename if -f $filename; @@ -506,30 +507,30 @@ sub get_distfile { # 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'; + 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.'; +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 : undef; } # 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; } # given a list of downloads, return just the filenames -sub get_dl_fns($) { +sub get_dl_fns { my $fns = shift; my $return; push @$return, ($_ =~ qr|/([^/]+)$|)[0] for @$fns; @@ -569,7 +570,7 @@ sub rewrite_slackbuild { C32 => 0, @_ ); - $args{SLACKBUILD} or script_error 'rewrite_slackbuild requires SLACKBUILD.'; + $args{SLACKBUILD} or script_error('rewrite_slackbuild requires SLACKBUILD.'); my $slackbuild = $args{SLACKBUILD}; my $changes = $args{CHANGES}; unless (copy($slackbuild, "$slackbuild.orig")) { @@ -589,10 +590,10 @@ sub rewrite_slackbuild { LOCATION => $location, 32 => 1, ); - my $fns = get_dl_fns [keys %$downloads]; + my $fns = get_dl_fns([keys %$downloads]); for my $line (@sb_file) { if ($line =~ $dc_regex) { - my ($regex, $initial) = get_dc_regex $line; + my ($regex, $initial) = get_dc_regex($line); for my $fn (@$fns) { $fn = "$initial$fn"; $line =~ s/$regex/$fn/ if $fn =~ $regex; @@ -614,8 +615,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; @@ -633,10 +634,10 @@ sub check_distfiles { COMPAT32 => 0, @_ ); - $args{LOCATION} or script_error 'check_distfiles requires LOCATION.'; + $args{LOCATION} or script_error('check_distfiles requires LOCATION.'); my $location = $args{LOCATION}; - my $sbo = get_sbo_from_loc $location; + my $sbo = get_sbo_from_loc($location); my $downloads = get_sbo_downloads( LOCATION => $location, 32 => $args{COMPAT32} @@ -659,11 +660,11 @@ sub check_distfiles { # 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.'; + 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 $filename = get_filename_from_link($link); my $symlink = get_symlink_from_filename($filename, $location); push @symlinks, $symlink; symlink $filename, $symlink; @@ -672,7 +673,7 @@ sub create_symlinks { } # pull the created package name from the temp file we tee'd to -sub get_pkg_name($) { +sub get_pkg_name { my $fh = shift; seek $fh, 0, 0; my $regex = qr/^Slackware\s+package\s+([^\s]+)\s+created\.$/; @@ -683,8 +684,8 @@ sub get_pkg_name($) { return $out; } -sub get_src_dir($) { - exists $_[0] or script_error 'get_src_dir requires an argument'; +sub get_src_dir { + exists $_[0] or script_error('get_src_dir requires an argument'); my $fh = shift; seek $fh, 0, 0; my @src_dirs; @@ -710,8 +711,8 @@ sub get_src_dir($) { } # return a filename from a temp fh for use externally -sub get_tmp_extfn($) { - exists $_[0] or script_error 'get_tmp_extfn requires an argument.'; +sub get_tmp_extfn { + exists $_[0] or script_error('get_tmp_extfn requires an argument.'); my $fh = shift; unless (fcntl($fh, F_SETFD, 0)) { return "Can't unset exec-on-close bit.\n", _ERR_F_SETFD; @@ -731,11 +732,11 @@ sub perform_sbo { @_ ); unless ($args{LOCATION} && $args{ARCH}) { - script_error 'perform_sbo requires LOCATION and ARCH.'; + script_error('perform_sbo requires LOCATION and ARCH.'); } my $location = $args{LOCATION}; - my $sbo = get_sbo_from_loc $location; + my $sbo = get_sbo_from_loc($location); my ($cmd, %changes); # set any changes we need to make to the .SlackBuild, setup the command @@ -763,7 +764,7 @@ sub perform_sbo { } # get a tempfile to store the exit status of the slackbuild my $exit_temp = tempfile(DIR => $tempdir); - my ($exit_fn, $exit) = get_tmp_extfn $exit_temp; + my ($exit_fn, $exit) = get_tmp_extfn($exit_temp); return $exit_fn, undef, $exit if $exit; # set TMP/OUTPUT if set in the environment $cmd .= " TMP=$env_tmp" if $env_tmp; @@ -771,7 +772,7 @@ sub perform_sbo { $cmd .= " /bin/bash $location/$sbo.SlackBuild; echo \$? > $exit_fn )"; my $tempfh = tempfile(DIR => $tempdir); my $fn; - ($fn, $exit) = get_tmp_extfn $tempfh; + ($fn, $exit) = get_tmp_extfn($tempfh); return $fn, undef, $exit if $exit; $cmd .= " | tee -a $fn"; # attempt to rewrite the slackbuild, or exit if we can't @@ -788,27 +789,27 @@ sub perform_sbo { seek $exit_temp, 0, 0; my $out = do {local $/; <$exit_temp>}; close $exit_temp; - revert_slackbuild "$location/$sbo.SlackBuild"; + revert_slackbuild("$location/$sbo.SlackBuild"); # return error now if the slackbuild didn't exit 0 return "$sbo.SlackBuild return non-zero\n", undef, _ERR_BUILD if $out != 0; - my $pkg = get_pkg_name $tempfh; - my $src = get_src_dir $src_ls_fh; + my $pkg = get_pkg_name($tempfh); + my $src = get_src_dir($src_ls_fh); 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.'; +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 $fn = get_tmp_extfn($tempfh); my $cmd = "/usr/sbin/convertpkg-compat32 -i $pkg -d $tmpd | tee $fn"; if (system($cmd) != 0) { return "convertpkg-compt32 returned non-zero exit status\n", _ERR_CONVERTPKG; } unlink $pkg; - return get_pkg_name $tempfh; + return get_pkg_name($tempfh); } # "public interface", sort of thing. @@ -820,12 +821,12 @@ sub do_slackbuild { COMPAT32 => 0, @_ ); - $args{LOCATION} or script_error 'do_slackbuild requires LOCATION.'; + $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 $multilib = check_multilib; - my $version = get_sbo_version $location; + my $sbo = get_sbo_from_loc($location); + my $arch = get_arch(); + my $multilib = 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}) { @@ -858,7 +859,7 @@ sub do_slackbuild { ); return $pkg, (undef) x 2, $exit if $exit; if ($args{COMPAT32}) { - ($pkg, $exit) = do_convertpkg $pkg; + ($pkg, $exit) = do_convertpkg($pkg); return $pkg, (undef) x 2, $exit if $exit; } return $version, $pkg, $src; @@ -873,7 +874,7 @@ sub make_clean { @_ ); unless ($args{SBO} && $args{SRC} && $args{VERSION}) { - script_error 'make_clean requires three arguments.'; + script_error('make_clean requires three arguments.'); } my $src = $args{SRC}; say "Cleaning for $args{SBO}-$args{VERSION}..."; @@ -898,29 +899,29 @@ sub make_distclean { @_ ); unless ($args{SRC} && $args{VERSION} && $args{LOCATION}) { - script_error 'make_distclean requires four arguments.'; + script_error('make_distclean requires four arguments.'); } - my $sbo = get_sbo_from_loc $args{LOCATION}; + my $sbo = get_sbo_from_loc($args{LOCATION}); make_clean(SBO => $sbo, SRC => $args{SRC}, VERSION => $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; + 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; } # wrapper to pull the list of requirements for a given sbo -sub get_requires($) { +sub get_requires { my $location = get_sbo_location(shift); return unless $location; my $info = get_from_info(LOCATION => $location, GET => 'REQUIRES'); @@ -933,7 +934,7 @@ sub add_to_queue { my $sbo = \${$args}{NAME}; return unless $$sbo; push @{ $args->{QUEUE} }, $$sbo; - my $requires = get_requires $$sbo; + my $requires = get_requires($$sbo); FIRST: for my $req (@$requires) { next FIRST if $req eq $$sbo; if ($req eq "%README%") { @@ -947,7 +948,7 @@ sub add_to_queue { # recursively add a sbo's requirements to the build queue. sub get_build_queue { - exists $_[1] or script_error 'get_build_queue requires two arguments.'; + exists $_[1] or script_error('get_build_queue requires two arguments.'); my ($sbos, $warnings) = @_; my $temp_queue = []; for my $sbo (@$sbos) { @@ -969,7 +970,7 @@ sub get_build_queue { sub merge_queues { # Usage: merge_queues(\@queue_a, \@queue_b); # Results in queue_b being merged into queue_a (without duplicates) - exists $_[1] or script_error 'merge_queues requires two arguments.'; + exists $_[1] or script_error('merge_queues requires two arguments.'); my $queue_a = $_[0]; my $queue_b = $_[1]; @@ -982,8 +983,8 @@ sub merge_queues { return $queue_a; } -sub get_readme_contents($) { - exists $_[0] or script_error 'get_readme_contents requires an argument.'; +sub get_readme_contents { + exists $_[0] or script_error('get_readme_contents requires an argument.'); my ($fh, $exit) = open_read(shift .'/README'); return undef, $exit if $exit; my $readme = do {local $/; <$fh>}; @@ -992,14 +993,14 @@ sub get_readme_contents($) { } # return a list of perl modules installed via the CPAN -sub get_installed_cpans() { +sub get_installed_cpans { my @locals; for my $dir (@INC) { push @locals, "$dir/perllocal.pod" if -f "$dir/perllocal.pod"; } my @contents; for my $file (@locals) { - my ($fh, $exit) = open_read $file; + my ($fh, $exit) = open_read($file); return [] if $exit; # push @contents, grep {/Module|VERSION/} <$fh>; push @contents, grep {/Module/} <$fh>; @@ -1019,8 +1020,8 @@ sub get_installed_cpans() { } # look for any (user|group)add commands in the README -sub get_user_group($) { - exists $_[0] or script_error 'get_user_group requires an argument'; +sub get_user_group { + exists $_[0] or script_error('get_user_group requires an argument'); my $readme = shift; my @cmds = $readme =~ /^\s*#*\s*(useradd.*|groupadd.*)/mg; return \@cmds; @@ -1028,7 +1029,7 @@ sub get_user_group($) { # offer to run any user/group add commands sub ask_user_group { - exists $_[1] or script_error 'ask_user_group requires two arguments'; + exists $_[1] or script_error('ask_user_group requires two arguments'); my ($cmds, $readme) = @_; say "\n". $readme; print "\nIt looks like this slackbuild requires the following"; @@ -1039,32 +1040,32 @@ sub ask_user_group { } # see if the README mentions any options -sub get_opts($) { - exists $_[0] or script_error 'get_opts requires an argument'; +sub get_opts { + exists $_[0] or script_error('get_opts requires an argument'); my $readme = shift; return $readme =~ /[A-Z0-9]+=[^\s]/ ? 1 : undef; } # provide an opportunity to set options sub ask_opts { - exists $_[0] or script_error 'ask_opts requires an argument'; + exists $_[0] or script_error('ask_opts requires an argument'); my ($sbo, $readme) = @_; say "\n". $readme; print "\nIt looks like $sbo 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 if $opts =~ /^\n/; return $opts; }; my $kv_regex = qr/[A-Z0-9]+=[^\s]+(|\s([A-Z]+=[^\s]+){0,})/; - my $opts = &$ask; + my $opts = $ask->(); return unless $opts; while ($opts !~ $kv_regex) { warn "Invalid input received.\n"; - $opts = &$ask; + $opts = $ask->(); } return $opts; } @@ -1073,17 +1074,17 @@ sub ask_opts { # for a given sbo, check for cmds/opts, prompt the user as appropriate sub user_prompt { - exists $_[1] or script_error 'user_prompt requires two arguments.'; + exists $_[1] or script_error('user_prompt requires two arguments.'); my ($sbo, $location) = @_; - my ($readme, $exit) = get_readme_contents $location; + my ($readme, $exit) = get_readme_contents($location); return $readme, undef, $exit if $exit; # check for user/group add commands, offer to run any found - my $user_group = get_user_group $readme; + my $user_group = get_user_group($readme); my $cmds; $cmds = ask_user_group($user_group, $readme) if $$user_group[0]; # check for options mentioned in the README my $opts = 0; - $opts = ask_opts($sbo, $readme) if get_opts $readme; + $opts = ask_opts($sbo, $readme) if get_opts($readme); print "\n". $readme unless $opts; print "\nProceed with $sbo? [y]: "; # we have to return something substantial if the user says no so that we @@ -1112,7 +1113,7 @@ sub process_sbos { my $opts = $args{OPTS}; my $locs = $args{LOCATIONS}; my $jobs = $args{JOBS} =~ /^\d+$/ ? $args{JOBS} : 0; - exists $$todo[0] or script_error 'process_sbos requires TODO.'; + exists $$todo[0] or script_error('process_sbos requires TODO.'); my (@failures, @symlinks, $temp_syms, $exit); FIRST: for my $sbo (@$todo) { my $compat32 = $sbo =~ /-compat32$/ ? 1 : 0; @@ -1172,7 +1173,7 @@ sub process_sbos { } } - do_upgradepkg $pkg unless $args{NOINSTALL}; + do_upgradepkg($pkg) unless $args{NOINSTALL}; unless ($args{DISTCLEAN}) { make_clean(SBO => $sbo, SRC => $src, VERSION => $version) @@ -18,7 +18,7 @@ use File::Basename; my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self @@ -35,15 +35,15 @@ my ($help, $vers); GetOptions('help|h' => \$help, 'version|v' => \$vers); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; -update_tree; +update_tree(); # retrieve and format list of available updates -sub get_update_list() { +sub get_update_list { print "Checking for updated SlackBuilds...\n"; - my $updates = get_available_updates; + my $updates = get_available_updates(); return unless exists $$updates[0]; # consistent formatting - determine longest version string, which will tell # us the max minimum length of the left side of the output for stuff that @@ -76,8 +76,8 @@ sub get_update_list() { } # print list of updates -sub print_output($) { - exists $_[0] or script_error 'print_output requires an argument'; +sub print_output { + exists $_[0] or script_error('print_output requires an argument'); my $listing = shift; if (exists $$listing[0]) { print "\n"; @@ -100,7 +100,7 @@ sub print_output($) { } } -my $output = get_update_list; -print_output $output; +my $output = get_update_list(); +print_output($output); exit 0; @@ -19,7 +19,7 @@ use File::Path qw(remove_tree); my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self (options) [package] @@ -48,14 +48,14 @@ GetOptions( 'interactive|i' => \$interactive, ); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; -usage_error "You must specify at least one of -d or -w." unless +usage_error("You must specify at least one of -d or -w.") unless ($clean_dist || $clean_work); -sub rm_full($) { - exists $_[0] or script_error 'rm_full requires an argument.'; +sub rm_full { + exists $_[0] or script_error('rm_full requires an argument.'); my $full = shift; if ($interactive) { print "Remove $full? [n] "; @@ -66,27 +66,27 @@ sub rm_full($) { return 1; } -sub remove_stuff($) { +sub remove_stuff { exists $_[0] or script_error 'remove_stuff requires an argument.'; -d $_[0] or say 'Nothing to do.' and return 1; my $dir = shift; opendir(my $dh, $dir); FIRST: while (my $ls = readdir $dh) { next FIRST if $ls =~ /^(\.){1,2}$/; - rm_full "$dir/$ls"; + rm_full("$dir/$ls"); } } -sub clean_c32() { +sub clean_c32 { my $dir = $SBO::Lib::tmpd; opendir(my $dh, $dir); FIRST: while (my $ls = readdir $dh) { next FIRST unless $ls =~ /^package-.+-compat32$/; - rm_full "$dir/$ls"; + rm_full("$dir/$ls"); } } -remove_stuff $config{SBO_HOME} .'/distfiles' if $clean_dist; +remove_stuff($config{SBO_HOME} .'/distfiles') if $clean_dist; if ($clean_work) { my $env_tmp = $SBO::Lib::env_tmp; @@ -94,11 +94,11 @@ if ($clean_work) { if ($env_tmp && !$interactive) { warn "This will remove the entire contents of $env_tmp\n"; print "Proceed? [y] "; - remove_stuff $tsbo if <STDIN> =~ /^[yY\n]/; + remove_stuff($tsbo) if <STDIN> =~ /^[yY\n]/; } else { - remove_stuff $tsbo; + remove_stuff($tsbo); } - clean_c32; + clean_c32(); } exit 0; @@ -21,7 +21,7 @@ use File::Temp qw(tempfile);; my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self [options] [arguments] @@ -50,8 +50,8 @@ my %options; GetOptions(\%options, 'help|h', 'version|v', 'list|l', 'noclean|c=s', 'distclean|d=s', 'jobs|j=s', 'pkg-dir|p=s', 'sbo-home|s=s'); -show_usage and exit 0 if exists $options{help}; -show_version and exit 0 if exists $options{version}; +show_usage() and exit 0 if exists $options{help}; +show_version() and exit 0 if exists $options{version}; my %valid_confs = ( noclean => 'NOCLEAN', @@ -75,7 +75,7 @@ if (exists $options{list}) { exit 0; } -show_usage and exit 0 unless keys %options > 0; +show_usage() and exit 0 unless keys %options > 0; # setup what's being changed, sanity check. my %changes; @@ -86,19 +86,19 @@ while (my ($key, $value) = each %valid_confs) { my $warn = 'You have provided an invalid parameter for'; if (exists $changes{NOCLEAN}) { - usage_error "$warn -c" unless $changes{NOCLEAN} =~ /^(TRUE|FALSE)$/; + usage_error("$warn -c") unless $changes{NOCLEAN} =~ /^(TRUE|FALSE)$/; } if (exists $changes{DISTCLEAN}) { - usage_error "$warn -d" unless $changes{DISTCLEAN} =~ /^(TRUE|FALSE)$/; + usage_error("$warn -d") unless $changes{DISTCLEAN} =~ /^(TRUE|FALSE)$/; } if (exists $changes{JOBS}) { - usage_error "$warn -j" unless $changes{JOBS} =~ /^(\d+|FALSE)$/; + usage_error("$warn -j") unless $changes{JOBS} =~ /^(\d+|FALSE)$/; } if (exists $changes{PKG_DIR}) { - usage_error "$warn -p" unless $changes{PKG_DIR} =~ qr#^(/|FALSE$)#; + usage_error("$warn -p") unless $changes{PKG_DIR} =~ qr#^(/|FALSE$)#; } if (exists $changes{SBO_HOME}) { - usage_error "$warn -s" unless $changes{SBO_HOME} =~ qr#^/#; + usage_error("$warn -s") unless $changes{SBO_HOME} =~ qr#^/#; } # safely modify our conf file; write its contents to a temp file, modify the @@ -107,14 +107,14 @@ if (exists $changes{SBO_HOME}) { # them all at once, instead of only a single one and having to call it once for # each option specified to the script. sub config_write { - exists $_[1] or script_error 'config_write requires two arguments.'; + exists $_[1] or script_error('config_write requires two arguments.'); my ($key, $val) = @_; if (! -d $conf_dir) { - mkdir $conf_dir or usage_error "Unable to create $conf_dir. Exiting."; + mkdir $conf_dir or usage_error("Unable to create $conf_dir. Exiting."); } if (-f $conf_file) { my $tempfh = tempfile(DIR => $tempdir); - my ($conffh, $exit) = open_read $conf_file; + my ($conffh, $exit) = open_read($conf_file); if ($exit) { warn $conffh; exit $exit; @@ -7,6 +7,7 @@ # # authors: Jacob Pipkin <j@dawnrazor.net> # Luke Williams <xocel@iquidus.org> +# Andreas Guldstrand <andreas.guldstrand@gmail.com> # license: WTFPL <http://sam.zoy.org/wtfpl/COPYING> use 5.16.0; @@ -18,7 +19,7 @@ use Getopt::Long qw(:config bundling); my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self (search_term) @@ -50,17 +51,17 @@ GetOptions( 'queue|q' => \$show_queue, ); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; -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 -sub perform_search($) { +sub perform_search { exists $_[0] or script_error 'perform_search requires an argument.'; my $search = shift; my (@findings, $name, $found); @@ -86,10 +87,10 @@ sub perform_search($) { } # pull the contents of a file into a variable and format it for output -sub get_file_contents($) { +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, $exit) = open_read shift; + my ($fh, $exit) = open_read(shift); if ($exit) { warn $fh; return; @@ -103,24 +104,23 @@ sub get_file_contents($) { } # get build queue and return it as a single line. -sub show_build_queue($) { - exists $_[0] or script_error 'show_build_queue requires an argument.'; +sub show_build_queue { + exists $_[0] or script_error('show_build_queue requires an argument.'); my $queue = get_build_queue([shift], {}); return join(" ", reverse @$queue); } -my $findings = perform_search $search; +my $findings = perform_search($search); # pretty formatting if (exists $$findings[0]) { - my @listing = ("\n"); for my $hash (@$findings) { while (my ($key, $val) = each %$hash) { say "SBo: $key"; say "Path: $val"; - say "info: ". get_file_contents "$val/$key.info" if $show_info; - say "README: ". get_file_contents "$val/README" if $show_readme; - say "Queue: ". show_build_queue "$key" if $show_queue; + say "info: ". get_file_contents("$val/$key.info") if $show_info; + say "README: ". get_file_contents("$val/README") if $show_readme; + say "Queue: ". show_build_queue("$key") if $show_queue; say ''; } } @@ -18,7 +18,7 @@ use File::Basename; my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self [options] sbo @@ -62,24 +62,24 @@ GetOptions( 'norequirements|R' => \$no_reqs, ); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; -show_usage and exit 1 unless exists $ARGV[0]; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; +show_usage() and exit 1 unless exists $ARGV[0]; $noclean = $noclean eq 'TRUE' ? 1 : 0; $distclean = $distclean eq 'TRUE' ? 1 : 0; if ($jobs) { - usage_error "You have provided an invalid value for -j|--jobs" + usage_error("You have provided an invalid value for -j|--jobs") unless ($jobs =~ /^\d+$/ || $jobs eq 'FALSE'); } if ($compat32) { - usage_error "compat32 only works on x86_64." unless get_arch eq 'x86_64'; + usage_error("compat32 only works on x86_64.") unless get_arch eq 'x86_64'; } # if we can't find SLACKBUILDS.TXT in $config{HOME}, prompt to fetch the tree -slackbuilds_or_fetch; +slackbuilds_or_fetch(); my (%warnings, $build_queue, %locations); @@ -95,17 +95,17 @@ if ($no_reqs or $non_int) { # populate %locations and sanity check %locations = get_sbo_location($build_queue); for my $sbo (@$build_queue) { - usage_error "Unable to locate $sbo in the SlackBuilds.org tree." unless + usage_error("Unable to locate $sbo in the SlackBuilds.org tree.") unless $locations{$sbo}; if ($compat32) { - usage_error "-p|--compat32 is not supported with Perl SBos." + usage_error("-p|--compat32 is not supported with Perl SBos.") if $locations{$sbo} =~ qr|/perl/[^/]+$|; } } # get lists of installed packages and perl modules from CPAN my $inst_names = get_inst_names(get_installed_packages 'ALL'); -my $pms = get_installed_cpans; +my $pms = get_installed_cpans(); s/::/-/g for @$pms; # check for already-installeds and prompt for the rest @@ -18,7 +18,7 @@ use File::Basename; my $self = basename ($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self [options] sbo @@ -44,9 +44,9 @@ GetOptions( 'alwaysask|a' => \$alwaysask, ); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; -show_usage and exit 1 unless exists $ARGV[0]; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; +show_usage() and exit 1 unless exists $ARGV[0]; # ensure that all provided arguments are valid sbos my @sbos; @@ -78,7 +78,7 @@ my (%required_by, @confirmed); sub get_reverse_reqs($) { my $installed = shift; FIRST: for my $inst (@$installed) { - my $require = get_requires $inst; + my $require = get_requires($inst); next FIRST unless $$require[0]; SECOND: for my $req (@$require) { unless ( $req eq '%README%' ) { @@ -92,11 +92,11 @@ sub get_reverse_reqs($) { } } } -get_reverse_reqs $inst_names; +get_reverse_reqs($inst_names); # returns a list of installed sbo's that list the given sbo as a requirement, # excluding any installed sbo's that have already been confirmed for removal -sub get_required_by($) { +sub get_required_by { my $sbo = shift; my @dep_of; if ( $required_by{$sbo} ) { @@ -111,7 +111,7 @@ sub get_required_by($) { return exists $dep_of[0] ? \@dep_of : undef; } -sub confirm_remove($) { +sub confirm_remove { my $sbo = shift; my $found = 0; for my $conf (@confirmed) { @@ -131,7 +131,7 @@ if ($inst_names) { # Confirm all and skip prompts if noninteractive if ($non_int) { - confirm_remove $_ for @$remove_queue; + confirm_remove($_) for @$remove_queue; goto CONFIRMED; } @@ -19,7 +19,7 @@ use Getopt::Long; my $sbo_home = $config{SBO_HOME}; my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self [options|command] @@ -37,24 +37,24 @@ Commands: EOF } -show_usage and exit 1 unless exists $ARGV[0]; +show_usage() and exit 1 unless exists $ARGV[0]; my ($help, $vers); GetOptions('help|h' => \$help, 'version|v' => \$vers); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; # 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; } -if ($command eq 'fetch') { fetch_tree } -elsif ($command eq 'update') { update_tree } +if ($command eq 'fetch') { fetch_tree() } +elsif ($command eq 'update') { update_tree() } exit 0; @@ -19,7 +19,7 @@ use File::Copy; my $self = basename($0); -sub show_usage() { +sub show_usage { print <<EOF Usage: $self (options) [package] @@ -68,27 +68,27 @@ GetOptions( 'compat32|p' => \$compat32, ); -show_usage and exit 0 if $help; -show_version and exit 0 if $vers; -show_usage and exit 1 unless exists $ARGV[0]; +show_usage() and exit 0 if $help; +show_version() and exit 0 if $vers; +show_usage() and exit 1 unless exists $ARGV[0]; $noclean = $noclean eq 'TRUE' ? 1 : 0; $distclean = $distclean eq 'TRUE' ? 1 : 0; if ($jobs) { - usage_error "You have provided an invalid value for -j|--jobs" + usage_error("You have provided an invalid value for -j|--jobs") unless ($jobs =~ /^\d+$/ || $jobs eq 'FALSE'); } -usage_error "-r|--nointeractive and -z|--force-reqs can not be used together." +usage_error("-r|--nointeractive and -z|--force-reqs can not be used together.") if $non_int && $force_reqs; -usage_error "-R|--norequirements does not make sense without -N|--installnew" +usage_error("-R|--norequirements does not make sense without -N|--installnew") if $no_reqs && ! $install_new; -usage_error "-p|--compat32 does not make sense without -N|--installnew" +usage_error("-p|--compat32 does not make sense without -N|--installnew") if $compat32 && ! $install_new; # if we can't find SLACKBUILDS.TXT in $config{HOME}, prompt to fetch the tree -slackbuilds_or_fetch; +slackbuilds_or_fetch(); my @sbos = @ARGV; @@ -98,16 +98,16 @@ for my $sbo (@sbos) { my $name = $sbo; $name =~ s/-compat32//; $locations{$sbo} = get_sbo_location($name); - usage_error "Unable to locate $sbo in the SlackBuilds.org tree." unless + usage_error("Unable to locate $sbo in the SlackBuilds.org tree.") unless $locations{$sbo}; if ($sbo =~ /-compat32$/) { - usage_error "compat32 Perl SBos are not supported." + usage_error("compat32 Perl SBos are not supported.") if $locations{$sbo} =~ qr|/perl/[^/]+$|; } } # get a list of installed SBos to check upgradability against -my $inst_names = get_inst_names(get_installed_packages 'SBO'); +my $inst_names = get_inst_names(get_installed_packages('SBO')); my %inst_names; $inst_names{$_} = 1 for @$inst_names; @@ -144,7 +144,7 @@ my $upgrade_queue; # but without force, we only want to update what there are updates for unless ($force) { my %updates; - my $updates = get_available_updates; + my $updates = get_available_updates(); $updates{$$_{name}} = 1 for @$updates; for my $sbo (@sbos) { push @$upgrade_queue, $sbo if $updates{$sbo}; |