diff options
Diffstat (limited to 'SBO-Lib/lib/SBO/Lib.pm')
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib.pm | 247 |
1 files changed, 124 insertions, 123 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) |