diff --git a/.DS_Store b/.DS_Store index f90eb78..14c6eda 100644 Binary files a/.DS_Store and b/.DS_Store differ diff --git a/CHANGELOG.md b/CHANGELOG.md index 5ba0ac3..90660f4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,9 @@ # Changelog All notable changes to this project will be documented in this file. -## [0.1.5.3] -- Preferences window - +## [0.1.6] +- Preferences, version, console menu items +- Fix UTF-8 character bug ## [0.1.5] - Add version check diff --git a/MainMenu.nib/designable.nib b/MainMenu.nib/designable.nib index 85e3e14..ddedaac 100644 --- a/MainMenu.nib/designable.nib +++ b/MainMenu.nib/designable.nib @@ -164,6 +164,12 @@ Gw + + + + + + @@ -483,6 +489,12 @@ Gw + + + + + + @@ -708,5 +720,11 @@ Gw + + + + + + diff --git a/MainMenu.nib/keyedobjects.nib b/MainMenu.nib/keyedobjects.nib index 20f9b37..524b4f3 100644 Binary files a/MainMenu.nib/keyedobjects.nib and b/MainMenu.nib/keyedobjects.nib differ diff --git a/Minat.php b/Minat.php index c2b24e3..ff72a04 100755 --- a/Minat.php +++ b/Minat.php @@ -9,14 +9,6 @@ $version = file_get_contents(__DIR__."/version.txt"); require (__DIR__."/functions.php"); -// Check for translocation - -if (!@touch(__DIR__."/test")) { - alert("Minat cannot run from the Downloads folder"); - quitme(); - die; - } - // Prefs $prefs = __DIR__."/prefs.php"; @@ -29,6 +21,8 @@ if (!file_exists($prefs)) { $p = unserialize(file_get_contents($prefs)); + // Extra prefs + $p['phpbin'] = "/usr/bin/php"; $p['flacbin'] = __DIR__."/bin/flac"; $p['metaflacbin'] = __DIR__."/bin/metaflac"; @@ -44,33 +38,8 @@ if (!file_exists($prefs)) { } -// Version check - -if (strpos(__FILE__,".app")) { - - $checkfile = __DIR__."/vcheck"; - - if (!file_exists($checkfile) | time()-@filemtime($checkfile) > 86400) { - $curr_version = file_get_contents("http://git.profiteroles.org/profiteroles/Minat/raw/branch/master/version.txt"); - addline("Version check, me=".$version." latest=".$curr_version); - if ($curr_version > $version) { - if(askMulti("A new version of Minat is available", array("Skip","Download")) == 1) { - exec("open http://git.profiteroles.org/profiteroles/Minat"); - quitme(); - } - } - touch($checkfile); - } - } - if ($p['mode'] != 1) { $p['premature'] = 1; addline("MODE ".$p['mode']." NOT YET IMPLEMENTED."); } -// If SHIFT key is held down, open debug window - -if(exec(__DIR__."/bin/keys") == 512) { - exec("open -n Console.app --args ".$p['logfile']); - } - // Make work dir if (!is_dir($p['workdir'])) { @@ -99,12 +68,39 @@ if(count($argv) == 0) { die; } +// Preferences + if ($argv[0] == "Preferences...") { exec($p['phpbin']." ".__DIR__."/MinatPrefs.php"); addline("Launch preferences"); die; } +// Version check + +if ($argv[0] == "Check for Updates...") { + + $curr_version = file_get_contents("http://git.profiteroles.org/profiteroles/Minat/raw/branch/master/version.txt"); + addline("Version check, me=".$version." latest=".$curr_version); + if ($curr_version > $version) { + if(askMulti("Minat ".$curr_version." is available (you have ".$version.")", array("Cancel","Download")) == 1) { + exec("open http://git.profiteroles.org/profiteroles/Minat"); + die; + } + } else { + alert($version." is the latest version","Up-to-date"); + die; + } + + } + +// Console + +if ($argv[0] == "Show Debug Console") { + exec("open -n Console.app --args ".$p['logfile']); + die; + } + $stamp = md5(serialize($argv))."_".time(); $workdir = $p['workdir'].$stamp."/"; $batchfile = $workdir.$stamp.".sh"; @@ -182,6 +178,9 @@ foreach ($argv as $target) { $mimecmd = $p['metaflacbin']." --list --block-type=PICTURE ".escapeshellarg($files[0])." | head -10 | grep MIME | sed 's:.*/::'"; addline($mimecmd); $mime = exec($mimecmd); + if ($mime == " MIME type:") { + $mime = "pic"; + } if (@$mime) { @@ -248,7 +247,7 @@ foreach ($argv as $target) { $dest = $destdir.basename($file,".flac").".mp3"; $lockfile = $workdir.md5($target).".".basename($file,".flac").".lock"; $cmd_flac = $p['flacbin']." -dcs -- ".escapeshellarg($file); - $cmd_lame = $p['lamebin']." -S ".$p['lameopts']." ".$tags." ".$covertags." - ".escapeshellarg($dest); + $cmd_lame = $p['lamebin']." -S ".$p['lameopts']." --id3v2-utf16 ".$tags." ".$covertags." - ".escapeshellarg($dest); $cmd_lock = "touch ".escapeshellarg($lockfile); $line[] = $cmd_flac." | ".$cmd_lame." ; ".$cmd_lock; diff --git a/Parallel/.DS_Store b/Parallel/.DS_Store new file mode 100644 index 0000000..32de611 Binary files /dev/null and b/Parallel/.DS_Store differ diff --git a/Parallel/Parallel.php b/Parallel/Parallel.php index 103363e..69d2763 100755 --- a/Parallel/Parallel.php +++ b/Parallel/Parallel.php @@ -9,6 +9,10 @@ if ($argv[3]) { $log = $argv[3]; } else { $log = "/dev/null"; } echo "Starting ".$lines." threads..."; +$locale="en_US.UTF-8"; +setlocale(LC_ALL, $locale); +putenv("LC_ALL=".$locale); + exec(__DIR__."/parallel < ".escapeshellarg($argv[1])." >> ".$log." 2>&1 &"); echo "\nPROGRESS:0\n"; diff --git a/Parallel/parallel b/Parallel/parallel index 2f96b4b..808aac3 100755 --- a/Parallel/parallel +++ b/Parallel/parallel @@ -1,7 +1,6 @@ #!/opt/local/bin/perl -# Copyright (C) 2007,2008,2009,2010,2011,2012,2013,2014,2015,2016, -# 2017,2018 Ole Tange and Free Software Foundation, Inc. +# Copyright (C) 2007-2019 Ole Tange and Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -34,113 +33,8 @@ use Getopt::Long; use strict; use File::Basename; -save_stdin_stdout_stderr(); -save_original_signal_handler(); -parse_options(); -::debug("init", "Open file descriptors: ", join(" ",keys %Global::fd), "\n"); -my $number_of_args; -if($Global::max_number_of_args) { - $number_of_args = $Global::max_number_of_args; -} elsif ($opt::X or $opt::m or $opt::xargs) { - $number_of_args = undef; -} else { - $number_of_args = 1; -} - -my @command = @ARGV; -my @input_source_fh; -if($opt::pipepart) { - if($opt::tee) { - @input_source_fh = map { open_or_exit($_) } @opt::a; - # Remove the first: It will be the file piped. - shift @input_source_fh; - if(not @input_source_fh and not $opt::pipe) { - @input_source_fh = (*STDIN); - } - } else { - # -a is used for data - not for command line args - @input_source_fh = map { open_or_exit($_) } "/dev/null"; - } -} else { - @input_source_fh = map { open_or_exit($_) } @opt::a; - if(not @input_source_fh and not $opt::pipe) { - @input_source_fh = (*STDIN); - } -} -if($opt::sqlmaster) { - # Create SQL table to hold joblog + output - $Global::sql->create_table($#input_source_fh+1); - if($opt::sqlworker) { - # Start a real --sqlworker in the background later - $Global::start_sqlworker = 1; - $opt::sqlworker = undef; - } -} - -if($opt::skip_first_line) { - # Skip the first line for the first file handle - my $fh = $input_source_fh[0]; - <$fh>; -} - -set_input_source_header(); - -if($opt::filter_hosts and (@opt::sshlogin or @opt::sshloginfile)) { - # Parallel check all hosts are up. Remove hosts that are down - filter_hosts(); -} - -if($opt::nonall or $opt::onall) { - onall(\@input_source_fh,@command); - wait_and_exit(min(undef_as_zero($Global::exitstatus),254)); -} - -$Global::JobQueue = JobQueue->new( - \@command,\@input_source_fh,$Global::ContextReplace, - $number_of_args,\@Global::transfer_files,\@Global::ret_files); - -if($opt::pipepart) { - pipepart_setup(); -} elsif($opt::pipe and $opt::tee) { - pipe_tee_setup(); -} - -if($opt::eta or $opt::bar or $opt::shuf or $Global::halt_pct) { - # Count the number of jobs or shuffle all jobs - # before starting any. - # Must be done after ungetting any --pipepart jobs. - $Global::JobQueue->total_jobs(); -} -# Compute $Global::max_jobs_running -# Must be done after ungetting any --pipepart jobs. -max_jobs_running(); - -init_run_jobs(); -my $sem; -if($Global::semaphore) { - $sem = acquire_semaphore(); -} -$SIG{TERM} = \&start_no_new_jobs; -start_more_jobs(); -if($opt::tee) { - # All jobs must be running in parallel for --tee - $Global::start_no_new_jobs = 1; -} elsif($opt::pipe and not $opt::pipepart) { - spreadstdin(); -} -::debug("init", "Start draining\n"); -drain_job_queue(); -::debug("init", "Done draining\n"); -reaper(); -::debug("init", "Done reaping\n"); -if($Global::semaphore) { - $sem->release(); -} -cleanup(); -::debug("init", "Halt\n"); -halt(); - -sub set_input_source_header { +sub set_input_source_header($$) { + my ($command_ref,$input_source_fh_ref) = @_; if($opt::header and not $opt::pipe) { # split with colsep or \t # $header force $colsep = \t if undef? @@ -152,15 +46,16 @@ sub set_input_source_header { my $right = "\Q$Global::parensright\E"; my $r = $Global::parensright; my $id = 1; - for my $fh (@input_source_fh) { + for my $fh (@$input_source_fh_ref) { my $line = <$fh>; chomp($line); ::debug("init", "Delimiter: '$delimiter'"); for my $s (split /$delimiter/o, $line) { ::debug("init", "Colname: '$s'"); # Replace {colname} with {2} - for(@command,@Global::ret_files,@Global::transfer_files, - $opt::tagstring, $opt::workdir, $opt::results, $opt::retries) { + for(@$command_ref,@Global::ret_files,@Global::transfer_files, + $opt::tagstring, $opt::workdir, $opt::results, + $opt::retries) { # Skip if undefined $_ or next; s:\{$s(|/|//|\.|/\.)\}:\{$id$1\}:g; @@ -173,28 +68,31 @@ sub set_input_source_header { } } else { my $id = 1; - for my $fh (@input_source_fh) { + for my $fh (@$input_source_fh_ref) { $Global::input_source_header{$id} = $id; $id++; } } } -sub max_jobs_running { +sub max_jobs_running() { # Compute $Global::max_jobs_running as the max number of jobs # running on each sshlogin. # Returns: # $Global::max_jobs_running if(not $Global::max_jobs_running) { - for my $sshlogin (values %Global::host) { $sshlogin->max_jobs_running(); } } + if(not $Global::max_jobs_running) { + ::error("Cannot run any jobs."); + wait_and_exit(255); + } return $Global::max_jobs_running; } -sub halt { +sub halt() { # Compute exit value, # wait for children to complete # and exit @@ -202,7 +100,8 @@ sub halt { if(not defined $Global::halt_exitstatus) { if($Global::halt_pct) { $Global::halt_exitstatus = - ::ceil($Global::total_failed / $Global::total_started * 100); + ::ceil($Global::total_failed / + ($Global::total_started || 1) * 100); } elsif($Global::halt_count) { $Global::halt_exitstatus = ::min(undef_as_zero($Global::total_failed),101); @@ -214,9 +113,11 @@ sub halt { } } -sub __PIPE_MODE__ {} -sub pipepart_setup { +sub __PIPE_MODE__() {} + + +sub pipepart_setup() { # Compute the blocksize # Generate the commands to extract the blocks # Push the commands on queue @@ -226,7 +127,7 @@ sub pipepart_setup { if($opt::tee) { # Prepend each command with # < file - my $cat_string = "< ".::shell_quote_scalar($opt::a[0]); + my $cat_string = "< ".Q($opt::a[0]); for(1..$Global::JobQueue->total_jobs()) { push @Global::cat_appends, $cat_string; push @Global::cat_prepends, ""; @@ -262,12 +163,12 @@ sub pipepart_setup { @Global::cat_prepends = map { pipe_part_files($_) } @opt::a; # Unget the empty arg as many times as there are parts $Global::JobQueue->{'commandlinequeue'}{'arg_queue'}->unget( - map { [Arg->new("\0")] } @Global::cat_prepends + map { [Arg->new("\0noarg")] } @Global::cat_prepends ); } } -sub pipe_tee_setup { +sub pipe_tee_setup() { # Create temporary fifos # Run 'tee fifo1 fifo2 fifo3 ... fifoN' in the background # This will spread the input to fifos @@ -295,7 +196,257 @@ sub pipe_tee_setup { @Global::cat_appends = map { ") < $_" } @fifos; } -sub pipe_part_files { + +sub parcat_script() { + # TODO if script fails: Use parallel -j0 --plain --lb cat ::: fifos + my $script = q'{ + use POSIX qw(:errno_h); + use IO::Select; + use strict; + use threads; + use Thread::Queue; + use Fcntl qw(:DEFAULT :flock); + + my $opened :shared; + my $q = Thread::Queue->new(); + my $okq = Thread::Queue->new(); + my @producers; + + if(not @ARGV) { + if(-t *STDIN) { + print "Usage:\n"; + print " parcat file(s)\n"; + print " cat argfile | parcat\n"; + } else { + # Read arguments from stdin + chomp(@ARGV = ); + } + } + my $files_to_open = 0; + # Default: fd = stdout + my $fd = 1; + for (@ARGV) { + # --rm = remove file when opened + /^--rm$/ and do { $opt::rm = 1; next; }; + # -1 = output to fd 1, -2 = output to fd 2 + /^-(\d+)$/ and do { $fd = $1; next; }; + push @producers, threads->create("producer", $_, $fd); + $files_to_open++; + } + + sub producer { + # Open a file/fifo, set non blocking, enqueue fileno of the file handle + my $file = shift; + my $output_fd = shift; + open(my $fh, "<", $file) || do { + print STDERR "parcat: Cannot open $file\n"; + exit(1); + }; + # Remove file when it has been opened + if($opt::rm) { + unlink $file; + } + set_fh_non_blocking($fh); + $opened++; + # Pass the fileno to parent + $q->enqueue(fileno($fh),$output_fd); + # Get an OK that the $fh is opened and we can release the $fh + while(1) { + my $ok = $okq->dequeue(); + if($ok == fileno($fh)) { last; } + # Not ours - very unlikely to happen + $okq->enqueue($ok); + } + return; + } + + my $s = IO::Select->new(); + my %buffer; + + sub add_file { + my $infd = shift; + my $outfd = shift; + open(my $infh, "<&=", $infd) || die; + open(my $outfh, ">&=", $outfd) || die; + $s->add($infh); + # Tell the producer now opened here and can be released + $okq->enqueue($infd); + # Initialize the buffer + @{$buffer{$infh}{$outfd}} = (); + $Global::fh{$outfd} = $outfh; + } + + sub add_files { + # Non-blocking dequeue + my ($infd,$outfd); + do { + ($infd,$outfd) = $q->dequeue_nb(2); + if(defined($outfd)) { + add_file($infd,$outfd); + } + } while(defined($outfd)); + } + + sub add_files_block { + # Blocking dequeue + my ($infd,$outfd) = $q->dequeue(2); + add_file($infd,$outfd); + } + + + my $fd; + my (@ready,$infh,$rv,$buf); + do { + # Wait until at least one file is opened + add_files_block(); + while($q->pending or keys %buffer) { + add_files(); + while(keys %buffer) { + @ready = $s->can_read(0.01); + if(not @ready) { + add_files(); + } + for $infh (@ready) { + # There is only one key, namely the output file descriptor + for my $outfd (keys %{$buffer{$infh}}) { + $rv = sysread($infh, $buf, 65536); + if (!$rv) { + if($! == EAGAIN) { + # Would block: Nothing read + next; + } else { + # Nothing read, but would not block: + # This file is done + $s->remove($infh); + for(@{$buffer{$infh}{$outfd}}) { + syswrite($Global::fh{$outfd},$_); + } + delete $buffer{$infh}; + # Closing the $infh causes it to block + # close $infh; + add_files(); + next; + } + } + # Something read. + # Find \n or \r for full line + my $i = (rindex($buf,"\n")+1); + if($i) { + # Print full line + for(@{$buffer{$infh}{$outfd}}, substr($buf,0,$i)) { + syswrite($Global::fh{$outfd},$_); + } + # @buffer = remaining half line + $buffer{$infh}{$outfd} = [substr($buf,$i,$rv-$i)]; + } else { + # Something read, but not a full line + push @{$buffer{$infh}{$outfd}}, $buf; + } + redo; + } + } + } + } + } while($opened < $files_to_open); + + for (@producers) { + $_->join(); + } + + sub set_fh_non_blocking { + # Set filehandle as non-blocking + # Inputs: + # $fh = filehandle to be blocking + # Returns: + # N/A + my $fh = shift; + my $flags; + fcntl($fh, &F_GETFL, $flags) || die $!; # Get the current flags on the filehandle + $flags |= &O_NONBLOCK; # Add non-blocking to the flags + fcntl($fh, &F_SETFL, $flags) || die $!; # Set the flags on the filehandle + } + }'; + return ::spacefree(3, $script); +} + +sub sharder_script() { + my $script = q{ + use B; + # Column separator + my $sep = shift; + # Which columns to shard on (count from 1) + my $col = shift; + # Which columns to shard on (count from 0) + my $col0 = $col - 1; + my $bins = @ARGV; + # Open fifos for writing, fh{0..$bins} + my $t = 0; + my %fh; + for(@ARGV) { + open $fh{$t++}, ">", $_; + # open blocks until it is opened by reader + # so unlink only happens when it is ready + unlink $_; + } + while() { + # Split into $col columns (no need to split into more) + @F = split $sep, $_, $col+1; + $fh = $fh{ hex(B::hash($F[$col0]))%$bins }; + print $fh $_; + } + # Close all open fifos + close values %fh; + }; + return ::spacefree(1, $script); +} + +sub pipe_shard_setup() { + # Create temporary fifos + # Run 'shard.pl sep col fifo1 fifo2 fifo3 ... fifoN' in the background + # This will spread the input to fifos + # Generate commands that reads from fifo1..N: + # cat fifo | user_command + # Changes: + # @Global::cat_prepends + my @shardfifos; + my @parcatfifos; + # TODO $opt::jobs should be evaluated (100%) + # TODO $opt::jobs should be number of total_jobs if there are argugemts + my $njobs = $opt::jobs; + for my $m (0..$njobs-1) { + for my $n (0..$njobs-1) { + # sharding to A B C D + # parcatting all As together + $parcatfifos[$n][$m] = $shardfifos[$m][$n] = tmpfifo(); + } + } + my $script = sharder_script(); + # cat foo | sharder sep col fifo1 fifo2 fifo3 ... fifoN + + if(not fork()) { + # Let the sharder inherit our stdin + # and redirect stdout to null + open STDOUT, ">","/dev/null"; + # The PERL_HASH_SEED must be the same for all sharders + # so B::hash will return the same value for any given input + $ENV{'PERL_HASH_SEED'} = $$; + exec qw(parallel --block 100k -q --pipe -j), $njobs, + qw(--roundrobin -u perl -e), $script, ($opt::colsep || ","), + $opt::shard, '{}', (map { (':::+', @{$_}) } @parcatfifos); + } + # For each fifo + # (rm fifo1; grep 1) < fifo1 + # (rm fifo2; grep 2) < fifo2 + # (rm fifo3; grep 3) < fifo3 + my $parcat = Q(parcat_script()); + if(not $parcat) { + ::error("'parcat' must be in path."); + ::wait_and_exit(255); + } + @Global::cat_prepends = map { "perl -e $parcat @$_ | " } @parcatfifos; +} + +sub pipe_part_files(@) { # Given the bigfile # find header and split positions # make commands that 'cat's the partial file @@ -321,7 +472,7 @@ sub pipe_part_files { return @cat_prepends; } -sub find_header { +sub find_header($$) { # Compute the header based on $opt::header # Input: # $buf_ref = reference to read-in buffer @@ -337,7 +488,8 @@ sub find_header { if($opt::header eq ":") { $opt::header = "(.*\n)"; } # Number = number of lines $opt::header =~ s/^(\d+)$/"(.*\n)"x$1/e; - while(read($fh,substr($$buf_ref,length $$buf_ref,0),$Global::blocksize)) { + while(read($fh,substr($$buf_ref,length $$buf_ref,0), + $Global::blocksize)) { if($$buf_ref=~s/^($opt::header)//) { $header = $1; last; @@ -347,7 +499,7 @@ sub find_header { return $header; } -sub find_split_positions { +sub find_split_positions($$$) { # Find positions in bigfile where recend is followed by recstart # Input: # $file = the file to read @@ -384,7 +536,7 @@ sub find_split_positions { while(read($fh,substr($buf,length $buf,0),$dd_block_size)) { if($opt::regexp) { # If match /$recend$recstart/ => Record position - if($buf =~ /^(.*$recend)$recstart/os) { + if($buf =~ m:^(.*$recend)$recstart:os) { # Start looking for next record _after_ this match $pos += length($1); push(@pos,$pos); @@ -414,7 +566,7 @@ sub find_split_positions { return @pos; } -sub cat_partial { +sub cat_partial($@) { # Efficient command to copy from byte X to byte Y # Input: # $file = the file to read @@ -441,11 +593,11 @@ sub cat_partial { } } }); - return "<". shell_quote_scalar($file) . + return "<". Q($file) . " perl -e '$script' @start_len |"; } -sub spreadstdin { +sub spreadstdin() { # read a record # Spawn a job and print the record to it. # Uses: @@ -460,15 +612,6 @@ sub spreadstdin { # %Global::running # Returns: N/A - if($opt::tee) { - # Spawn all jobs - # read a record - # Write record to all jobs - if(not $Global::JobQueue->empty()) { - ::error("--tee requres --jobs to be higher. Try --jobs 0."); - } - } - my $buf = ""; my ($recstart,$recend) = recstartrecend(); my $recendrecstart = $recend.$recstart; @@ -519,12 +662,19 @@ sub spreadstdin { $Global::max_number_of_args * ($Global::max_lines || 1); # (?!negative lookahead) is needed to avoid backtracking # See: https://unix.stackexchange.com/questions/439356/ - while($buf =~ /# From start up till recend - ^((?:(?!$recend$recstart).)*?$recend - # Then n-1 times recstart.*recend - (?:$recstart(?:(?!$recend$recstart).)*?$recend){$read_n_lines}) - # Followed by recstart - (?=$recstart)/osx) { + while($buf =~ + /( + # Either recstart or at least one char from start + ^(?: $recstart | .) + # followed something + (?:(?!$recend$recstart).)*? + # and then recend + $recend + # Then n-1 times recstart.*recend + (?:$recstart(?:(?!$recend$recstart).)*?$recend){$read_n_lines} + ) + # Followed by recstart + (?=$recstart)/osx) { $anything_written += write_record_to_pipe($chunk_number++,\$header,\$buf, $recstart,$recend,length $1); @@ -561,7 +711,9 @@ sub spreadstdin { my $i = 0; my $read_n_lines = $Global::max_number_of_args * ($Global::max_lines || 1); - while(($i = nindex(\$buf,$recendrecstart,$read_n_lines)) != -1) { + while(($i = nindex(\$buf,$recendrecstart,$read_n_lines)) != -1 + and + length $buf) { $i += length $recend; # find the actual splitting location $anything_written += write_record_to_pipe($chunk_number++,\$header,\$buf, @@ -615,6 +767,7 @@ sub spreadstdin { my $sleep =1; while($Global::total_running > 0) { $sleep = ::reap_usleep($sleep); + start_more_jobs(); } } $Global::start_no_new_jobs ||= 1; @@ -638,7 +791,7 @@ sub spreadstdin { } } -sub recstartrecend { +sub recstartrecend() { # Uses: # $opt::recstart # $opt::recend @@ -657,10 +810,15 @@ sub recstartrecend { # If --recend is given then it must match end of record $recstart = ""; $recend = $opt::recend; + if($opt::regexp and $recend eq '') { + # --regexp --recend '' + $recend = '.'; + } } if($opt::regexp) { - # If $recstart/$recend contains '|' this should only apply to the regexp + # If $recstart/$recend contains '|' + # this should only apply to the regexp $recstart = "(?:".$recstart.")"; $recend = "(?:".$recend.")"; } else { @@ -671,7 +829,7 @@ sub recstartrecend { return ($recstart,$recend); } -sub nindex { +sub nindex($$) { # See if string is in buffer N times # Returns: # the position where the Nth copy is found @@ -688,7 +846,7 @@ sub nindex { my @robin_queue; my $sleep = 1; - sub round_robin_write { + sub round_robin_write($$$$$) { # Input: # $header_ref = ref to $header string # $block_ref = ref to $block to be written @@ -714,45 +872,32 @@ sub nindex { push @robin_queue, (sort { $a->seq() <=> $b->seq() } values %Global::running); } - if($opt::keeporder) { + do { + $written = 0; for my $job (@robin_queue) { if($job->block_length() > 0) { $written += $job->non_blocking_write(); } else { - $job->set_block($header_ref,$buffer_ref,$endpos,$recstart,$recend); + $job->set_block($header_ref, $buffer_ref, + $endpos, $recstart, $recend); $block_passed = 1; $job->set_virgin(0); $written += $job->non_blocking_write(); last; } } - } else { - do { - $written = 0; - for my $job (@robin_queue) { - if($job->block_length() > 0) { - $written += $job->non_blocking_write(); - } else { - $job->set_block($header_ref,$buffer_ref, - $endpos,$recstart,$recend); - $block_passed = 1; - $job->set_virgin(0); - $written += $job->non_blocking_write(); - last; - } - } - if($written) { - $sleep = $sleep/1.5+0.001; - } - } while($written and not $block_passed); - } + if($written) { + $sleep = $sleep/1.5+0.001; + } + # Don't sleep if something is written + } while($written and not $block_passed); $sleep = ::reap_usleep($sleep); } return $written; } } -sub index64 { +sub index64($$$) { # Do index on strings > 2GB. # index in Perl < v5.22 does not work for > 2GB # Input: @@ -784,7 +929,7 @@ sub index64 { return -1; } -sub rindex64 { +sub rindex64($@) { # Do rindex on strings > 2GB. # rindex in Perl < v5.22 does not work for > 2GB # Input: @@ -825,7 +970,7 @@ sub rindex64 { return -1; } -sub shorten { +sub shorten($$) { # Do: substr($buf,0,$i) = ""; # Some Perl versions do not support $i > 2GB, so do this in 2GB chunks # Input: @@ -841,7 +986,7 @@ sub shorten { substr($$buf_ref,0,$i) = ""; } -sub write_record_to_pipe { +sub write_record_to_pipe($$$$$$) { # Fork then # Write record from pos 0 .. $endpos to pipe # Input: @@ -857,12 +1002,14 @@ sub write_record_to_pipe { # @Global::virgin_jobs # Returns: # Number of chunks written (0 or 1) - my ($chunk_number,$header_ref,$buffer_ref,$recstart,$recend,$endpos) = @_; + my ($chunk_number, $header_ref, $buffer_ref, + $recstart, $recend, $endpos) = @_; if($endpos == 0) { return 0; } if(vec($Global::job_already_run,$chunk_number,1)) { return 1; } if($opt::roundrobin) { # Write the block to one of the already running jobs - return round_robin_write($header_ref,$buffer_ref,$recstart,$recend,$endpos); + return round_robin_write($header_ref, $buffer_ref, + $recstart, $recend, $endpos); } # If no virgin found, backoff my $sleep = 0.0001; # 0.01 ms - better performance on highend @@ -882,7 +1029,8 @@ sub write_record_to_pipe { # Copy $buffer[0..$endpos] to $job->{'block'} # Remove rec_sep # Run $job->add_transfersize - $job->set_block($header_ref,$buffer_ref,$endpos,$recstart,$recend); + $job->set_block($header_ref, $buffer_ref, $endpos, + $recstart, $recend); if(fork()) { # Skip } else { @@ -901,7 +1049,7 @@ sub write_record_to_pipe { substr($$buffer_ref,$endpos,length $$buffer_ref) = ""; # Remove rec_sep if($opt::remove_rec_sep) { - Job::remove_rec_sep($buffer_ref,$recstart,$recend); + Job::remove_rec_sep($buffer_ref, $recstart, $recend); } $job->write($header_ref); $job->write($buffer_ref); @@ -914,17 +1062,18 @@ sub write_record_to_pipe { } -sub __SEM_MODE__ {} +sub __SEM_MODE__() {} -sub acquire_semaphore { +sub acquire_semaphore() { # Acquires semaphore. If needed: spawns to the background # Uses: # @Global::host # Returns: # The semaphore to be released when jobs is complete $Global::host{':'} = SSHLogin->new(":"); - my $sem = Semaphore->new($Semaphore::name,$Global::host{':'}->max_jobs_running()); + my $sem = Semaphore->new($Semaphore::name, + $Global::host{':'}->max_jobs_running()); $sem->acquire(); if($Semaphore::fg) { # skip @@ -940,10 +1089,10 @@ sub acquire_semaphore { } -sub __PARSE_OPTIONS__ {} +sub __PARSE_OPTIONS__() {} -sub options_hash { +sub options_hash() { # Returns: # %hash = the GetOptions config return @@ -967,7 +1116,8 @@ sub options_hash { "group" => \$opt::group, "g" => \$opt::retired, "ungroup|u" => \$opt::ungroup, - "linebuffer|linebuffered|line-buffer|line-buffered|lb" => \$opt::linebuffer, + "linebuffer|linebuffered|line-buffer|line-buffered|lb" + => \$opt::linebuffer, "tmux" => \$opt::tmux, "tmuxpane" => \$opt::tmuxpane, "null|0" => \$opt::null, @@ -991,9 +1141,15 @@ sub options_hash { "noswap" => \$opt::noswap, "max-line-length-allowed" => \$opt::max_line_length_allowed, "number-of-cpus" => \$opt::number_of_cpus, + "number-of-sockets" => \$opt::number_of_sockets, "number-of-cores" => \$opt::number_of_cores, + "number-of-threads" => \$opt::number_of_threads, + "use-sockets-instead-of-threads" + => \$opt::use_sockets_instead_of_threads, + "use-cores-instead-of-threads" + => \$opt::use_cores_instead_of_threads, "use-cpus-instead-of-cores" => \$opt::use_cpus_instead_of_cores, - "shellquote|shell_quote|shell-quote" => \$opt::shellquote, + "shellquote|shell_quote|shell-quote" => \@opt::shellquote, "nice=i" => \$opt::nice, "tag" => \$opt::tag, "tagstring|tag-string=s" => \$opt::tagstring, @@ -1019,7 +1175,8 @@ sub options_hash { "rsync-opts|rsyncopts=s" => \$opt::rsync_opts, "tmpdir|tempdir=s" => \$opt::tmpdir, "use-compress-program|compress-program=s" => \$opt::compress_program, - "use-decompress-program|decompress-program=s" => \$opt::decompress_program, + "use-decompress-program|decompress-program=s" + => \$opt::decompress_program, "compress" => \$opt::compress, "tty" => \$opt::tty, "T" => \$opt::retired, @@ -1049,6 +1206,8 @@ sub options_hash { "gnu" => \$opt::gnu, "link|xapply" => \$opt::link, "linkinputsource|xapplyinputsource=i" => \@opt::linkinputsource, + # Before changing this line, please read + # https://www.gnu.org/software/parallel/parallel_design.html#Citation-notice "bibtex|citation" => \$opt::citation, "wc|willcite|will-cite|nn|nonotice|no-notice" => \$opt::willcite, # Termination and retries @@ -1089,7 +1248,8 @@ sub options_hash { "wait" => \$opt::wait, # Shebang #!/opt/local/bin/parallel --shebang "shebang|hashbang" => \$opt::shebang, - "internal-pipe-means-argfiles" => \$opt::internal_pipe_means_argfiles, + "internal-pipe-means-argfiles" + => \$opt::internal_pipe_means_argfiles, "Y" => \$opt::retired, "skip-first-line" => \$opt::skip_first_line, "bug" => \$opt::bug, @@ -1098,12 +1258,13 @@ sub options_hash { "fifo" => \$opt::fifo, "pipepart|pipe-part" => \$opt::pipepart, "tee" => \$opt::tee, + "shard=s" => \$opt::shard, "hgrp|hostgrp|hostgroup|hostgroups" => \$opt::hostgroups, "embed" => \$opt::embed, ); } -sub get_options_from_array { +sub get_options_from_array($@) { # Run GetOptions on @array # Input: # $array_ref = ref to @ARGV to parse @@ -1145,12 +1306,14 @@ sub get_options_from_array { return $retval; } -sub parse_options { +sub parse_options(@) { # Returns: N/A init_globals(); my @argv_before = @ARGV; @ARGV = read_options(); + # Before changing this line, please read + # https://www.gnu.org/software/parallel/parallel_design.html#Citation-notice if(defined $opt::citation) { citation(\@argv_before,\@ARGV); wait_and_exit(0); @@ -1215,12 +1378,18 @@ sub parse_options { if(defined $opt::arg_file_sep) { $Global::arg_file_sep = $opt::arg_file_sep; } + if(defined $opt::number_of_sockets) { + print SSHLogin::no_of_sockets(),"\n"; wait_and_exit(0); + } if(defined $opt::number_of_cpus) { - print SSHLogin::no_of_cpus(),"\n"; wait_and_exit(0); + print SSHLogin::no_of_cores(),"\n"; wait_and_exit(0); } if(defined $opt::number_of_cores) { print SSHLogin::no_of_cores(),"\n"; wait_and_exit(0); } + if(defined $opt::number_of_threads) { + print SSHLogin::no_of_threads(),"\n"; wait_and_exit(0); + } if(defined $opt::max_line_length_allowed) { print Limits::Command::real_max_length(),"\n"; wait_and_exit(0); } @@ -1300,10 +1469,10 @@ sub parse_options { # Append a dummy empty argument if there are no arguments # on the command line to avoid reading from STDIN. # arg_sep = random 50 char - # \0 => nothing (not the empty string) + # \0noarg => nothing (not the empty string) $Global::arg_sep = join "", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..50); - push @ARGV, $Global::arg_sep, "\0"; + push @ARGV, $Global::arg_sep, "\0noarg"; } if(defined $opt::tee) { if(not defined $opt::jobs) { @@ -1374,9 +1543,85 @@ sub parse_options { if(defined $opt::eta) { $opt::progress = $opt::eta; } if(defined $opt::bar) { $opt::progress = $opt::bar; } + + # Funding a free software project is hard. GNU Parallel is no + # exception. On top of that it seems the less visible a project + # is, the harder it is to get funding. And the nature of GNU + # Parallel is that it will never be seen by "the guy with the + # checkbook", but only by the people doing the actual work. + # + # This problem has been covered by others - though no solution has + # been found: + # https://www.slideshare.net/NadiaEghbal/consider-the-maintainer + # https://www.numfocus.org/blog/why-is-numpy-only-now-getting-funded/ + # + # Before implementing the citation notice it was discussed with + # the users: + # https://lists.gnu.org/archive/html/parallel/2013-11/msg00006.html + # + # Having to spend 10 seconds on running 'parallel --citation' once + # is no doubt not an ideal solution, but no one has so far come up + # with an ideal solution - neither for funding GNU Parallel nor + # other free software. + # + # If you believe you have the perfect solution, you should try it + # out, and if it works, you should post it on the email + # list. Ideas that will cost work and which have not been tested + # are, however, unlikely to be prioritized. + # + # Please note that GPL version 3 gives you the right to fork GNU + # Parallel under a new name, but it does not give you the right to + # distribute modified copies with the citation notice disabled + # under the name GNU Parallel. To do that you need to be the owner + # of the GNU Parallel trademark. The xt:Commerce case shows this. + # + # Description of the xt:Commerce case in OLG Duesseldorf + # http://www.inta.org/INTABulletin/Pages/GERMANYGeneralPublicLicenseDoesNotPermitUseofThird-PartyTrademarksforAdvertisingModifiedVersionsofOpen-SourceSoftware.aspx + # https://web.archive.org/web/20180715073746/http://www.inta.org/INTABulletin/Pages/GERMANYGeneralPublicLicenseDoesNotPermitUseofThird-PartyTrademarksforAdvertisingModifiedVersionsofOpen-SourceSoftware.aspx + # + # The verdict in German + # https://www.admody.com/urteilsdatenbank/cafe6fdaeed3/OLG-Duesseldorf_Urteil_vom_28-September-2010_Az_I-20-U-41-09 + # https://web.archive.org/web/20180715073717/https://www.admody.com/urteilsdatenbank/cafe6fdaeed3/OLG-Duesseldorf_Urteil_vom_28-September-2010_Az_I-20-U-41-09 + # + # Other free software limiting derivates by the same name + # https://en.wikipedia.org/wiki/Red_Hat_Enterprise_Linux_derivatives#Legal_aspects + # https://tm.joomla.org/trademark-faq.html + # https://www.mozilla.org/en-US/foundation/trademarks/faq/ + # + # Running 'parallel --citation' one single time takes less than 10 + # seconds, and will silence the citation notice for future + # runs. If that is too much trouble for you, why not use one of + # the alternatives instead? + # See a list in: 'man parallel_alternatives' + # + # Please read the above before changing this line. citation_notice(); parse_halt(); + + if($ENV{'PARALLEL_ENV'}) { + # Read environment and set $Global::parallel_env + # Must be done before is_acceptable_command_line_length() + my $penv = $ENV{'PARALLEL_ENV'}; + # unset $PARALLEL_ENV: It should not be given to children + # because it takes up a lot of env space + delete $ENV{'PARALLEL_ENV'}; + if(-e $penv) { + # This is a file/fifo: Replace envvar with content of file + open(my $parallel_env, "<", $penv) || + ::die_bug("Cannot read parallel_env from $penv"); + local $/; # Put <> in slurp mode + $penv = <$parallel_env>; + close $parallel_env; + } + # Map \001 to \n to make it easer to quote \n in $PARALLEL_ENV + $penv =~ s/\001/\n/g; + if($penv =~ /\0/) { + ::warning('\0 (NUL) in environment is not supported'); + } + $Global::parallel_env = $penv; + } + parse_sshlogin(); if(remote_hosts() and ($opt::X or $opt::m or $opt::xargs)) { @@ -1395,7 +1640,7 @@ sub parse_options { if($opt::sqlworker) { $Global::membuffer ||= 1; } } -sub check_invalid_option_combinations { +sub check_invalid_option_combinations() { if(defined $opt::timeout and $opt::timeout !~ /^\d+(\.\d+)?%?$|^(\d+(\.\d+)?[dhms])+$/i) { ::error("--timeout must be seconds or percentage."); @@ -1448,9 +1693,9 @@ sub check_invalid_option_combinations { } } -sub init_globals { +sub init_globals() { # Defaults: - $Global::version = 20180622; + $Global::version = 20190322; $Global::progname = 'parallel'; $Global::infinity = 2**31; $Global::debug = 0; @@ -1521,9 +1766,8 @@ sub init_globals { $Global::trim = 'n'; $Global::max_jobs_running = 0; $Global::job_already_run = ''; - # LC_ALL workaround for multibyte chars containing special shell chars - $ENV{'LC_ALL'} = 'C'; $ENV{'TMPDIR'} ||= "/tmp"; + $ENV{'OLDPWD'} = $ENV{'PWD'}; if(not $ENV{HOME}) { # $ENV{HOME} is sometimes not set if called from PHP ::warning("\$HOME not set. Using /tmp."); @@ -1555,7 +1799,7 @@ sub init_globals { $ENV{'HOME'} . "/.parallel"; } -sub parse_halt { +sub parse_halt() { # $opt::halt flavours # Uses: # $opt::halt @@ -1607,7 +1851,7 @@ sub parse_halt { } } -sub parse_replacement_string_options { +sub parse_replacement_string_options() { # Deal with --rpl # Uses: # %Global::rpl @@ -1627,7 +1871,7 @@ sub parse_replacement_string_options { # $opt::slotreplace # $opt::basenameextensionreplace - sub rpl { + sub rpl($$) { # Modify %Global::rpl # Replace $old with $new my ($old,$new) = @_; @@ -1660,7 +1904,7 @@ sub parse_replacement_string_options { } } -sub parse_semaphore { +sub parse_semaphore() { # Semaphore defaults # Must be done before computing number of processes and max_line_length # because when running as a semaphore GNU Parallel does not read args @@ -1701,7 +1945,7 @@ sub parse_semaphore { @opt::a = ("/dev/null"); # Append a dummy empty argument # \0 => nothing (not the empty string) - push(@Global::unget_argv, [Arg->new("\0")]); + push(@Global::unget_argv, [Arg->new("\0noarg")]); $Semaphore::timeout = $opt::semaphoretimeout || 0; if(defined $opt::semaphorename) { $Semaphore::name = $opt::semaphorename; @@ -1724,7 +1968,7 @@ sub parse_semaphore { } } -sub record_env { +sub record_env() { # Record current %ENV-keys in $PARALLEL_HOME/ignored_vars # Returns: N/A my $ignore_filename = $Global::config_dir . "/ignored_vars"; @@ -1736,7 +1980,7 @@ sub record_env { } } -sub open_joblog { +sub open_joblog() { # Open joblog as specified by --joblog # Uses: # $opt::resume @@ -1765,6 +2009,8 @@ sub open_joblog { if($opt::resume || $opt::resume_failed || $opt::retry_failed) { if(open(my $joblog_fh, "<", $opt::joblog)) { # Read the joblog + # Override $/ with \n because -d might be set + local $/ = "\n"; # If there is a header: Open as append later $append = <$joblog_fh>; my $joblog_regexp; @@ -1773,22 +2019,19 @@ sub open_joblog { # 4 host 1360490623.067 3.445 1023 1222 0 0 command $joblog_regexp='^(\d+)(?:\t[^\t]+){5}\t0\t0\t'; my @group; - { - local $/ = "\n"; - while(<$joblog_fh>) { - if(/$joblog_regexp/o) { - # This is 30% faster than set_job_already_run($1); - vec($Global::job_already_run,($1||0),1) = 1; - $Global::total_completed++; - $group[$1-1] = "true"; - } elsif(/(\d+)\s+\S+(\s+[-0-9.]+){6}\s+(.*)$/) { - # Grab out the command - $group[$1-1] = $3; - } else { - chomp; - ::error("Format of '$opt::joblog' is wrong: $_"); - ::wait_and_exit(255); - } + while(<$joblog_fh>) { + if(/$joblog_regexp/o) { + # This is 30% faster than set_job_already_run($1); + vec($Global::job_already_run,($1||0),1) = 1; + $Global::total_completed++; + $group[$1-1] = "true"; + } elsif(/(\d+)\s+\S+(\s+[-0-9.]+){6}\s+(.*)$/) { + # Grab out the command + $group[$1-1] = $3; + } else { + chomp; + ::error("Format of '$opt::joblog' is wrong: $_"); + ::wait_and_exit(255); } } if(@group) { @@ -1802,7 +2045,7 @@ sub open_joblog { $/ = "\0"; } # Replace \0 with '\n' as used in print_joblog() - print $outfh map { s/\0/\n/g; $_,$/ } @group; + print $outfh map { s/\0/\n/g; $_,$/ } map { $_ } @group; seek $outfh, 0, 0; exit_if_disk_full(); # Set filehandle to -a @@ -1833,6 +2076,8 @@ sub open_joblog { } close $joblog_fh; } + # $opt::null may be set if the commands contain \n + if($opt::null) { $/ = "\0"; } } if($opt::dryrun) { # Do not write to joblog in a dry-run @@ -1863,7 +2108,7 @@ sub open_joblog { } } -sub open_csv { +sub open_csv() { if($opt::results) { # Output as CSV/TSV if($opt::results eq "-.csv" @@ -1888,7 +2133,7 @@ sub open_csv { } } -sub find_compression_program { +sub find_compression_program() { # Find a fast compression program # Returns: # $compress_program = compress program with options @@ -1932,7 +2177,7 @@ sub find_compression_program { return ("cat","cat"); } -sub read_options { +sub read_options() { # Read options from command line, profile and $PARALLEL # Uses: # $opt::shebang_wrap @@ -1957,7 +2202,7 @@ sub read_options { # remove --hashbang if it is set $opt::shebang .= ($ARGV[0] =~ s/^--hashbang *//); if($opt::shebang) { - my $argfile = shell_quote_scalar(pop @ARGV); + my $argfile = Q(pop @ARGV); # exec myself to split $ARGV[0] into separate fields exec "$0 --skip-first-line -a $argfile @ARGV"; } @@ -1980,7 +2225,7 @@ sub read_options { } else { @options = shift @ARGV; } - my $script = shell_quote_scalar(shift @ARGV); + my $script = Q(shift @ARGV); # exec myself to split $ARGV[0] into separate fields exec "$0 --internal-pipe-means-argfiles @options @parser $script ". "::: @ARGV"; @@ -2035,7 +2280,11 @@ sub read_options { } # Add options from shell variable $PARALLEL if($ENV{'PARALLEL'}) { - @ARGV_env = shell_words($ENV{'PARALLEL'}); + push @ARGV_env, shell_words($ENV{'PARALLEL'}); + } + # Add options from env_parallel.csh via $PARALLEL_CSH + if($ENV{'PARALLEL_CSH'}) { + push @ARGV_env, shell_words($ENV{'PARALLEL_CSH'}); } } Getopt::Long::Configure("bundling","require_order"); @@ -2051,11 +2300,13 @@ sub read_options { return @ARGV; } -sub arrayindex { +sub arrayindex() { # Similar to Perl's index function, but for arrays # Input: # $arr_ref1 = ref to @array1 to search in # $arr_ref2 = ref to @array2 to search for + # Returns: + # $pos = position of @array1 in @array2, -1 if not found my ($arr_ref1,$arr_ref2) = @_; my $array1_as_string = join "", map { "\0".$_ } @$arr_ref1; my $array2_as_string = join "", map { "\0".$_ } @$arr_ref2; @@ -2065,7 +2316,7 @@ sub arrayindex { return $#before; } -sub read_args_from_command_line { +sub read_args_from_command_line() { # Arguments given on the command line after: # ::: ($Global::arg_sep) # :::: ($Global::arg_file_sep) @@ -2157,7 +2408,7 @@ sub read_args_from_command_line { return @new_argv; } -sub cleanup { +sub cleanup() { # Returns: N/A unlink keys %Global::unlink; map { rmdir $_ } keys %Global::unlink; @@ -2169,20 +2420,17 @@ sub cleanup { } -sub __QUOTING_ARGUMENTS_FOR_SHELL__ {} +sub __QUOTING_ARGUMENTS_FOR_SHELL__() {} - -sub shell_quote { +sub shell_quote(@) { # Input: # @strings = strings to be quoted - # Output: - # @shell_quoted_strings = string quoted with \ as needed by the shell - return wantarray ? - (map { shell_quote_scalar($_) } @_) - : (join" ",map { shell_quote_scalar($_) } @_); + # Returns: + # @shell_quoted_strings = string quoted as needed by the shell + return wantarray ? (map { Q($_) } @_) : (join" ",map { Q($_) } @_); } -sub shell_quote_scalar_rc { +sub shell_quote_scalar_rc($) { # Quote for the rc-shell my $a = $_[0]; if(defined $a) { @@ -2200,7 +2448,7 @@ sub shell_quote_scalar_rc { return $a; } -sub shell_quote_scalar_csh { +sub shell_quote_scalar_csh($) { # Quote for (t)csh my $a = $_[0]; if(defined $a) { @@ -2221,30 +2469,27 @@ sub shell_quote_scalar_csh { return $a; } -sub shell_quote_scalar_default { - # Quote for other shells - my $a = $_[0]; - if(defined $a) { - # zsh wants '=' quoted - # Solaris sh wants ^ quoted. - # $a =~ s/([\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\>\<\~\|\; \"\!\$\&\'\202-\377])/\\$1/g; - # This is 1% faster than the above - if(($a =~ s/[\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\<\=\>\~\|\; \"\!\$\&\'\202-\377]/\\$&/go) - + - # quote newline as '\n' - ($a =~ s/[\n]/'\n'/go)) { - # A string was replaced - # No need to test for "" or \0 - } elsif($a eq "") { - $a = "''"; - } elsif($a eq "\0") { - $a = ""; - } +sub shell_quote_scalar_default($) { + # Quote for other shells (Bourne compatibles) + # Inputs: + # $string = string to be quoted + # Returns: + # $shell_quoted = string quoted as needed by the shell + my $par = $_[0]; + if($par =~ /[^-_.+a-z0-9\/]/i) { + $par =~ s/'/'"'"'/g; # "-quote single quotes + $par = "'$par'"; # '-quote entire string + $par =~ s/^''|''$//g; # Remove unneeded '' at ends + return $par; + } elsif ($par eq "") { + return "''"; + } else { + # No quoting needed + return $par; } - return $a; } -sub shell_quote_scalar { +sub shell_quote_scalar($) { # Quote the string so the shell will not expand any special chars # Inputs: # $string = string to be quoted @@ -2268,14 +2513,21 @@ sub shell_quote_scalar { return shell_quote_scalar(@_); } -sub shell_quote_file { +sub Q($) { + # Q alias for ::shell_quote_scalar + no warnings 'redefine'; + *Q = \&::shell_quote_scalar; + return Q(@_); +} + +sub shell_quote_file($) { # Quote the string so shell will not expand any special chars # and prepend ./ if needed # Input: # $filename = filename to be shell quoted # Returns: # $quoted_filename = filename quoted with \ and ./ if needed - my $a = shell_quote_scalar(shift); + my $a = shift; if(defined $a) { if($a =~ m:^/: or $a =~ m:^\./:) { # /abs/path or ./rel/path => skip @@ -2284,10 +2536,10 @@ sub shell_quote_file { $a = "./".$a; } } - return $a; + return Q($a); } -sub shell_words { +sub shell_words(@) { # Input: # $string = shell line # Returns: @@ -2296,7 +2548,7 @@ sub shell_words { return Text::ParseWords::shellwords(@_); } -sub perl_quote_scalar { +sub perl_quote_scalar($) { # Quote the string so perl's eval will not expand any special chars # Inputs: # $string = string to be quoted @@ -2309,8 +2561,19 @@ sub perl_quote_scalar { return $a; } -sub unquote_printf { +# -w complains about prototype +sub pQ($) { + # pQ alias for ::perl_quote_scalar + *pQ = \&::perl_quote_scalar; + return pQ(@_); +} + +sub unquote_printf() { # Convert \t \n \r \000 \0 + # Inputs: + # $string = string with \t \n \r \num \0 + # Returns: + # $replaced = string with TAB NEWLINE CR NUL $_ = shift; s/\\t/\t/g; s/\\n/\n/g; @@ -2321,10 +2584,10 @@ sub unquote_printf { } -sub __FILEHANDLES__ {} +sub __FILEHANDLES__() {} -sub save_stdin_stdout_stderr { +sub save_stdin_stdout_stderr() { # Remember the original STDIN, STDOUT and STDERR # and file descriptors opened by the shell (e.g. 3>/tmp/foo) # Uses: @@ -2354,7 +2617,7 @@ sub save_stdin_stdout_stderr { ::die_bug("Can't dup STDIN: $!"); } -sub enough_file_handles { +sub enough_file_handles() { # Check that we have enough filehandles available for starting # another job # Uses: @@ -2382,7 +2645,7 @@ sub enough_file_handles { } } -sub open_or_exit { +sub open_or_exit($) { # Open a file name or exit if the file cannot be opened # Inputs: # $file = filehandle or filename to open @@ -2406,7 +2669,7 @@ sub open_or_exit { return $fh; } -sub set_fh_blocking { +sub set_fh_blocking($) { # Set filehandle as blocking # Inputs: # $fh = filehandle to be blocking @@ -2423,7 +2686,7 @@ sub set_fh_blocking { fcntl($fh, &F_SETFL, $flags) || die $!; } -sub set_fh_non_blocking { +sub set_fh_non_blocking($) { # Set filehandle as non-blocking # Inputs: # $fh = filehandle to be blocking @@ -2441,7 +2704,7 @@ sub set_fh_non_blocking { } -sub __RUNNING_THE_JOBS_AND_PRINTING_PROGRESS__ {} +sub __RUNNING_THE_JOBS_AND_PRINTING_PROGRESS__() {} # Variable structure: @@ -2466,7 +2729,7 @@ sub __RUNNING_THE_JOBS_AND_PRINTING_PROGRESS__ {} # $Global::exitstatus = status code of GNU Parallel # $Global::quoting = quote the command to run -sub init_run_jobs { +sub init_run_jobs() { # Set Global variables and progress signal handlers # Do the copying of basefiles # Returns: N/A @@ -2560,7 +2823,6 @@ sub init_run_jobs { # Returns: # $jobs_started = number of jobs started my $jobs_started = 0; - my $jobs_started_this_round = 0; if($Global::start_no_new_jobs) { return $jobs_started; } @@ -2570,65 +2832,61 @@ sub init_run_jobs { changed_procs_file(); changed_sshloginfile(); } - do { - $jobs_started_this_round = 0; - # This will start 1 job on each --sshlogin (if possible) - # thus distribute the jobs on the --sshlogins round robin - for my $sshlogin (values %Global::host) { - if($Global::JobQueue->empty() and not $opt::pipe) { - # No more jobs in the queue - last; - } - debug("run", "Running jobs before on ", $sshlogin->string(), ": ", - $sshlogin->jobs_running(), "\n"); - if ($sshlogin->jobs_running() < $sshlogin->max_jobs_running()) { - if($opt::delay - and - $opt::delay > ::now() - $Global::newest_starttime) { - # It has been too short since last start - next; - } - if($opt::load and $sshlogin->loadavg_too_high()) { - # The load is too high or unknown - next; - } - if($opt::noswap and $sshlogin->swapping()) { - # The server is swapping - next; - } - if($opt::limit and $sshlogin->limit()) { - # Over limit - next; - } - if($opt::memfree and $sshlogin->memfree() < $opt::memfree) { - # The server has not enough mem free - ::debug("mem", "Not starting job: not enough mem\n"); - next; - } - if($sshlogin->too_fast_remote_login()) { - # It has been too short since - next; - } - debug("run", $sshlogin->string(), - " has ", $sshlogin->jobs_running(), - " out of ", $sshlogin->max_jobs_running(), - " jobs running. Start another.\n"); - if(start_another_job($sshlogin) == 0) { - # No more jobs to start on this $sshlogin - debug("run","No jobs started on ", - $sshlogin->string(), "\n"); - next; - } - $sshlogin->inc_jobs_running(); - $sshlogin->set_last_login_at(::now()); - $jobs_started++; - $jobs_started_this_round++; - } - debug("run","Running jobs after on ", $sshlogin->string(), ": ", - $sshlogin->jobs_running(), " of ", - $sshlogin->max_jobs_running(), "\n"); + # This will start 1 job on each --sshlogin (if possible) + # thus distribute the jobs on the --sshlogins round robin + for my $sshlogin (values %Global::host) { + if($Global::JobQueue->empty() and not $opt::pipe) { + # No more jobs in the queue + last; } - } while($jobs_started_this_round); + debug("run", "Running jobs before on ", $sshlogin->string(), ": ", + $sshlogin->jobs_running(), "\n"); + if ($sshlogin->jobs_running() < $sshlogin->max_jobs_running()) { + if($opt::delay + and + $opt::delay > ::now() - $Global::newest_starttime) { + # It has been too short since last start + next; + } + if($opt::load and $sshlogin->loadavg_too_high()) { + # The load is too high or unknown + next; + } + if($opt::noswap and $sshlogin->swapping()) { + # The server is swapping + next; + } + if($opt::limit and $sshlogin->limit()) { + # Over limit + next; + } + if($opt::memfree and $sshlogin->memfree() < $opt::memfree) { + # The server has not enough mem free + ::debug("mem", "Not starting job: not enough mem\n"); + next; + } + if($sshlogin->too_fast_remote_login()) { + # It has been too short since + next; + } + debug("run", $sshlogin->string(), + " has ", $sshlogin->jobs_running(), + " out of ", $sshlogin->max_jobs_running(), + " jobs running. Start another.\n"); + if(start_another_job($sshlogin) == 0) { + # No more jobs to start on this $sshlogin + debug("run","No jobs started on ", + $sshlogin->string(), "\n"); + next; + } + $sshlogin->inc_jobs_running(); + $sshlogin->set_last_login_at(::now()); + $jobs_started++; + } + debug("run","Running jobs after on ", $sshlogin->string(), ": ", + $sshlogin->jobs_running(), " of ", + $sshlogin->max_jobs_running(), "\n"); + } return $jobs_started; } @@ -2637,7 +2895,7 @@ sub init_run_jobs { { my $no_more_file_handles_warned; - sub start_another_job { + sub start_another_job() { # If there are enough filehandles # and JobQueue not empty # and not $job is in joblog @@ -2736,7 +2994,7 @@ sub init_run_jobs { } } -sub init_progress { +sub init_progress() { # Uses: # $opt::bar # Returns: @@ -2750,7 +3008,7 @@ sub init_progress { $progress{'workerlist'}); } -sub drain_job_queue { +sub drain_job_queue(@) { # Uses: # $opt::progress # $Global::total_running @@ -2760,6 +3018,7 @@ sub drain_job_queue { # %Global::host # $Global::start_no_new_jobs # Returns: N/A + my @command = @_; if($opt::progress) { ::status_no_nl(init_progress()); } @@ -2804,8 +3063,8 @@ sub drain_job_queue { } # * because of loadavg # * because of too little time between each ssh login. - start_more_jobs(); $sleep = ::reap_usleep($sleep); + start_more_jobs(); if($Global::max_jobs_running == 0) { ::warning("There are no job slots available. Increase --jobs."); } @@ -2813,6 +3072,7 @@ sub drain_job_queue { while($opt::sqlmaster and not $Global::sql->finished()) { # SQL master $sleep = ::reap_usleep($sleep); + start_more_jobs(); if($Global::start_sqlworker) { # Start an SQL worker as we are now sure there is work to do $Global::start_sqlworker = 0; @@ -2822,7 +3082,7 @@ sub drain_job_queue { # Replace --sql/--sqlandworker with --sqlworker my @ARGV = map { s/^--sql(andworker)?$/--sqlworker/; $_ } @Global::options_in_argv; # exec the --sqlworker - exec($0,::shell_quote(@ARGV),@command); + exec($0,@ARGV,@command); } } } @@ -2837,7 +3097,7 @@ sub drain_job_queue { } } -sub toggle_progress { +sub toggle_progress() { # Turn on/off progress view # Uses: # $opt::progress @@ -2848,7 +3108,7 @@ sub toggle_progress { } } -sub progress { +sub progress() { # Uses: # $opt::bar # $opt::eta @@ -3008,7 +3268,7 @@ sub progress { { - my ($total, $first_completed, $smoothed_avg_time, $last_eta); + my ($first_completed, $smoothed_avg_time, $last_eta); sub compute_eta { # Calculate important numbers for ETA @@ -3019,13 +3279,14 @@ sub progress { # $pctcomplete = percent of jobs completed # $avgtime = averaged time # $eta = smoothed eta - $total = $Global::JobQueue->total_jobs(); my $completed = $Global::total_completed; + # In rare cases with -X will $completed > total_jobs() + my $total = ::max($Global::JobQueue->total_jobs(),$completed); my $left = $total - $completed; if(not $completed) { return($total, $completed, $left, 0, 0, 0); } - my $pctcomplete = $completed / $total; + my $pctcomplete = ::min($completed / $total,100); $first_completed ||= time; my $timepassed = (time - $first_completed); my $avgtime = $timepassed / $completed; @@ -3047,7 +3308,7 @@ sub progress { { my ($rev,$reset); - sub bar { + sub bar() { # Return: # $status = bar with eta, completed jobs, arg and pct $rev ||= "\033[7m"; @@ -3081,7 +3342,7 @@ sub progress { { my ($columns,$last_column_time); - sub terminal_columns { + sub terminal_columns() { # Get the number of columns of the terminal. # Only update once per second. # Returns: @@ -3111,7 +3372,9 @@ sub progress { } } -sub get_job_with_sshlogin { +# Prototype forwarding +sub get_job_with_sshlogin($); +sub get_job_with_sshlogin($) { # Input: # $sshlogin = which host should the job be run on? # Uses: @@ -3148,19 +3411,8 @@ sub get_job_with_sshlogin { return undef; } } - - my $clean_command = $job->replaced(); - if($clean_command =~ /^\s*$/) { - # Do not run empty lines - if(not $Global::JobQueue->empty()) { - return get_job_with_sshlogin($sshlogin); - } else { - return undef; - } - } $job->set_sshlogin($sshlogin); - if($opt::retries and $clean_command and - $job->failed_here()) { + if($opt::retries and $job->failed_here()) { # This command with these args failed for this sshlogin my ($no_of_failed_sshlogins,$min_failures) = $job->min_failed(); # Only look at the Global::host that have > 0 jobslots @@ -3187,10 +3439,10 @@ sub get_job_with_sshlogin { } -sub __REMOTE_SSH__ {} +sub __REMOTE_SSH__() {} -sub read_sshloginfiles { +sub read_sshloginfiles(@) { # Read a list of --slf's # Input: # @files = files or symbolic file names to read @@ -3200,7 +3452,7 @@ sub read_sshloginfiles { } } -sub expand_slf_shorthand { +sub expand_slf_shorthand($) { # Expand --slf shorthand into a read file name # Input: # $file = file or symbolic file name to read @@ -3228,7 +3480,7 @@ sub expand_slf_shorthand { return $file; } -sub read_sshloginfile { +sub read_sshloginfile($) { # Read sshloginfile into @Global::sshlogin # Input: # $file = file to read @@ -3261,7 +3513,7 @@ sub read_sshloginfile { } } -sub parse_sshlogin { +sub parse_sshlogin() { # Parse @Global::sshlogin into %Global::host. # Keep only hosts that are in one of the given ssh hostgroups. # Uses: @@ -3346,7 +3598,7 @@ sub parse_sshlogin { } } -sub remote_hosts { +sub remote_hosts() { # Return sshlogins that are not ':' # Uses: # %Global::host @@ -3355,7 +3607,7 @@ sub remote_hosts { return grep !/^:$/, keys %Global::host; } -sub setup_basefile { +sub setup_basefile() { # Transfer basefiles to each $sshlogin # This needs to be done before first jobs on $sshlogin is run # Uses: @@ -3391,7 +3643,7 @@ sub setup_basefile { } } -sub cleanup_basefile { +sub cleanup_basefile() { # Remove the basefiles transferred # Uses: # %Global::host @@ -3421,14 +3673,14 @@ sub cleanup_basefile { } } -sub run_parallel { +sub run_parallel() { my ($stdin,@args) = @_; my $cmd = join "",map { " $_ & " } split /\n/, $stdin; print $Global::original_stderr ` $cmd wait` ; return 0 } -sub _run_parallel { +sub _run_parallel() { # Run GNU Parallel # This should ideally just fork an internal copy # and not start it through a shell @@ -3472,18 +3724,20 @@ sub _run_parallel { return ($exitstatus,\@stdout,\@stderr); } -sub filter_hosts { +sub filter_hosts() { # Remove down --sshlogins from active duty. # Find ncpus, ncores, maxlen, time-to-login for each host. # Uses: # %Global::host # $Global::minimal_command_line_length + # $opt::use_sockets_instead_of_threads + # $opt::use_cores_instead_of_threads # $opt::use_cpus_instead_of_cores # Returns: N/A - my ($ncores_ref, $ncpus_ref, $time_to_login_ref, $maxlen_ref, - $echo_ref, $down_hosts_ref) = - parse_host_filtering(parallelized_host_filtering()); + my ($nsockets_ref,$ncores_ref, $nthreads_ref, $time_to_login_ref, + $maxlen_ref, $echo_ref, $down_hosts_ref) = + parse_host_filtering(parallelized_host_filtering()); delete @Global::host{@$down_hosts_ref}; @$down_hosts_ref and ::warning("Removed @$down_hosts_ref."); @@ -3491,17 +3745,22 @@ sub filter_hosts { $Global::minimal_command_line_length = 8_000_000; while (my ($sshlogin, $obj) = each %Global::host) { if($sshlogin eq ":") { next } - $ncpus_ref->{$sshlogin} or - ::die_bug("ncpus missing: ".$obj->serverlogin()); + $nsockets_ref->{$sshlogin} or + ::die_bug("nsockets missing: ".$obj->serverlogin()); $ncores_ref->{$sshlogin} or ::die_bug("ncores missing: ".$obj->serverlogin()); + $nthreads_ref->{$sshlogin} or + ::die_bug("nthreads missing: ".$obj->serverlogin()); $time_to_login_ref->{$sshlogin} or ::die_bug("time_to_login missing: ".$obj->serverlogin()); $maxlen_ref->{$sshlogin} or ::die_bug("maxlen missing: ".$obj->serverlogin()); + $obj->set_ncpus($nthreads_ref->{$sshlogin}); if($opt::use_cpus_instead_of_cores) { - $obj->set_ncpus($ncpus_ref->{$sshlogin}); - } else { + $obj->set_ncpus($ncores_ref->{$sshlogin}); + } elsif($opt::use_sockets_instead_of_threads) { + $obj->set_ncpus($nsockets_ref->{$sshlogin}); + } elsif($opt::use_cores_instead_of_threads) { $obj->set_ncpus($ncores_ref->{$sshlogin}); } $obj->set_time_to_login($time_to_login_ref->{$sshlogin}); @@ -3510,28 +3769,31 @@ sub filter_hosts { ::min($Global::minimal_command_line_length, int($maxlen_ref->{$sshlogin}/2)); ::debug("init", "Timing from -S:$sshlogin ", - " ncpus:",$ncpus_ref->{$sshlogin}, + " nsockets:",$nsockets_ref->{$sshlogin}, " ncores:", $ncores_ref->{$sshlogin}, + " nthreads:",$nthreads_ref->{$sshlogin}, " time_to_login:", $time_to_login_ref->{$sshlogin}, " maxlen:", $maxlen_ref->{$sshlogin}, " min_max_len:", $Global::minimal_command_line_length,"\n"); } } -sub parse_host_filtering { +sub parse_host_filtering() { # Input: # @lines = output from parallelized_host_filtering() # Returns: + # \%nsockets = number of sockets of {host} # \%ncores = number of cores of {host} - # \%ncpus = number of cpus of {host} + # \%nthreads = number of hyperthreaded cores of {host} # \%time_to_login = time_to_login on {host} # \%maxlen = max command len on {host} # \%echo = echo received from {host} # \@down_hosts = list of hosts with no answer local $/ = "\n"; - my (%ncores, %ncpus, %time_to_login, %maxlen, %echo, @down_hosts); + my (%nsockets, %ncores, %nthreads, %time_to_login, %maxlen, %echo, + @down_hosts); for (@_) { - ::debug("init",$_); + ::debug("init","Read: ",$_); chomp; my @col = split /\t/, $_; if($col[0] =~ /^parallel: Warning:/) { @@ -3547,7 +3809,7 @@ sub parse_host_filtering { next; } # Get server from: eval true server\; - $col[8] =~ /eval true..([^;]+).;/ or + $col[8] =~ /eval .?true.?\s([^\;]+);/ or ::die_bug("col8 does not contain host: $col[8]"); my $host = $1; $host =~ tr/\\//d; @@ -3560,11 +3822,12 @@ sub parse_host_filtering { push(@down_hosts, $host); } elsif($col[6] eq "127") { # signal == 127: parallel not installed remote - # Set ncpus and ncores = 1 + # Set nsockets, ncores, nthreads = 1 ::warning("Could not figure out ". "number of cpus on $host. Using 1."); + $nsockets{$host} = 1; $ncores{$host} = 1; - $ncpus{$host} = 1; + $nthreads{$host} = 1; $maxlen{$host} = Limits::Command::max_length(); } elsif($col[0] =~ /^\d+$/ and $Global::host{$host}) { # Remember how log it took to log in @@ -3582,10 +3845,12 @@ sub parse_host_filtering { if(/parallel: Warning: Cannot figure out number of/) { next; } - if(not $ncores{$col[0]}) { + if(not $nsockets{$col[0]}) { + $nsockets{$col[0]} = $col[1]; + } elsif(not $ncores{$col[0]}) { $ncores{$col[0]} = $col[1]; - } elsif(not $ncpus{$col[0]}) { - $ncpus{$col[0]} = $col[1]; + } elsif(not $nthreads{$col[0]}) { + $nthreads{$col[0]} = $col[1]; } elsif(not $maxlen{$col[0]}) { $maxlen{$col[0]} = $col[1]; } elsif(not $echo{$col[0]}) { @@ -3607,10 +3872,11 @@ sub parse_host_filtering { } } @down_hosts = uniq(@down_hosts); - return(\%ncores, \%ncpus, \%time_to_login, \%maxlen, \%echo, \@down_hosts); + return(\%nsockets, \%ncores, \%nthreads, \%time_to_login, + \%maxlen, \%echo, \@down_hosts); } -sub parallelized_host_filtering { +sub parallelized_host_filtering() { # Uses: # %Global::host # Returns: @@ -3632,14 +3898,16 @@ sub parallelized_host_filtering { return($job->{'wrapped'}); } - my(@cores, @cpus, @maxline, @echo); + my(@sockets, @cores, @threads, @maxline, @echo); while (my ($host, $sshlogin) = each %Global::host) { if($host eq ":") { next } # The 'true' is used to get the $host out later + push(@sockets, $host."\t"."true $host; ". + sshwrapped($sshlogin,"parallel --number-of-sockets")."\n\0"); push(@cores, $host."\t"."true $host; ". sshwrapped($sshlogin,"parallel --number-of-cores")."\n\0"); - push(@cpus, $host."\t"."true $host; ". - sshwrapped($sshlogin,"parallel --number-of-cpus")."\n\0"); + push(@threads, $host."\t"."true $host; ". + sshwrapped($sshlogin,"parallel --number-of-threads")."\n\0"); push(@maxline, $host."\t"."true $host; ". sshwrapped($sshlogin,"parallel --max-line-length-allowed")."\n\0"); # 'echo' is used to get the fastest possible ssh login time @@ -3656,7 +3924,7 @@ sub parallelized_host_filtering { my $cmd = "$0 -j0 --timeout 10 --joblog - --plain --delay 0.1 --retries 3 ". "--tag --tagstring '{1}' -0 --colsep '\t' -k eval '{2}' && true "; - $cmd = $Global::shell." -c ".::shell_quote_scalar($cmd); + $cmd = $Global::shell." -c ".Q($cmd); ::debug("init", $cmd, "\n"); my @out; my $prepend = ""; @@ -3666,18 +3934,19 @@ sub parallelized_host_filtering { if(not fork()) { # Give the commands to run to the $cmd close $host_fh; - print $in @cores, @cpus, @maxline, @echo; + print $in @sockets, @cores, @threads, @maxline, @echo; close $in; exit(); } close $in; for(<$host_fh>) { - if(/\'$/) { - # if last char = ' then append next line - # This may be due to quoting of \n in environment var - $prepend .= $_; - next; - } + # TODO incompatible with '-quoting. Needs to be fixed differently + #if(/\'$/) { + # # if last char = ' then append next line + # # This may be due to quoting of \n in environment var + # $prepend .= $_; + # next; + #} $_ = $prepend . $_; $prepend = ""; push @out, $_; @@ -3686,7 +3955,7 @@ sub parallelized_host_filtering { return @out; } -sub onall { +sub onall($@) { # Runs @command on all hosts. # Uses parallel to run @command on each host. # --jobs = number of hosts to run on simultaneously. @@ -3757,6 +4026,7 @@ sub onall { # -P should only go to the first, and -S should not be copied at all. my $options = join(" ", + ((defined $opt::memfree) ? "--memfree ".$opt::memfree : ""), ((defined $opt::D) ? "-D $opt::D" : ""), ((defined $opt::group) ? "-g" : ""), ((defined $opt::jobs) ? "-P $opt::jobs" : ""), @@ -3784,16 +4054,16 @@ sub onall { ((defined $opt::timeout) ? "--timeout ".$opt::timeout : ""), ((defined $opt::ungroup) ? "-u" : ""), ((defined $opt::tee) ? "--tee" : ""), - ((defined $opt::workdir) ? "--wd ".::shell_quote_scalar($opt::workdir) : ""), - (@Global::transfer_files ? map { "--tf ".::shell_quote_scalar($_) } + ((defined $opt::workdir) ? "--wd ".Q($opt::workdir) : ""), + (@Global::transfer_files ? map { "--tf ".Q($_) } @Global::transfer_files : ""), - (@Global::ret_files ? map { "--return ".::shell_quote_scalar($_) } + (@Global::ret_files ? map { "--return ".Q($_) } @Global::ret_files : ""), - (@opt::env ? map { "--env ".::shell_quote_scalar($_) } @opt::env : ""), + (@opt::env ? map { "--env ".Q($_) } @opt::env : ""), (map { "-v" } @opt::v), ); ::debug("init", "| $0 $options\n"); - open(my $parallel_fh, "|-", "$0 --will-cite -j0 $options") || + open(my $parallel_fh, "|-", "$0 -0 --will-cite -j0 $options") || ::die_bug("This does not run GNU Parallel: $0 $options"); my @joblogs; for my $host (sort keys %Global::host) { @@ -3804,16 +4074,20 @@ sub onall { $joblog = "--joblog $joblog"; } my $quad = $opt::arg_file_sep || "::::"; - ::debug("init", "$0 $suboptions -j1 $joblog ", + # If PARALLEL_ENV is set: Pass it on + my $penv=$Global::parallel_env ? + "PARALLEL_ENV=".Q($Global::parallel_env) : + ''; + ::debug("init", "$penv $0 $suboptions -j1 $joblog ", ((defined $opt::tag) ? - "--tagstring ".shell_quote_scalar($sshlogin->string()) : ""), - " -S ", shell_quote_scalar($sshlogin->string())," ", + "--tagstring ".Q($sshlogin->string()) : ""), + " -S ", Q($sshlogin->string())," ", join(" ",shell_quote(@command))," $quad @argfiles\n"); - print $parallel_fh "$0 $suboptions -j1 $joblog ", + print $parallel_fh "$penv $0 $suboptions -j1 $joblog ", ((defined $opt::tag) ? - "--tagstring ".shell_quote_scalar($sshlogin->string()) : ""), - " -S ", shell_quote_scalar($sshlogin->string())," ", - join(" ",shell_quote(@command))," $quad @argfiles\n"; + "--tagstring ".Q($sshlogin->string()) : ""), + " -S ", Q($sshlogin->string())," ", + join(" ",shell_quote(@command))," $quad @argfiles\0"; } close $parallel_fh; $Global::exitstatus = $? >> 8; @@ -3833,10 +4107,10 @@ sub onall { } -sub __SIGNAL_HANDLING__ {} +sub __SIGNAL_HANDLING__() {} -sub sigtstp { +sub sigtstp() { # Send TSTP signal (Ctrl-Z) to all children process groups # Uses: # %SIG @@ -3844,7 +4118,7 @@ sub sigtstp { signal_children("TSTP"); } -sub sigpipe { +sub sigpipe() { # Send SIGPIPE signal to all children process groups # Uses: # %SIG @@ -3852,7 +4126,7 @@ sub sigpipe { signal_children("PIPE"); } -sub signal_children { +sub signal_children() { # Send signal to all children process groups # and GNU Parallel itself # Uses: @@ -3866,7 +4140,7 @@ sub signal_children { kill $signal, $$; } -sub save_original_signal_handler { +sub save_original_signal_handler() { # Remember the original signal handler # Uses: # %Global::original_sig @@ -3893,7 +4167,7 @@ sub save_original_signal_handler { }; } -sub list_running_jobs { +sub list_running_jobs() { # Print running jobs on tty # Uses: # %Global::running @@ -3903,121 +4177,130 @@ sub list_running_jobs { } } -sub start_no_new_jobs { +sub start_no_new_jobs() { # Start no more jobs # Uses: # %Global::original_sig # %Global::unlink # $Global::start_no_new_jobs # Returns: N/A - $SIG{TERM} = $Global::original_sig{TERM}; +# $SIG{TERM} = $Global::original_sig{TERM}; unlink keys %Global::unlink; ::status - ("$Global::progname: SIGTERM received. No new jobs will be started.", + ("$Global::progname: SIGHUP received. No new jobs will be started.", "$Global::progname: Waiting for these ".(keys %Global::running). - " jobs to finish. Send SIGTERM again to stop now."); + " jobs to finish. Send SIGTERM to stop now."); list_running_jobs(); $Global::start_no_new_jobs ||= 1; } -sub reaper { - # A job finished. - # Print the output. - # Start another job +sub reapers() { + # Run reaper until there are no more left + # Returns: + # @pids_reaped = pids of reaped processes + my @pids_reaped; + my $pid; + while($pid = reaper()) { + push @pids_reaped, $pid; + } + return @pids_reaped; +} + +sub reaper() { + # A job finished: + # * Set exitstatus, exitsignal, endtime. + # * Free ressources for new job + # * Update median runtime + # * Print output + # * If --halt = now: Kill children + # * Print progress # Uses: - # %Global::sshmaster # %Global::running # $opt::timeout # $Global::timeoutq - # $opt::halt # $opt::keeporder # $Global::total_running # Returns: - # @pids_reaped = PIDs of children finished + # $stiff = PID of child finished my $stiff; - my @pids_reaped; - my $children_reaped = 0; debug("run", "Reaper "); - # For efficiency surround with BEGIN/COMMIT when using $opt::sqlmaster - $opt::sqlmaster and $Global::sql->run("BEGIN;"); - while (($stiff = waitpid(-1, &WNOHANG)) > 0) { - # $stiff = pid of dead process - if(wantarray) { - push(@pids_reaped,$stiff); - } else { - $children_reaped++; - } - if($Global::sshmaster{$stiff}) { - # This is one of the ssh -M: ignore - next; - } - my $job = $Global::running{$stiff}; + if(($stiff = waitpid(-1, &WNOHANG)) <= 0) { + # No jobs waiting to be reaped + return 0; + } - # '-a <(seq 10)' will give us a pid not in %Global::running - $job or next; - delete $Global::running{$stiff}; - $Global::total_running--; - if($job->{'commandline'}{'skip'}) { - # $job->skip() was called - $job->set_exitstatus(-2); - $job->set_exitsignal(0); - } else { - $job->set_exitstatus($? >> 8); - $job->set_exitsignal($? & 127); - } + # $stiff = pid of dead process + my $job = $Global::running{$stiff}; - debug("run", "seq ",$job->seq()," died (", $job->exitstatus(), ")"); - $job->set_endtime(::now()); - my $sshlogin = $job->sshlogin(); - $sshlogin->dec_jobs_running(); - if($job->should_be_retried()) { - $job->free_ressources(); + # '-a <(seq 10)' will give us a pid not in %Global::running + # The same will one of the ssh -M: ignore + $job or return 0; + delete $Global::running{$stiff}; + $Global::total_running--; + if($job->{'commandline'}{'skip'}) { + # $job->skip() was called + $job->set_exitstatus(-2); + $job->set_exitsignal(0); + } else { + $job->set_exitstatus($? >> 8); + $job->set_exitsignal($? & 127); + } + + debug("run", "seq ",$job->seq()," died (", $job->exitstatus(), ")"); + $job->set_endtime(::now()); + my $sshlogin = $job->sshlogin(); + $sshlogin->dec_jobs_running(); + if($job->should_be_retried()) { + # Free up file handles + $job->free_ressources(); + } else { + # The job is done + $sshlogin->inc_jobs_completed(); + # Free the jobslot + $job->free_slot(); + if($opt::timeout and not $job->exitstatus()) { + # Update average runtime for timeout only for successful jobs + $Global::timeoutq->update_median_runtime($job->runtime()); + } + if($opt::keeporder) { + $job->print_earlier_jobs(); } else { - # The job is done - $sshlogin->inc_jobs_completed(); - # Free the jobslot - $job->free_slot(); - if($opt::timeout and not $job->exitstatus()) { - # Update average runtime for timeout only for successful jobs - $Global::timeoutq->update_median_runtime($job->runtime()); - } - if($opt::keeporder) { - $job->print_earlier_jobs(); - } else { - $job->print(); - } - if($job->should_we_halt() eq "now") { - # Kill children - ::kill_sleep_seq($job->pid()); - ::killall(); - ::wait_and_exit($Global::halt_exitstatus); - } - } - $job->cleanup(); - start_more_jobs(); - if($opt::progress) { - my %progress = progress(); - ::status_no_nl("\r",$progress{'status'}); + $job->print(); + } + if($job->should_we_halt() eq "now") { + # Kill children + ::kill_sleep_seq($job->pid()); + ::killall(); + ::wait_and_exit($Global::halt_exitstatus); } } - $opt::sqlmaster and $Global::sql->run("COMMIT;"); + $job->cleanup(); + + if($opt::progress) { + my %progress = progress(); + ::status_no_nl("\r",$progress{'status'}); + } + debug("run", "done "); - return wantarray ? @pids_reaped : $children_reaped; + return $stiff; } -sub __USAGE__ {} +sub __USAGE__() {} -sub killall { +sub killall() { # Kill all jobs by killing their process groups - + # Uses: + # $Global::start_no_new_jobs = we are stopping + # $Global::killall = Flag to not run reaper $Global::start_no_new_jobs ||= 1; + # Do not reap killed children: Ignore them instead $Global::killall ||= 1; kill_sleep_seq(keys %Global::running); } -sub kill_sleep_seq { +sub kill_sleep_seq(@) { # Send jobs TERM,TERM,KILL to processgroups # Input: # @pids = list of pids that are also processgroups @@ -4032,41 +4315,41 @@ sub kill_sleep_seq { } } -sub kill_sleep { +sub kill_sleep() { + # Kill pids with a signal and wait a while for them to die + # Input: + # $signal = signal to send to @pids + # $sleep_max = number of ms to sleep at most before returning + # @pids = pids to kill (actually process groups) + # Uses: + # $Global::killall = set by killall() to avoid calling reaper + # Returns: + # @pids = pids still alive my ($signal, $sleep_max, @pids) = @_; ::debug("kill","kill_sleep $signal ",(join " ",sort @pids),"\n"); kill $signal, @pids; my $sleepsum = 0; my $sleep = 0.001; - my @dead; while(@pids and $sleepsum < $sleep_max) { if($Global::killall) { # Killall => don't run reaper - my $stiff; - while (($stiff = waitpid(-1, &WNOHANG)) > 0) { - # remove $stiff from @pids - @pids = grep { $_ != $stiff } @pids; + while(waitpid(-1, &WNOHANG) > 0) { $sleep = $sleep/2+0.001; } - } elsif(@dead = reaper()) { - # Remove reaped pids - for my $stiff (@dead) { - @pids = grep { $_ != $stiff } @pids; - } + } elsif(reapers()) { $sleep = $sleep/2+0.001; } - @pids = grep { kill( 0, $_) } @pids; $sleep *= 1.1; ::usleep($sleep); $sleepsum += $sleep; - # Remove dead children - @pids = grep { kill( 0, $_) } @pids; + # Keep only living children + @pids = grep { kill(0, $_) } @pids; } return @pids; } -sub wait_and_exit { +sub wait_and_exit($) { # If we do not wait, we sometimes get segfault # Returns: N/A my $error = shift; @@ -4076,7 +4359,7 @@ sub wait_and_exit { killall(); } for (keys %Global::unkilled_children) { - # Kill any (non-jobs) children + # Kill any (non-jobs) children (e.g. reserved processes) kill 9, $_; waitpid($_,0); delete $Global::unkilled_children{$_}; @@ -4087,13 +4370,13 @@ sub wait_and_exit { exit($error); } -sub die_usage { +sub die_usage() { # Returns: N/A usage(); wait_and_exit(255); } -sub usage { +sub usage() { # Returns: N/A print join ("\n", @@ -4131,13 +4414,15 @@ sub usage { " O. Tange (2018): GNU Parallel 2018, Mar 2018, ISBN 9781387509881,", " DOI https://doi.org/10.5281/zenodo.1146014", "", + # Before changing this line, please read + # https://www.gnu.org/software/parallel/parallel_design.html#Citation-notice "This helps funding further development; AND IT WON'T COST YOU A CENT.", "If you pay 10000 EUR you should feel free to use GNU Parallel without citing.", "", "",); } -sub citation_notice { +sub citation_notice() { # if --will-cite or --plain: do nothing # if stderr redirected: do nothing # if $PARALLEL_HOME/will-cite: do nothing @@ -4159,6 +4444,8 @@ sub citation_notice { " O. Tange (2018): GNU Parallel 2018, Mar 2018, ISBN 9781387509881,", " DOI https://doi.org/10.5281/zenodo.1146014", "", + # Before changing this line, please read + # https://www.gnu.org/software/parallel/parallel_design.html#Citation-notice "This helps funding further development; AND IT WON'T COST YOU A CENT.", "If you pay 10000 EUR you should feel free to use GNU Parallel without citing.", "", @@ -4168,36 +4455,56 @@ sub citation_notice { "To silence this citation notice: run 'parallel --citation' once.", "" ); + mkdir $Global::config_dir; + # Number of times the user has run GNU Parallel without showing + # willingness to cite + my $runs = 0; + if(open (my $fh, "<", $Global::config_dir. + "/runs-without-willing-to-cite")) { + $runs = <$fh>; + close $fh; + } + $runs++; + if(open (my $fh, ">", $Global::config_dir. + "/runs-without-willing-to-cite")) { + print $fh $runs; + close $fh; + if($runs >= 10) { + ::status("Come on: You have run parallel $runs times. Isn't it about time ", + "you run 'parallel --citation' once to silence the citation notice?", + ""); + } + } } } -sub status { +sub status(@) { my @w = @_; my $fh = $Global::status_fd || *STDERR; print $fh map { ($_, "\n") } @w; flush $fh; } -sub status_no_nl { +sub status_no_nl(@) { my @w = @_; my $fh = $Global::status_fd || *STDERR; print $fh @w; flush $fh; } -sub warning { +sub warning(@) { my @w = @_; my $prog = $Global::progname || "parallel"; status_no_nl(map { ($prog, ": Warning: ", $_, "\n"); } @w); } -sub error { +sub error(@) { my @w = @_; my $prog = $Global::progname || "parallel"; status(map { ($prog.": Error: ". $_); } @w); } -sub die_bug { +sub die_bug($) { my $bugid = shift; print STDERR ("$Global::progname: This should not happen. You have found a bug.\n", @@ -4214,23 +4521,23 @@ sub die_bug { ::wait_and_exit(255); } -sub version { +sub version() { # Returns: N/A - print join("\n", - "GNU $Global::progname $Global::version", - "Copyright (C) 2007,2008,2009,2010,2011,2012,2013,2014,2015,2016,2017,2018", - "Ole Tange and Free Software Foundation, Inc.", - "License GPLv3+: GNU GPL version 3 or later ", - "This is free software: you are free to change and redistribute it.", - "GNU $Global::progname comes with no warranty.", - "", - "Web site: http://www.gnu.org/software/${Global::progname}\n", - "When using programs that use GNU Parallel to process data for publication", - "please cite as described in 'parallel --citation'.\n", + print join + ("\n", + "GNU $Global::progname $Global::version", + "Copyright (C) 2007-2019 Ole Tange and Free Software Foundation, Inc.", + "License GPLv3+: GNU GPL version 3 or later ", + "This is free software: you are free to change and redistribute it.", + "GNU $Global::progname comes with no warranty.", + "", + "Web site: http://www.gnu.org/software/${Global::progname}\n", + "When using programs that use GNU Parallel to process data for publication", + "please cite as described in 'parallel --citation'.\n", ); } -sub citation { +sub citation() { # Returns: N/A my ($all_argv_ref,$argv_options_removed_ref) = @_; my $all_argv = "@$all_argv_ref"; @@ -4259,11 +4566,16 @@ sub citation { "", "(Feel free to use \\nocite{tange_ole_2018_1146014})", "", + # Before changing this line, please read + # https://www.gnu.org/software/parallel/parallel_design.html#Citation-notice + # https://git.savannah.gnu.org/cgit/parallel.git/tree/doc/citation-notice-faq.txt "This helps funding further development; AND IT WON'T COST YOU A CENT.", "If you pay 10000 EUR you should feel free to use GNU Parallel without citing.", "", "More about funding GNU Parallel and the citation notice:", + "https://lists.gnu.org/archive/html/parallel/2013-11/msg00006.html", "https://www.gnu.org/software/parallel/parallel_design.html#Citation-notice", + "https://git.savannah.gnu.org/cgit/parallel.git/tree/doc/citation-notice-faq.txt", "", "If you send a copy of your published article to tange\@gnu.org, it will be", "mentioned in the release notes of next version of GNU Parallel.", @@ -4281,8 +4593,13 @@ sub citation { close $fh; ::status( "", - "Thank you for your support. It is much appreciated. The citation", - "notice is now silenced.", + "Thank you for your support: You are the reason why there is funding to", + "continue maintaining GNU Parallel. On behalf of future versions of", + "GNU Parallel, which would not exist without your support:", + "", + " THANK YOU SO MUCH", + "", + "It is really appreciated. The citation notice is now silenced.", ""); } else { ::status( @@ -4303,7 +4620,7 @@ sub citation { } } -sub show_limits { +sub show_limits() { # Returns: N/A print("Maximal size of command: ",Limits::Command::real_max_length(),"\n", "Maximal used size of command: ",Limits::Command::max_length(),"\n", @@ -4313,7 +4630,7 @@ sub show_limits { "press CTRL-D or CTRL-C\n"); } -sub embed { +sub embed() { # Give an embeddable version of GNU Parallel # Tested with: bash, zsh, ksh, ash, dash, sh my $randomstring = "cut-here-".join"", @@ -4339,8 +4656,8 @@ sub embed { } print "#!$Global::shell -# Copyright (C) 2007,2008,2009,2010,2011,2012,2013,2014,2015,2016, -# 2017,2018 $user, Ole Tange and Free Software Foundation, Inc. +# Copyright (C) 2007-2019 $user, Ole Tange and Free Software +# Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -4415,10 +4732,11 @@ echo $p $y $c $h " $0 --embed > new_script"); } -sub __GENERIC_COMMON_FUNCTION__ {} + +sub __GENERIC_COMMON_FUNCTION__() {} -sub mkdir_or_die { +sub mkdir_or_die($) { # If dir is not executable: die my $dir = shift; # The eval is needed to catch exception from mkdir @@ -4429,7 +4747,7 @@ sub mkdir_or_die { } } -sub tmpfile { +sub tmpfile(@) { # Create tempfile as $TMPDIR/parXXXXX # Returns: # $filehandle = opened file handle @@ -4445,7 +4763,7 @@ sub tmpfile { } } -sub tmpname { +sub tmpname($) { # Select a name that does not exist # Do not create the file as it may be used for creating a socket (by tmux) # Remember the name in $Global::unlink to avoid hitting the same name twice @@ -4466,15 +4784,15 @@ sub tmpname { return $tmpname; } -sub tmpfifo { +sub tmpfifo() { # Find an unused name and mkfifo on it use POSIX qw(mkfifo); - my $tmpfifo = tmpname("fif",@_); + my $tmpfifo = tmpname("fif"); mkfifo($tmpfifo,0600); return $tmpfifo; } -sub rm { +sub rm(@) { # Remove file and remove it from %Global::unlink # Uses: # %Global::unlink @@ -4482,7 +4800,7 @@ sub rm { unlink @_; } -sub size_of_block_dev { +sub size_of_block_dev() { # Like -s but for block devices # Input: # $blockdev = file name of block device @@ -4500,7 +4818,7 @@ sub size_of_block_dev { } } -sub qqx { +sub qqx(@) { # Like qx but with clean environment (except for @keep) # and STDERR ignored # This is needed if the environment contains functions @@ -4521,12 +4839,12 @@ sub qqx { } } -sub uniq { +sub uniq(@) { # Remove duplicates and return unique values return keys %{{ map { $_ => 1 } @_ }}; } -sub min { +sub min(@) { # Returns: # Minimum value of array my $min; @@ -4539,7 +4857,7 @@ sub min { return $min; } -sub max { +sub max(@) { # Returns: # Maximum value of array my $max; @@ -4552,7 +4870,7 @@ sub max { return $max; } -sub sum { +sub sum() { # Returns: # Sum of values of array my @args = @_; @@ -4564,24 +4882,24 @@ sub sum { return $sum; } -sub undef_as_zero { +sub undef_as_zero($) { my $a = shift; return $a ? $a : 0; } -sub undef_as_empty { +sub undef_as_empty($) { my $a = shift; return $a ? $a : ""; } -sub undef_if_empty { +sub undef_if_empty($) { if(defined($_[0]) and $_[0] eq "") { return undef; } return $_[0]; } -sub multiply_binary_prefix { +sub multiply_binary_prefix(@) { # Evalualte numbers with binary prefix # Ki=2^10, Mi=2^20, Gi=2^30, Ti=2^40, Pi=2^50, Ei=2^70, Zi=2^80, Yi=2^80 # ki=2^10, mi=2^20, gi=2^30, ti=2^40, pi=2^50, ei=2^70, zi=2^80, yi=2^80 @@ -4630,7 +4948,7 @@ sub multiply_binary_prefix { return wantarray ? @v : $v[0]; } -sub multiply_time_units { +sub multiply_time_units($) { # Evalualte numbers with time units # s=1, m=60, h=3600, d=86400 # Input: @@ -4651,7 +4969,7 @@ sub multiply_time_units { return wantarray ? @v : $v[0]; } -sub seconds_to_time_units { +sub seconds_to_time_units() { # Convert seconds into ??d??h??m??s # s=1, m=60, h=3600, d=86400 # Input: @@ -4680,7 +4998,7 @@ sub seconds_to_time_units { { my ($disk_full_fh, $b8193, $error_printed); - sub exit_if_disk_full { + sub exit_if_disk_full() { # Checks if $TMPDIR is full by writing 8kb to a tmpfile # If the disk is full: Exit immediately. # Returns: @@ -4724,7 +5042,7 @@ sub seconds_to_time_units { } } -sub spacefree { +sub spacefree($$) { # Remove comments and spaces # Inputs: # $spaces = keep 1 space? @@ -4740,6 +5058,10 @@ sub spacefree { # Keep newlines $s =~ s/\n\n+/\n/sg; $s =~ s/[ \t]+/ /mg; + } elsif(3 == $spaces) { + # Keep perl code required space + $s =~ s{([^a-zA-Z0-9/])\s+}{$1}sg; + $s =~ s{([a-zA-Z0-9/])\s+([^:a-zA-Z0-9/])}{$1$2}sg; } else { $s =~ s/\s//mg; } @@ -4748,7 +5070,7 @@ sub spacefree { { my $hostname; - sub hostname { + sub hostname() { local $/ = "\n"; if(not $hostname) { $hostname = `hostname`; @@ -4759,7 +5081,7 @@ sub spacefree { } } -sub which { +sub which(@) { # Input: # @programs = programs to find the path to # Returns: @@ -4774,7 +5096,7 @@ sub which { push(@which, grep { not -d $_ and -x $_ } $prg); } } - return @which; + return wantarray ? @which : $which[0]; } { @@ -4811,7 +5133,7 @@ sub which { # csh and tcsh disguise themselves as -sh/-csh # E.g.: ssh -tt csh@lo 'ps aux;true' |egrep ^csh # but sh also disguise itself as -sh - # (When?) + # (TODO When does that happen?) "-sh" => ["sh"], "-csh" => ["tcsh", "csh"], # ash disguises itself as -ash @@ -4820,7 +5142,7 @@ sub which { "-dash" => ["dash", "ash", "sh"], # bash disguises itself as -bash "-bash" => ["bash", "sh"], - # ksh disguises itself as -ash + # ksh disguises itself as -ksh "-ksh" => ["ksh", "sh"], # zsh disguises itself as -zsh "-zsh" => ["zsh", "sh"], @@ -4862,7 +5184,7 @@ sub which { { my %pid_parentpid_cmd; - sub pid_table { + sub pid_table() { # Returns: # %children_of = { pid -> children of pid } # %parent_of = { pid -> pid of parent } @@ -4872,9 +5194,10 @@ sub which { # Filter for SysV-style `ps` my $sysv = q( ps -ef | perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;). q(s/^.{$s}//; print "@F[1,2] $_"' ); - # Crazy msys: ' is not accepted on the cmd line, but " are treated as ' - my $msys = q( ps -ef | perl -ane "1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;). - q(s/^.{$s}//; print qq{@F[1,2] $_}" ); + # Minix uses cols 2,3 and can have newlines in the command + # so lines not having numbers in cols 2,3 must be ignored + my $minix = q( ps -ef | perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;). + q(s/^.{$s}// and $F[2]>0 and $F[3]>0 and print "@F[2,3] $_"' ); # BSD-style `ps` my $bsd = q(ps -o pid,ppid,command -ax); %pid_parentpid_cmd = @@ -4890,7 +5213,8 @@ sub which { 'hpux' => $sysv, 'linux' => $sysv, 'mirbsd' => $bsd, - 'msys' => $msys, + 'minix' => $minix, + 'msys' => $sysv, 'MSWin32' => $sysv, 'netbsd' => $bsd, 'nto' => $sysv, @@ -4925,7 +5249,7 @@ sub which { } } -sub now { +sub now() { # Returns time since epoch as in seconds with 3 decimals # Uses: # @Global::use @@ -4943,7 +5267,7 @@ sub now { return (int(TimeHiRestime()*1000))/1000; } -sub usleep { +sub usleep($) { # Sleep this many milliseconds. # Input: # $ms = milliseconds to sleep @@ -4952,7 +5276,8 @@ sub usleep { select(undef, undef, undef, $ms/1000); } -sub reap_usleep { +sub __KILLER_REAPER__() {} +sub reap_usleep() { # Reap dead children. # If no dead children: Sleep specified amount with exponential backoff # Input: @@ -4961,7 +5286,7 @@ sub reap_usleep { # $ms/2+0.001 if children reaped # $ms*1.1 if no children reaped my $ms = shift; - if(reaper()) { + if(reapers()) { if(not $Global::total_completed % 100) { if($opt::timeout) { # Force cleaning the timeout queue for every 1000 jobs @@ -5010,7 +5335,7 @@ sub reap_usleep { } } -sub kill_youngest_if_over_limit { +sub kill_youngest_if_over_limit() { # Check each $sshlogin we are over limit # If over limit: kill off the youngest child # Put the child back in the queue. @@ -5035,7 +5360,7 @@ sub kill_youngest_if_over_limit { } } -sub kill_youngster_if_not_enough_mem { +sub kill_youngster_if_not_enough_mem() { # Check each $sshlogin if there is enough mem. # If less than 50% enough free mem: kill off the youngest child # Put the child back in the queue. @@ -5070,10 +5395,10 @@ sub kill_youngster_if_not_enough_mem { } -sub __DEBUGGING__ {} +sub __DEBUGGING__() {} -sub debug { +sub debug(@) { # Uses: # $Global::debug # %Global::fd @@ -5091,7 +5416,7 @@ sub debug { } } -sub my_memory_usage { +sub my_memory_usage() { # Returns: # memory usage if found # 0 otherwise @@ -5115,7 +5440,7 @@ sub my_memory_usage { } } -sub my_size { +sub my_size() { # Returns: # $size = size of object if Devel::Size is installed # -1 otherwise @@ -5128,7 +5453,7 @@ sub my_size { } } -sub my_dump { +sub my_dump(@) { # Returns: # ascii expression of object if Data::Dump(er) is installed # error code otherwise @@ -5154,25 +5479,25 @@ sub my_dump { } } -sub my_croak { +sub my_croak(@) { eval "use Carp; 1"; $Carp::Verbose = 1; croak(@_); } -sub my_carp { +sub my_carp() { eval "use Carp; 1"; $Carp::Verbose = 1; carp(@_); } -sub __OBJECT_ORIENTED_PARTS__ {} +sub __OBJECT_ORIENTED_PARTS__() {} package SSHLogin; -sub new { +sub new($$) { my $class = shift; my $sshlogin_string = shift; my $ncpus; @@ -5226,49 +5551,49 @@ sub new { }, ref($class) || $class; } -sub DESTROY { +sub DESTROY($) { my $self = shift; # Remove temporary files if they are created. ::rm($self->{'loadavg_file'}); ::rm($self->{'swap_activity_file'}); } -sub string { +sub string($) { my $self = shift; return $self->{'string'}; } -sub jobs_running { +sub jobs_running($) { my $self = shift; return ($self->{'jobs_running'} || "0"); } -sub inc_jobs_running { +sub inc_jobs_running($) { my $self = shift; $self->{'jobs_running'}++; } -sub dec_jobs_running { +sub dec_jobs_running($) { my $self = shift; $self->{'jobs_running'}--; } -sub set_maxlength { +sub set_maxlength($$) { my $self = shift; $self->{'maxlength'} = shift; } -sub maxlength { +sub maxlength($) { my $self = shift; return $self->{'maxlength'}; } -sub jobs_completed { +sub jobs_completed() { my $self = shift; return $self->{'jobs_completed'}; } -sub in_hostgroups { +sub in_hostgroups() { # Input: # @hostgroups = the hostgroups to look for # Returns: @@ -5278,18 +5603,18 @@ sub in_hostgroups { return grep { defined $self->{'hostgroups'}{$_} } @_; } -sub hostgroups { +sub hostgroups() { my $self = shift; return keys %{$self->{'hostgroups'}}; } -sub inc_jobs_completed { +sub inc_jobs_completed($) { my $self = shift; $self->{'jobs_completed'}++; $Global::total_completed++; } -sub set_max_jobs_running { +sub set_max_jobs_running($$) { my $self = shift; if(defined $self->{'max_jobs_running'}) { $Global::max_jobs_running -= $self->{'max_jobs_running'}; @@ -5303,15 +5628,16 @@ sub set_max_jobs_running { $self->{'orig_max_jobs_running'} ||= $self->{'max_jobs_running'}; } -sub memfree { +sub memfree() { # Returns: # $memfree in bytes my $self = shift; $self->memfree_recompute(); + # Return 1 if not defined. return (not defined $self->{'memfree'} or $self->{'memfree'}) } -sub memfree_recompute { +sub memfree_recompute() { my $self = shift; my $script = memfreescript(); @@ -5327,7 +5653,7 @@ sub memfree_recompute { { my $script; - sub memfreescript { + sub memfreescript() { # Returns: # shellscript for giving available memory in bytes if(not $script) { @@ -5342,6 +5668,13 @@ sub memfree_recompute { q[ awk '/^((Swap)?Cached|MemFree|Buffers):/ ]. q[ { sum += \$2} END { print sum }' ]. q[ /proc/meminfo } ], + # Android uses same code as GNU/Linux + "android" => + q[ print 1024 * qx{ ]. + q[ awk '/^((Swap)?Cached|MemFree|Buffers):/ ]. + q[ { sum += \$2} END { print sum }' ]. + q[ /proc/meminfo } ], + # $ vmstat 1 1 # procs memory page faults cpu # r b w avm free re at pi po fr de sr in sy cs us sy id @@ -5397,13 +5730,13 @@ sub memfree_recompute { $perlscript .= 'if($^O eq "'.$os.'") { '.$script_of{$os}.'}'; } $perlscript =~ s/[\t\n ]+/ /g; - $script = "perl -e " . ::shell_quote_scalar($perlscript); + $script = "perl -e " . ::Q($perlscript); } return $script; } } -sub limit { +sub limit($) { # Returns: # 0 = Below limit. Start another job. # 1 = Over limit. Start no jobs. @@ -5474,13 +5807,13 @@ sub limit { } -sub swapping { +sub swapping($) { my $self = shift; my $swapping = $self->swap_activity(); return (not defined $swapping or $swapping) } -sub swap_activity { +sub swap_activity($) { # If the currently known swap activity is too old: # Recompute a new one in the background # Returns: @@ -5489,7 +5822,8 @@ sub swap_activity { # Should we update the swap_activity file? my $update_swap_activity_file = 0; if(-r $self->{'swap_activity_file'}) { - open(my $swap_fh, "<", $self->{'swap_activity_file'}) || ::die_bug("swap_activity_file-r"); + open(my $swap_fh, "<", $self->{'swap_activity_file'}) || + ::die_bug("swap_activity_file-r"); my $swap_out = <$swap_fh>; close $swap_fh; if($swap_out =~ /^(\d+)$/) { @@ -5516,7 +5850,7 @@ sub swap_activity { $swap_activity = swapactivityscript(); if($self->{'string'} ne ":") { $swap_activity = $self->sshcommand() . " " . $self->serverlogin() . " " . - ::shell_quote_scalar($swap_activity); + ::Q($swap_activity); } # Run swap_activity measuring. # As the command can take long to run if run remote @@ -5532,7 +5866,7 @@ sub swap_activity { { my $script; - sub swapactivityscript { + sub swapactivityscript() { # Returns: # shellscript for detecting swap activity # @@ -5653,13 +5987,13 @@ sub swap_activity { $perlscript .= 'if($^O eq "'.$os.'") { print `'.$vmstat{$os}[0].' | awk "{print ' . $vmstat{$os}[1] . '}"` }'; } - $script = "perl -e " . ::shell_quote_scalar($perlscript); + $script = "perl -e " . ::Q($perlscript); } return $script; } } -sub too_fast_remote_login { +sub too_fast_remote_login($) { my $self = shift; if($self->{'last_login_at'} and $self->{'time_to_login'}) { # sshd normally allows 10 simultaneous logins @@ -5676,26 +6010,31 @@ sub too_fast_remote_login { } } -sub last_login_at { +sub last_login_at($) { my $self = shift; return $self->{'last_login_at'}; } -sub set_last_login_at { +sub set_last_login_at($$) { my $self = shift; $self->{'last_login_at'} = shift; } -sub loadavg_too_high { +sub loadavg_too_high($) { my $self = shift; my $loadavg = $self->loadavg(); - return (not defined $loadavg or - $loadavg > $self->max_loadavg()); + if(defined $loadavg) { + ::debug("load", "Load $loadavg > ",$self->max_loadavg()); + return $loadavg >= $self->max_loadavg(); + } else { + # Unknown load: Assume load is too high + return 1; + } } { my $cmd; - sub loadavg_cmd { + sub loadavg_cmd() { if(not $cmd) { # aix => "ps -ae -o state,command" # state wrong # bsd => "ps ax -o state,command" @@ -5730,8 +6069,9 @@ sub loadavg_too_high { awk '{print $2,$1}' }; $dummy="echo S COMMAND;echo R dummy"; %ps=( - # TODO Find better code for AIX + # TODO Find better code for AIX/Android 'aix' => "uptime", + 'android' => "uptime", 'cygwin' => $cygwin, 'darwin' => $bsd, 'dec_osf' => $sysv2, @@ -5744,13 +6084,13 @@ sub loadavg_too_high { 'minix' => "ps el|awk '{print \$1,\$11}'", 'mirbsd' => $bsd, 'msys' => $cygwin, - 'MSWin32' => $sysv, 'netbsd' => $bsd, 'nto' => $dummy, 'openbsd' => $bsd, 'solaris' => $sysv, 'svr5' => $psel, 'ultrix' => "ps -ax | awk '{print \$3,\$5}'", + 'MSWin32' => $sysv, ); print `$ps{$^O}`; }); @@ -5762,7 +6102,7 @@ sub loadavg_too_high { } -sub loadavg { +sub loadavg($) { # If the currently know loadavg is too old: # Recompute a new one in the background # The load average is computed as the number of processes waiting for disk @@ -5813,13 +6153,13 @@ sub loadavg { my $cmd = ""; if($self->{'string'} ne ":") { $cmd = $self->sshcommand() . " " . $self->serverlogin() . " " . - ::shell_quote_scalar(loadavg_cmd()); + ::Q(loadavg_cmd()); } else { $cmd .= loadavg_cmd(); } # As the command can take long to run if run remote # save it to a tmp file before moving it to the correct file - ::debug("load", "Cmd: ", $cmd,"\n"); + ::debug("load", "Update load\n"); my $file = $self->{'loadavg_file'}; # tmpfile on same filesystem as $file my $tmpfile = $file.$$; @@ -5828,7 +6168,7 @@ sub loadavg { return $self->{'loadavg'}; } -sub max_loadavg { +sub max_loadavg($) { my $self = shift; # If --load is a file it might be changed if($Global::max_load_file) { @@ -5848,12 +6188,12 @@ sub max_loadavg { return $self->{'max_loadavg'}; } -sub set_max_loadavg { +sub set_max_loadavg($$) { my $self = shift; $self->{'max_loadavg'} = shift; } -sub compute_max_loadavg { +sub compute_max_loadavg($) { # Parse the max loadaverage that the user asked for using --load # Returns: # max loadaverage @@ -5899,17 +6239,17 @@ sub compute_max_loadavg { return $load; } -sub time_to_login { +sub time_to_login($) { my $self = shift; return $self->{'time_to_login'}; } -sub set_time_to_login { +sub set_time_to_login($$) { my $self = shift; $self->{'time_to_login'} = shift; } -sub max_jobs_running { +sub max_jobs_running($) { my $self = shift; if(not defined $self->{'max_jobs_running'}) { my $nproc = $self->compute_number_of_processes($opt::jobs); @@ -5918,12 +6258,12 @@ sub max_jobs_running { return $self->{'max_jobs_running'}; } -sub orig_max_jobs_running { +sub orig_max_jobs_running($) { my $self = shift; return $self->{'orig_max_jobs_running'}; } -sub compute_number_of_processes { +sub compute_number_of_processes($) { # Number of processes wanted and limited by system resources # Returns: # Number of processes @@ -5952,7 +6292,7 @@ sub compute_number_of_processes { my @args; my $arg; - sub reserve_filehandles { + sub reserve_filehandles($) { # Reserves filehandle my $n = shift; for (1..$n) { @@ -5960,7 +6300,7 @@ sub compute_number_of_processes { } } - sub reserve_process { + sub reserve_process() { # Spawn a dummy process my $child; if($child = fork()) { @@ -5971,8 +6311,8 @@ sub compute_number_of_processes { # The child takes one process slot # It will be killed later $SIG{'TERM'} = $Global::original_sig{'TERM'}; - if($^O eq "cygwin" or $^O eq "msys") { - # The exec does not work on Cygwin + if($^O eq "cygwin" or $^O eq "msys" or $^O eq "nto") { + # The exec does not work on Cygwin and QNX sleep 10101010; } else { # 'exec sleep' takes less RAM than sleeping in perl @@ -5985,7 +6325,7 @@ sub compute_number_of_processes { } } - sub get_args_or_jobs { + sub get_args_or_jobs() { # Get an arg or a job (depending on mode) if($Global::semaphore or ($opt::pipe and not $opt::tee)) { # Skip: No need to get args @@ -6020,6 +6360,8 @@ sub compute_number_of_processes { return 0; } else { $job = $Global::JobQueue->get(); + # Replacement must happen here due to seq() + $job and $job->replaced(); push(@jobs, $job); return 1; } @@ -6027,7 +6369,7 @@ sub compute_number_of_processes { } } - sub cleanup { + sub cleanup() { # Cleanup: Close the files for (values %fh) { close $_ } # Cleanup: Kill the children @@ -6043,7 +6385,7 @@ sub compute_number_of_processes { @jobs = (); } - sub processes_available_by_system_limit { + sub processes_available_by_system_limit($) { # If the wanted number of processes is bigger than the system limits: # Limit them to the system limits # Limits are: File handles, number of input lines, processes, @@ -6145,7 +6487,7 @@ sub compute_number_of_processes { } } -sub simultaneous_sshlogin_limit { +sub simultaneous_sshlogin_limit($) { # Test by logging in wanted number of times simultaneously # Returns: # min($wanted_processes,$working_simultaneous_ssh_logins-1) @@ -6164,7 +6506,7 @@ sub simultaneous_sshlogin_limit { my $serverlogin = $self->serverlogin(); ::warning("ssh to $serverlogin only allows ". "for $ssh_limit simultaneous logins.", - "You may raise this by changing ". + "You may raise this by changing", "/etc/ssh/sshd_config:MaxStartups and MaxSessions on $serverlogin.", "You can also try --sshdelay 0.1", "Using only ".($ssh_limit-1)." connections ". @@ -6175,12 +6517,15 @@ sub simultaneous_sshlogin_limit { return $ssh_limit; } -sub simultaneous_sshlogin { +sub simultaneous_sshlogin($) { # Using $sshlogin try to see if we can do $wanted_processes # simultaneous logins - # (ssh host echo simultaneouslogin & ssh host echo simultaneouslogin & ...)|grep simul|wc -l + # (ssh host echo simul-login & ssh host echo simul-login & ...) | + # grep simul|wc -l + # Input: + # $wanted_processes = Try for this many logins in parallel # Returns: - # Number of succesful logins + # $ssh_limit = Number of succesful parallel logins local $/ = "\n"; my $self = shift; my $wanted_processes = shift; @@ -6188,7 +6533,8 @@ sub simultaneous_sshlogin { my $serverlogin = $self->serverlogin(); my $sshdelay = $opt::sshdelay ? "sleep $opt::sshdelay;" : ""; # TODO sh -c wrapper to work for csh - my $cmd = "$sshdelay$sshcmd $serverlogin -- echo simultaneouslogin &1 &"x$wanted_processes; + my $cmd = ("$sshdelay$sshcmd $serverlogin -- ". + "echo simultaneouslogin &1 &")x$wanted_processes; ::debug("init", "Trying $wanted_processes logins at $serverlogin\n"); open (my $simul_fh, "-|", "($cmd)|grep simultaneouslogin | wc -l") or ::die_bug("simultaneouslogin"); @@ -6198,15 +6544,17 @@ sub simultaneous_sshlogin { return $ssh_limit; } -sub set_ncpus { +sub set_ncpus($$) { my $self = shift; $self->{'ncpus'} = shift; } -sub user_requested_processes { +sub user_requested_processes($) { # Parse the number of processes that the user asked for using -j + # Input: + # $opt_P = string formatted as for -P # Returns: - # the number of processes to run on this sshlogin + # $processes = the number of processes to run on this sshlogin my $self = shift; my $opt_P = shift; my $processes; @@ -6251,25 +6599,38 @@ sub user_requested_processes { return $processes; } -sub ncpus { +sub ncpus($) { + # Number of CPU threads + # --use_sockets_instead_of_threads = count socket instead + # --use_cores_instead_of_threads = count physical cores instead + # Returns: + # $ncpus = number of cpu (threads) on this sshlogin local $/ = "\n"; my $self = shift; if(not defined $self->{'ncpus'}) { my $sshcmd = $self->sshcommand(); my $serverlogin = $self->serverlogin(); if($serverlogin eq ":") { - if($opt::use_cpus_instead_of_cores) { - $self->{'ncpus'} = no_of_cpus(); + if($opt::use_sockets_instead_of_threads) { + $self->{'ncpus'} = socket_core_thread()->{'sockets'}; + } elsif($opt::use_cores_instead_of_threads) { + $self->{'ncpus'} = socket_core_thread()->{'cores'}; } else { - $self->{'ncpus'} = no_of_cores(); + $self->{'ncpus'} = socket_core_thread()->{'threads'}; } } else { my $ncpu; - if($opt::use_cpus_instead_of_cores) { - $ncpu = ::qqx("echo|$sshcmd $serverlogin -- parallel --number-of-cpus"); + if($opt::use_sockets_instead_of_threads + or + $opt::use_cpus_instead_of_cores) { + $ncpu = + ::qqx("echo|$sshcmd $serverlogin -- parallel --number-of-sockets"); + } elsif($opt::use_cores_instead_of_threads) { + $ncpu = + ::qqx("echo|$sshcmd $serverlogin -- parallel --number-of-cores"); } else { - ::debug("init",qq(echo|$sshcmd $serverlogin -- parallel --number-of-cores\n)); - $ncpu = ::qqx("echo|$sshcmd $serverlogin -- parallel --number-of-cores"); + $ncpu = + ::qqx("echo|$sshcmd $serverlogin -- parallel --number-of-threads"); } chomp $ncpu; if($ncpu =~ /^\s*[0-9]+\s*$/s) { @@ -6284,475 +6645,487 @@ sub ncpus { return $self->{'ncpus'}; } -sub no_of_cpus { + +sub nproc() { # Returns: - # Number of physical CPUs - local $/ = "\n"; # If delimiter is set, then $/ will be wrong - my $no_of_cpus; + # Number of threads using `nproc` + my $no_of_threads = ::qqx("nproc"); + chomp $no_of_threads; + return $no_of_threads; +} + +sub no_of_sockets() { + return socket_core_thread()->{'sockets'}; +} + +sub no_of_cores() { + return socket_core_thread()->{'cores'}; +} + +sub no_of_threads() { + return socket_core_thread()->{'threads'}; +} + +sub socket_core_thread() { + # Returns: + # { + # 'sockets' => #sockets = number of socket with CPU present + # 'cores' => #cores = number of physical cores + # 'threads' => #threads = number of compute cores (hyperthreading) + # 'active' => #taskset_threads = number of taskset limited cores + # } + my $cpu; + if ($^O eq 'linux') { - $no_of_cpus = no_of_cpus_gnu_linux() || no_of_cores_gnu_linux(); + $cpu = sct_gnu_linux(); + } elsif ($^O eq 'android') { + $cpu = sct_android(); } elsif ($^O eq 'freebsd') { - $no_of_cpus = no_of_cpus_freebsd(); + $cpu = sct_freebsd(); } elsif ($^O eq 'netbsd') { - $no_of_cpus = no_of_cpus_netbsd(); + $cpu = sct_netbsd(); } elsif ($^O eq 'openbsd') { - $no_of_cpus = no_of_cpus_openbsd(); + $cpu = sct_openbsd(); } elsif ($^O eq 'gnu') { - $no_of_cpus = no_of_cpus_hurd(); + $cpu = sct_hurd(); } elsif ($^O eq 'darwin') { - $no_of_cpus = no_of_cpus_darwin(); + $cpu = sct_darwin(); } elsif ($^O eq 'solaris') { - $no_of_cpus = no_of_cpus_solaris() || nproc(); + $cpu = sct_solaris(); } elsif ($^O eq 'aix') { - $no_of_cpus = no_of_cpus_aix(); + $cpu = sct_aix(); } elsif ($^O eq 'hpux') { - $no_of_cpus = no_of_cpus_hpux(); + $cpu = sct_hpux(); } elsif ($^O eq 'nto') { - $no_of_cpus = no_of_cpus_qnx(); + $cpu = sct_qnx(); } elsif ($^O eq 'svr5') { - $no_of_cpus = no_of_cpus_openserver(); + $cpu = sct_openserver(); } elsif ($^O eq 'irix') { - $no_of_cpus = no_of_cpus_irix(); + $cpu = sct_irix(); } elsif ($^O eq 'dec_osf') { - $no_of_cpus = no_of_cpus_tru64(); + $cpu = sct_tru64(); } else { - $no_of_cpus = (no_of_cpus_gnu_linux() - || no_of_cpus_freebsd() - || no_of_cpus_netbsd() - || no_of_cpus_openbsd() - || no_of_cpus_hurd() - || no_of_cpus_darwin() - || no_of_cpus_solaris() - || no_of_cpus_aix() - || no_of_cpus_hpux() - || no_of_cpus_qnx() - || no_of_cpus_openserver() - || no_of_cpus_irix() - || no_of_cpus_tru64() - # Number of cores is better than no guess for #CPUs - || nproc() + # Try all methods until we find something that works + $cpu = (sct_gnu_linux() + || sct_android() + || sct_freebsd() + || sct_netbsd() + || sct_openbsd() + || sct_hurd() + || sct_darwin() + || sct_solaris() + || sct_aix() + || sct_hpux() + || sct_qnx() + || sct_openserver() + || sct_irix() + || sct_tru64() ); } - if($no_of_cpus) { - chomp $no_of_cpus; - return $no_of_cpus; - } else { - ::warning("Cannot figure out number of cpus. Using 1."); - return 1; - } -} - -sub no_of_cores { - # Returns: - # Number of CPU cores - local $/ = "\n"; # If delimiter is set, then $/ will be wrong - my $no_of_cores; - if ($^O eq 'linux') { - $no_of_cores = no_of_cores_gnu_linux(); - } elsif ($^O eq 'freebsd') { - $no_of_cores = no_of_cores_freebsd(); - } elsif ($^O eq 'netbsd') { - $no_of_cores = no_of_cores_netbsd(); - } elsif ($^O eq 'openbsd') { - $no_of_cores = no_of_cores_openbsd(); - } elsif ($^O eq 'gnu') { - $no_of_cores = no_of_cores_hurd(); - } elsif ($^O eq 'darwin') { - $no_of_cores = no_of_cores_darwin(); - } elsif ($^O eq 'solaris') { - $no_of_cores = no_of_cores_solaris() || nproc(); - } elsif ($^O eq 'aix') { - $no_of_cores = no_of_cores_aix(); - } elsif ($^O eq 'hpux') { - $no_of_cores = no_of_cores_hpux(); - } elsif ($^O eq 'nto') { - $no_of_cores = no_of_cores_qnx(); - } elsif ($^O eq 'svr5') { - $no_of_cores = no_of_cores_openserver(); - } elsif ($^O eq 'irix') { - $no_of_cores = no_of_cores_irix(); - } elsif ($^O eq 'dec_osf') { - $no_of_cores = no_of_cores_tru64(); - } else { - $no_of_cores = (no_of_cores_gnu_linux() - || no_of_cores_freebsd() - || no_of_cores_netbsd() - || no_of_cores_openbsd() - || no_of_cores_hurd() - || no_of_cores_darwin() - || no_of_cores_solaris() - || no_of_cores_aix() - || no_of_cores_hpux() - || no_of_cores_qnx() - || no_of_cores_openserver() - || no_of_cores_irix() - || no_of_cores_tru64() - || nproc() - ); - } - if($no_of_cores) { - chomp $no_of_cores; - return $no_of_cores; - } else { - ::warning("Cannot figure out number of CPU cores. Using 1."); - return 1; - } -} - -sub nproc { - # Returns: - # Number of cores using `nproc` - my $no_of_cores = ::qqx("nproc"); - return $no_of_cores; -} - -sub no_of_cpus_gnu_linux { - # Returns: - # Number of physical CPUs on GNU/Linux - # undef if not GNU/Linux - my $no_of_cpus; - my $no_of_cores; - my $no_of_active_cores; - if(-e "/proc/cpuinfo") { - $no_of_cpus = 0; - $no_of_cores = 0; - my %seen; - if(open(my $in_fh, "<", "/proc/cpuinfo")) { - while(<$in_fh>) { - if(/^physical id.*[:](.*)/ and not $seen{$1}++) { - $no_of_cpus++; - } - /^processor.*[:]/i and $no_of_cores++; - } - close $in_fh; + if(not $cpu) { + my $nproc = nproc(); + if($nproc) { + $cpu->{'sockets'} = + $cpu->{'cores'} = + $cpu->{'threads'} = + $cpu->{'active'} = + $nproc; } } - if(-e "/proc/self/status") { - # if 'taskset' is used to limit number of cores - if(open(my $in_fh, "<", "/proc/self/status")) { + if(not $cpu) { + ::warning("Cannot figure out number of cpus. Using 1."); + $cpu->{'sockets'} = + $cpu->{'cores'} = + $cpu->{'threads'} = + $cpu->{'active'} = + 1 + } + + # Choose minimum of active and actual + my $mincpu; + $mincpu->{'sockets'} = ::min($cpu->{'sockets'},$cpu->{'active'}); + $mincpu->{'cores'} = ::min($cpu->{'cores'},$cpu->{'active'}); + $mincpu->{'threads'} = ::min($cpu->{'threads'},$cpu->{'active'}); + return $mincpu; +} + +sub sct_gnu_linux() { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + my $cpu; + local $/ = "\n"; # If delimiter is set, then $/ will be wrong + if($ENV{'PARALLEL_CPUINFO'} or -e "/proc/cpuinfo") { + $cpu->{'sockets'} = 0; + $cpu->{'cores'} = 0; + $cpu->{'threads'} = 0; + my %seen; + my %phy_seen; + my @cpuinfo; + my $physicalid; + if(open(my $in_fh, "<", "/proc/cpuinfo")) { + @cpuinfo = <$in_fh>; + close $in_fh; + } + if($ENV{'PARALLEL_CPUINFO'}) { + # Use CPUINFO from environment - used for testing only + @cpuinfo = split/(?<=\n)/,$ENV{'PARALLEL_CPUINFO'}; + } + for(@cpuinfo) { + if(/^physical id.*[:](.*)/) { + $physicalid=$1; + if(not $phy_seen{$1}++) { + $cpu->{'sockets'}++; + } + } + if(/^core id.*[:](.*)/ and not $seen{$physicalid,$1}++) { + $cpu->{'cores'}++; + } + /^processor.*[:]/i and $cpu->{'threads'}++; + } + $cpu->{'sockets'} ||= 1; + $cpu->{'cores'} ||= $cpu->{'threads'}; + } + if(-e "/proc/self/status" and not $ENV{'PARALLEL_CPUINFO'}) { + # if 'taskset' is used to limit number of threads + if(open(my $in_fh, "<", "/proc/self/status")) { while(<$in_fh>) { if(/^Cpus_allowed:\s*(\S+)/) { my $a = $1; $a =~ tr/,//d; - $no_of_active_cores = unpack ("%32b*", pack ("H*",$a)); + $cpu->{'active'} = unpack ("%32b*", pack ("H*",$a)); } } close $in_fh; } } - return (::min($no_of_cpus || $no_of_cores,$no_of_active_cores)); + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cores_gnu_linux { +sub sct_android() { # Returns: - # Number of CPU cores on GNU/Linux - # undef if not GNU/Linux - my $no_of_cores; - my $no_of_active_cores; - if(-e "/proc/cpuinfo") { - $no_of_cores = 0; - open(my $in_fh, "<", "/proc/cpuinfo") || return undef; - while(<$in_fh>) { - /^processor.*[:]/i and $no_of_cores++; - } - close $in_fh; - } - if(-e "/proc/self/status") { - # if 'taskset' is used to limit number of cores - if(open(my $in_fh, "<", "/proc/self/status")) { - while(<$in_fh>) { - if(/^Cpus_allowed:\s*(\S+)/) { - my $a = $1; - $a =~ tr/,//d; - $no_of_active_cores = unpack ("%32b*", pack ("H*",$a)); - } - } - close $in_fh; - } - } - return (::min($no_of_cores,$no_of_active_cores)); + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + # Use GNU/Linux + return sct_gnu_linux(); } -sub no_of_cpus_freebsd { +sub sct_freebsd() { # Returns: - # Number of physical CPUs on FreeBSD - # undef if not FreeBSD + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } local $/ = "\n"; - my $no_of_cpus = - (::qqx(qq{ sysctl -a dev.cpu | grep \%parent | awk '{ print \$2 }' | uniq | wc -l | awk '{ print \$1 }' }) + my $cpu; + $cpu->{'cores'} = (::qqx(qq{ sysctl -a dev.cpu | grep \%parent | awk '{ print \$2 }' | uniq | wc -l | awk '{ print \$1 }' }) or ::qqx(qq{ sysctl hw.ncpu | awk '{ print \$2 }' })); - chomp $no_of_cpus; - return $no_of_cpus; -} - -sub no_of_cores_freebsd { - # Returns: - # Number of CPU cores on FreeBSD - # undef if not FreeBSD - local $/ = "\n"; - my $no_of_cores = + $cpu->{'cores'} and chomp $cpu->{'cores'}; + $cpu->{'threads'} = (::qqx(qq{ sysctl hw.ncpu | awk '{ print \$2 }' }) or ::qqx(qq{ sysctl -a dev.cpu | grep \%parent | awk '{ print \$2 }' | uniq | wc -l | awk '{ print \$1 }' })); - chomp $no_of_cores; - return $no_of_cores; + $cpu->{'threads'} and chomp $cpu->{'threads'}; + $cpu->{'sockets'} ||= $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cpus_netbsd { +sub sct_netbsd() { # Returns: - # Number of physical CPUs on NetBSD - # undef if not NetBSD + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } local $/ = "\n"; - my $no_of_cpus = ::qqx("sysctl -n hw.ncpu"); - chomp $no_of_cpus; - return $no_of_cpus; + my $cpu; + $cpu->{'cores'} = ::qqx("sysctl -n hw.ncpu"); + $cpu->{'cores'} and chomp $cpu->{'cores'}; + $cpu->{'threads'} = ::qqx("sysctl -n hw.ncpu"); + $cpu->{'threads'} and chomp $cpu->{'threads'}; + $cpu->{'sockets'} ||= $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cores_netbsd { +sub sct_openbsd() { # Returns: - # Number of CPU cores on NetBSD - # undef if not NetBSD + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } local $/ = "\n"; - my $no_of_cores = ::qqx("sysctl -n hw.ncpu"); - chomp $no_of_cores; - return $no_of_cores; + my $cpu; + $cpu->{'cores'} = ::qqx('sysctl -n hw.ncpu'); + $cpu->{'cores'} and chomp $cpu->{'cores'}; + $cpu->{'threads'} = ::qqx('sysctl -n hw.ncpu'); + $cpu->{'threads'} and chomp $cpu->{'threads'}; + $cpu->{'sockets'} ||= $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cpus_openbsd { +sub sct_hurd() { # Returns: - # Number of physical CPUs on OpenBSD - # undef if not OpenBSD + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } local $/ = "\n"; - my $no_of_cpus = ::qqx('sysctl -n hw.ncpu'); - chomp $no_of_cpus; - return $no_of_cpus; + my $cpu; + $cpu->{'cores'} = ::qqx("nproc"); + $cpu->{'cores'} and chomp $cpu->{'cores'}; + $cpu->{'threads'} = ::qqx("nproc"); + $cpu->{'threads'} and chomp $cpu->{'threads'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cores_openbsd { +sub sct_darwin() { # Returns: - # Number of CPU cores on OpenBSD - # undef if not OpenBSD + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } local $/ = "\n"; - my $no_of_cores = ::qqx('sysctl -n hw.ncpu'); - chomp $no_of_cores; - return $no_of_cores; -} - -sub no_of_cpus_hurd { - # Returns: - # Number of physical CPUs on HURD - # undef if not HURD - local $/ = "\n"; - my $no_of_cpus = ::qqx("nproc"); - chomp $no_of_cpus; - return $no_of_cpus; -} - -sub no_of_cores_hurd { - # Returns: - # Number of physical CPUs on HURD - # undef if not HURD - local $/ = "\n"; - my $no_of_cores = ::qqx("nproc"); - chomp $no_of_cores; - return $no_of_cores; -} - -sub no_of_cpus_darwin { - # Returns: - # Number of physical CPUs on MacOSX Darwin - # undef if not MacOSX Darwin - my $no_of_cpus = + my $cpu; + $cpu->{'cores'} = (::qqx('sysctl -n hw.physicalcpu') or ::qqx(qq{ sysctl -a hw | grep [^a-z]physicalcpu[^a-z] | awk '{ print \$2 }' })); - return $no_of_cpus; -} - -sub no_of_cores_darwin { - # Returns: - # Number of CPU cores on Mac Darwin - # undef if not Mac Darwin - my $no_of_cores = + $cpu->{'cores'} and chomp $cpu->{'cores'}; + $cpu->{'threads'} = (::qqx('sysctl -n hw.logicalcpu') or ::qqx(qq{ sysctl -a hw | grep [^a-z]logicalcpu[^a-z] | awk '{ print \$2 }' })); - return $no_of_cores; + $cpu->{'threads'} and chomp $cpu->{'threads'}; + $cpu->{'sockets'} ||= $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cpus_solaris { +sub sct_solaris() { # Returns: - # Number of physical CPUs on Solaris - # undef if not Solaris - if(-x "/usr/sbin/psrinfo") { - my @psrinfo = ::qqx("/usr/sbin/psrinfo"); - if($#psrinfo >= 0) { - return $#psrinfo +1; - } - } - if(-x "/usr/sbin/prtconf") { - my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); - if($#prtconf >= 0) { - return $#prtconf +1; - } - } - if(-x "/usr/sbin/prtconf") { - my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); - if($#prtconf >= 0) { - return $#prtconf +1; - } - } - return undef; -} - -sub no_of_cores_solaris { - # Returns: - # Number of CPU cores on Solaris - # undef if not Solaris - if(-x "/usr/sbin/psrinfo") { - my @psrinfo = ::qqx("/usr/sbin/psrinfo"); - if($#psrinfo >= 0) { - return $#psrinfo +1; - } - } - if(-x "/usr/sbin/prtconf") { - my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); - if($#prtconf >= 0) { - return $#prtconf +1; - } - } - return undef; -} - -sub no_of_cpus_aix { - # Returns: - # Number of physical CPUs on AIX - # undef if not AIX + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } local $/ = "\n"; - my $no_of_cpus = 0; + my $cpu; + if(-x "/usr/sbin/psrinfo") { + my @psrinfo = ::qqx("/usr/sbin/psrinfo"); + if($#psrinfo >= 0) { + $cpu->{'cores'} = $#psrinfo +1; + } + } + if(-x "/usr/sbin/prtconf") { + my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); + if($#prtconf >= 0) { + $cpu->{'cores'} = $#prtconf +1; + } + } + if(-x "/usr/sbin/prtconf") { + my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); + if($#prtconf >= 0) { + $cpu->{'cores'} = $#prtconf +1; + } + } + $cpu->{'cores'} and chomp $cpu->{'cores'}; + + if(-x "/usr/sbin/psrinfo") { + my @psrinfo = ::qqx("/usr/sbin/psrinfo"); + if($#psrinfo >= 0) { + $cpu->{'threads'} = $#psrinfo +1; + } + } + if(-x "/usr/sbin/prtconf") { + my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); + if($#prtconf >= 0) { + $cpu->{'threads'} = $#prtconf +1; + } + } + $cpu->{'threads'} and chomp $cpu->{'threads'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } +} + +sub sct_aix() { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu; if(-x "/usr/sbin/lscfg") { - open(my $in_fh, "-|", "/usr/sbin/lscfg -vs |grep proc | wc -l|tr -d ' '") - || return undef; - $no_of_cpus = <$in_fh>; - chomp ($no_of_cpus); - close $in_fh; - } - return $no_of_cpus; -} - -sub no_of_cores_aix { - # Returns: - # Number of CPU cores on AIX - # undef if not AIX - my $no_of_cores; - if(-x "/usr/bin/vmstat") { - open(my $in_fh, "-|", "/usr/bin/vmstat 1 1") || return undef; - while(<$in_fh>) { - /lcpu=([0-9]*) / and $no_of_cores = $1; + if(open(my $in_fh, "-|", "/usr/sbin/lscfg -vs |grep proc | wc -l|tr -d ' '")) { + $cpu->{'cores'} = <$in_fh>; + chomp ($cpu->{'cores'}); + close $in_fh; } - close $in_fh; } - return $no_of_cores; + if(-x "/usr/bin/vmstat") { + if(open(my $in_fh, "-|", "/usr/bin/vmstat 1 1")) { + while(<$in_fh>) { + /lcpu=([0-9]*) / and $cpu->{'threads'} = $1; + } + close $in_fh; + } + } + + if(grep { /\d/ } values %$cpu) { + # BUG It is not not known how to calculate this + $cpu->{'sockets'} = 1; + return $cpu; + } else { + return undef; + } } -sub no_of_cpus_hpux { +sub sct_hpux() { # Returns: - # Number of physical CPUs on HP-UX - # undef if not HP-UX - my $no_of_cpus = + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu; + $cpu->{'cores'} = ::qqx(qq{ /usr/bin/mpsched -s 2>&1 | grep 'Locality Domain Count' | awk '{ print \$4 }'}); - return $no_of_cpus; + chomp($cpu->{'cores'}); + $cpu->{'threads'} = + ::qqx(qq{ /usr/bin/mpsched -s 2>&1 | perl -ne '/Processor Count\\D+(\\d+)/ and print "\$1"'}); + + if(grep { /\d/ } values %$cpu) { + # BUG It is not not known how to calculate this + $cpu->{'sockets'} = 1; + return $cpu; + } else { + return undef; + } } -sub no_of_cores_hpux { +sub sct_qnx() { # Returns: - # Number of CPU cores on HP-UX - # undef if not HP-UX - my $no_of_cores = - ::qqx(qq{ /usr/bin/mpsched -s 2>&1 | perl -ne '/Processor Count\\D+(\\d+)/ and print "\$1\n"'}); - return $no_of_cores; -} - -sub no_of_cpus_qnx { - # Returns: - # Number of physical CPUs on QNX - # undef if not QNX + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu; # BUG: It is not known how to calculate this. - my $no_of_cpus = 0; - return $no_of_cpus; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cores_qnx { +sub sct_openserver() { # Returns: - # Number of CPU cores on QNX - # undef if not QNX - # BUG: It is not known how to calculate this. - my $no_of_cores = 0; - return $no_of_cores; -} - -sub no_of_cpus_openserver { - # Returns: - # Number of physical CPUs on SCO OpenServer - # undef if not SCO OpenServer - my $no_of_cpus = 0; + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu; if(-x "/usr/sbin/psrinfo") { my @psrinfo = ::qqx("/usr/sbin/psrinfo"); if($#psrinfo >= 0) { - return $#psrinfo +1; + $cpu->{'cores'} = $#psrinfo +1; } } - return $no_of_cpus; -} - -sub no_of_cores_openserver { - # Returns: - # Number of CPU cores on SCO OpenServer - # undef if not SCO OpenServer - my $no_of_cores = 0; if(-x "/usr/sbin/psrinfo") { my @psrinfo = ::qqx("/usr/sbin/psrinfo"); if($#psrinfo >= 0) { - return $#psrinfo +1; + $cpu->{'threads'} = $#psrinfo +1; } } - return $no_of_cores; + $cpu->{'sockets'} ||= $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cpus_irix { +sub sct_irix() { # Returns: - # Number of physical CPUs on IRIX - # undef if not IRIX - my $no_of_cpus = ::qqx(qq{ hinv | grep HZ | grep Processor | awk '{print \$1}' }); - return $no_of_cpus; + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu; + $cpu->{'cores'} = ::qqx(qq{ hinv | grep HZ | grep Processor | awk '{print \$1}' }); + $cpu->{'cores'} and chomp $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cores_irix { +sub sct_tru64() { # Returns: - # Number of CPU cores on IRIX - # undef if not IRIX - my $no_of_cores = ::qqx(qq{ hinv | grep HZ | grep Processor | awk '{print \$1}' }); - return $no_of_cores; + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu; + $cpu->{'cores'} = ::qqx("sizer -pr"); + $cpu->{'cores'} and chomp $cpu->{'cores'}; + $cpu->{'cores'} ||= 1; + $cpu->{'sockets'} ||= $cpu->{'cores'}; + $cpu->{'threads'} ||= $cpu->{'cores'}; + + if(grep { /\d/ } values %$cpu) { + return $cpu; + } else { + return undef; + } } -sub no_of_cpus_tru64 { +sub sshcommand($) { # Returns: - # Number of physical CPUs on Tru64 - # undef if not Tru64 - my $no_of_cpus = ::qqx("sizer -pr"); - return $no_of_cpus; -} - -sub no_of_cores_tru64 { - # Returns: - # Number of CPU cores on Tru64 - # undef if not Tru64 - my $no_of_cores = ::qqx("sizer -pr"); - return $no_of_cores; -} - -sub sshcommand { + # $sshcommand = the command (incl options) to run when using ssh my $self = shift; if (not defined $self->{'sshcommand'}) { $self->sshcommand_of_sshlogin(); @@ -6760,7 +7133,9 @@ sub sshcommand { return $self->{'sshcommand'}; } -sub serverlogin { +sub serverlogin($) { + # Returns: + # $sshcommand = the command (incl options) to run when using ssh my $self = shift; if (not defined $self->{'serverlogin'}) { $self->sshcommand_of_sshlogin(); @@ -6768,15 +7143,16 @@ sub serverlogin { return $self->{'serverlogin'}; } -sub sshcommand_of_sshlogin { +sub sshcommand_of_sshlogin($) { + # Compute ssh command and serverlogin from sshlogin # 'server' -> ('ssh -S /tmp/parallel-ssh-RANDOM/host-','server') # 'user@server' -> ('ssh','user@server') # 'myssh user@server' -> ('myssh','user@server') # 'myssh -l user server' -> ('myssh -l user','server') # '/usr/bin/myssh -l user server' -> ('/usr/bin/myssh -l user','server') - # Returns: - # sshcommand - defaults to 'ssh' - # login@host + # Sets: + # $self->{'sshcommand'} + # $self->{'serverlogin'} my $self = shift; my ($sshcmd, $serverlogin); # If $opt::ssh is unset, use $PARALLEL_SSH or 'ssh' @@ -6806,8 +7182,7 @@ sub sshcommand_of_sshlogin { open(STDIN,"<","/dev/null"); # Run a sleep that outputs data, so it will discover # if the ssh connection closes. - my $sleep = ::shell_quote_scalar - ('$|=1;while(1){sleep 1;print "foo\n"}'); + my $sleep = ::Q('$|=1;while(1){sleep 1;print "foo\n"}'); my @master = ($opt::ssh, "-MTS", $control_path, $serverlogin, "--", "perl", "-e", $sleep); @@ -6829,9 +7204,9 @@ sub sshcommand_of_sshlogin { $self->{'serverlogin'} = $serverlogin; } -sub control_path_dir { +sub control_path_dir($) { # Returns: - # path to directory + # $control_path_dir = dir of control path (for -M) my $self = shift; if(not defined $self->{'control_path_dir'}) { $self->{'control_path_dir'} = @@ -6844,7 +7219,7 @@ sub control_path_dir { return $self->{'control_path_dir'}; } -sub rsync_transfer_cmd { +sub rsync_transfer_cmd($) { # Command to run to transfer a file # Input: # $file = filename of file to transfer @@ -6869,14 +7244,14 @@ sub rsync_transfer_cmd { $file = ::shell_quote_file($file); my $sshcmd = $self->sshcommand(); my $rsync_opts = $ENV{'PARALLEL_RSYNC_OPTS'}. - " -e".::shell_quote_scalar($sshcmd); + " -e".::Q($sshcmd); my $serverlogin = $self->serverlogin(); # Make dir if it does not exist return "$sshcmd $serverlogin -- mkdir -p $rsync_destdir && " . rsync()." $rsync_opts $file $serverlogin:$rsync_destdir"; } -sub cleanup_cmd { +sub cleanup_cmd($$$) { # Command to run to remove the remote file # Input: # $file = filename to remove @@ -6902,15 +7277,15 @@ sub cleanup_cmd { $dir .= $_."/"; unshift @rmdir, ::shell_quote_file($dir); } - my $rmdir = @rmdir ? "sh -c ".::shell_quote_scalar("rmdir @rmdir 2>/dev/null;") : ""; + my $rmdir = @rmdir ? "sh -c ".::Q("rmdir @rmdir 2>/dev/null;") : ""; if(defined $opt::workdir and $opt::workdir eq "...") { - $rmdir .= ::shell_quote_scalar("rm -rf " . ::shell_quote_file($workdir).';'); + $rmdir .= ::Q("rm -rf " . ::shell_quote_file($workdir).';'); } $f = ::shell_quote_file($f); my $sshcmd = $self->sshcommand(); my $serverlogin = $self->serverlogin(); - return "$sshcmd $serverlogin -- ".::shell_quote_scalar("rm -f $f; $rmdir"); + return "$sshcmd $serverlogin -- ".::Q("rm -f $f; $rmdir"); } { @@ -6919,6 +7294,8 @@ sub cleanup_cmd { sub rsync { # rsync 3.1.x uses protocol 31 which is unsupported by 2.5.7. # If the version >= 3.1.0: downgrade to protocol 30 + # Returns: + # $rsync = "rsync" or "rsync --protocol 30" if(not $rsync) { my @out = `rsync --version`; for (@out) { @@ -6940,7 +7317,7 @@ sub cleanup_cmd { package JobQueue; -sub new { +sub new($) { my $class = shift; my $commandref = shift; my $read_from = shift; @@ -6960,7 +7337,7 @@ sub new { }, ref($class) || $class; } -sub get { +sub get($) { my $self = shift; $self->{'this_job_no'}++; @@ -6977,21 +7354,21 @@ sub get { } } -sub unget { +sub unget($) { my $self = shift; unshift @{$self->{'unget'}}, @_; $self->{'this_job_no'} -= @_; } -sub empty { +sub empty($) { my $self = shift; - my $empty = (not @{$self->{'unget'}}) - && $self->{'commandlinequeue'}->empty(); + my $empty = (not @{$self->{'unget'}}) && + $self->{'commandlinequeue'}->empty(); ::debug("run", "JobQueue->empty $empty "); return $empty; } -sub total_jobs { +sub total_jobs($) { my $self = shift; if(not defined $self->{'total_jobs'}) { if($opt::pipe and not $opt::tee) { @@ -7019,7 +7396,7 @@ sub total_jobs { while($record = $record_queue->get()) { push @arg_records, $record; } - if($opt::shuf) { + if($opt::shuf and @arg_records) { my $i = @arg_records; while (--$i) { my $j = int rand($i+1); @@ -7027,29 +7404,35 @@ sub total_jobs { } } $record_queue->unget(@arg_records); - $self->{'total_jobs'} = - ::ceil((1+$#arg_records+$self->{'this_job_no'}) - / ::max($Global::max_number_of_args,1)); + # $#arg_records = number of args - 1 + # We have read one @arg_record for this job (so add 1 more) + my $num_args = $#arg_records + 2; + # This jobs is not started so -1 + my $started_jobs = $self->{'this_job_no'} - 1; + my $max_args = ::max($Global::max_number_of_args,1); + $self->{'total_jobs'} = ::ceil($num_args / $max_args) + + $started_jobs; ::debug("init","Total jobs: ".$self->{'total_jobs'}. - " (".(1+$#arg_records)."+".$self->{'this_job_no'}.")\n"); + " ($num_args/$max_args + $started_jobs)\n"); } } return $self->{'total_jobs'}; } -sub flush_total_jobs { +sub flush_total_jobs($) { # Unset total_jobs to force recomputing my $self = shift; + ::debug("init","flush Total jobs: "); $self->{'total_jobs'} = undef; } -sub next_seq { +sub next_seq($) { my $self = shift; return $self->{'commandlinequeue'}->seq(); } -sub quote_args { +sub quote_args($) { my $self = shift; return $self->{'commandlinequeue'}->quote_args(); } @@ -7057,7 +7440,7 @@ sub quote_args { package Job; -sub new { +sub new($) { my $class = shift; my $commandlineref = shift; return bless { @@ -7088,28 +7471,28 @@ sub new { }, ref($class) || $class; } -sub replaced { +sub replaced($) { my $self = shift; $self->{'commandline'} or ::die_bug("commandline empty"); return $self->{'commandline'}->replaced(); } -sub seq { +sub seq($) { my $self = shift; return $self->{'commandline'}->seq(); } -sub set_seq { +sub set_seq($$) { my $self = shift; return $self->{'commandline'}->set_seq(shift); } -sub slot { +sub slot($) { my $self = shift; return $self->{'commandline'}->slot(); } -sub free_slot { +sub free_slot($) { my $self = shift; push @Global::slots, $self->slot(); } @@ -7117,7 +7500,7 @@ sub free_slot { { my($cattail); - sub cattail { + sub cattail() { # Returns: # $cattail = perl program for: # cattail "decompress program" writerpid [file_to_decompress or stdin] [file_to_unlink] @@ -7196,7 +7579,7 @@ sub free_slot { } } -sub openoutputfiles { +sub openoutputfiles($) { # Open files for STDOUT and STDERR # Set file handles in $self->fh my $self = shift; @@ -7307,7 +7690,7 @@ sub openoutputfiles { } } -sub print_verbose_dryrun { +sub print_verbose_dryrun($) { # If -v set: print command to stdout (possibly buffered) # This must be done before starting the command my $self = shift; @@ -7326,26 +7709,26 @@ sub print_verbose_dryrun { } } -sub add_rm { +sub add_rm($) { # Files to remove when job is done my $self = shift; push @{$self->{'unlink'}}, @_; } -sub get_rm { +sub get_rm($) { # Files to remove when job is done my $self = shift; return @{$self->{'unlink'}}; } -sub cleanup { +sub cleanup($) { # Remove files when job is done my $self = shift; unlink $self->get_rm(); delete @Global::unlink{$self->get_rm()}; } -sub grouped { +sub grouped($) { my $self = shift; # Set reading FD if using --group (--ungroup does not need) for my $fdno (1,2) { @@ -7355,12 +7738,12 @@ sub grouped { open(my $fdr,"<", $self->fh($fdno,'name')) || ::die_bug("fdr: Cannot open ".$self->fh($fdno,'name')); $self->set_fh($fdno,'r',$fdr); - # Unlink if required + # Unlink if not debugging $Global::debug or ::rm($self->fh($fdno,"unlink")); } } -sub empty_input_wrapper { +sub empty_input_wrapper($) { # If no input: exit(0) # If some input: Pass input as input to command on STDIN # This avoids starting the command if there is no input. @@ -7385,7 +7768,7 @@ sub empty_input_wrapper { exit ($?&127 ? 128+($?&127) : 1+$?>>8) } }); - ::debug("run",'Empty wrap: perl -e '.::shell_quote_scalar($script)."\n"); + ::debug("run",'Empty wrap: perl -e '.::Q($script)."\n"); if($Global::cshell and length $command > 499) { @@ -7393,16 +7776,16 @@ sub empty_input_wrapper { # $command = "perl -e '".base64_zip_eval()."' ". # join" ",string_zip_base64( # 'exec "'.::perl_quote_scalar($command).'"'); - return 'perl -e '.::shell_quote_scalar($script)." ". + return 'perl -e '.::Q($script)." ". base64_wrap("exec \"$Global::shell\",'-c',\"". ::perl_quote_scalar($command).'"'); } else { - return 'perl -e '.::shell_quote_scalar($script)." ". - $Global::shell." -c ".::shell_quote_scalar($command); + return 'perl -e '.::Q($script)." ". + $Global::shell." -c ".::Q($command); } } -sub filter_through_compress { +sub filter_through_compress($) { my $self = shift; # Send stdout to stdin for $opt::compress_program(1) # Send stderr to stdin for $opt::compress_program(2) @@ -7435,19 +7818,19 @@ sub filter_through_compress { -sub set_fh { +sub set_fh($$$$) { # Set file handle my ($self, $fd_no, $key, $fh) = @_; $self->{'fd'}{$fd_no,$key} = $fh; } -sub fh { +sub fh($) { # Get file handle my ($self, $fd_no, $key) = @_; return $self->{'fd'}{$fd_no,$key}; } -sub write { +sub write($) { my $self = shift; my $remaining_ref = shift; my $stdin_fh = $self->fh(0,"w"); @@ -7465,7 +7848,7 @@ sub write { } } -sub set_block { +sub set_block($$$$$$) { # Copy stdin buffer from $block_ref up to $endpos # Prepend with $header_ref if virgin (i.e. not --roundrobin) # Remove $recstart and $recend if needed @@ -7489,18 +7872,18 @@ sub set_block { $self->add_transfersize($self->{'block_length'}); } -sub block_ref { +sub block_ref($) { my $self = shift; return \$self->{'block'}; } -sub block_length { +sub block_length($) { my $self = shift; return $self->{'block_length'}; } -sub remove_rec_sep { +sub remove_rec_sep($) { my ($block_ref,$recstart,$recend) = @_; # Remove record separator $$block_ref =~ s/$recend$recstart//gos; @@ -7508,7 +7891,7 @@ sub remove_rec_sep { $$block_ref =~ s/$recend$//os; } -sub non_blocking_write { +sub non_blocking_write($) { my $self = shift; my $something_written = 0; use POSIX qw(:errno_h); @@ -7538,34 +7921,34 @@ sub non_blocking_write { } -sub virgin { +sub virgin($) { my $self = shift; return $self->{'virgin'}; } -sub set_virgin { +sub set_virgin($$) { my $self = shift; $self->{'virgin'} = shift; } -sub pid { +sub pid($) { my $self = shift; return $self->{'pid'}; } -sub set_pid { +sub set_pid($$) { my $self = shift; $self->{'pid'} = shift; } -sub starttime { +sub starttime($) { # Returns: # UNIX-timestamp this job started my $self = shift; return sprintf("%.3f",$self->{'starttime'}); } -sub set_starttime { +sub set_starttime($@) { my $self = shift; my $starttime = shift || ::now(); $self->{'starttime'} = $starttime; @@ -7574,7 +7957,7 @@ sub set_starttime { $starttime); } -sub runtime { +sub runtime($) { # Returns: # Run time in seconds with 3 decimals my $self = shift; @@ -7582,7 +7965,7 @@ sub runtime { int(($self->endtime() - $self->starttime())*1000)/1000); } -sub endtime { +sub endtime($) { # Returns: # UNIX-timestamp this job ended # 0 if not ended yet @@ -7590,7 +7973,7 @@ sub endtime { return ($self->{'endtime'} || 0); } -sub set_endtime { +sub set_endtime($$) { my $self = shift; my $endtime = shift; $self->{'endtime'} = $endtime; @@ -7599,7 +7982,7 @@ sub set_endtime { $self->runtime()); } -sub is_timedout { +sub is_timedout($) { # Is the job timedout? # Input: # $delta_time = time that the job may run @@ -7610,13 +7993,13 @@ sub is_timedout { return time > $self->{'starttime'} + $delta_time; } -sub kill { +sub kill($) { my $self = shift; $self->set_exitstatus(-1); ::kill_sleep_seq($self->pid()); } -sub failed { +sub failed($) { # return number of times failed for this $sshlogin # Input: # $sshlogin @@ -7627,7 +8010,7 @@ sub failed { return $self->{'failed'}{$sshlogin}; } -sub failed_here { +sub failed_here($) { # return number of times failed for the current $sshlogin # Returns: # Number of times failed for this sshlogin @@ -7635,33 +8018,33 @@ sub failed_here { return $self->{'failed'}{$self->sshlogin()}; } -sub add_failed { +sub add_failed($) { # increase the number of times failed for this $sshlogin my $self = shift; my $sshlogin = shift; $self->{'failed'}{$sshlogin}++; } -sub add_failed_here { +sub add_failed_here($) { # increase the number of times failed for the current $sshlogin my $self = shift; $self->{'failed'}{$self->sshlogin()}++; } -sub reset_failed { +sub reset_failed($) { # increase the number of times failed for this $sshlogin my $self = shift; my $sshlogin = shift; delete $self->{'failed'}{$sshlogin}; } -sub reset_failed_here { +sub reset_failed_here($) { # increase the number of times failed for this $sshlogin my $self = shift; delete $self->{'failed'}{$self->sshlogin()}; } -sub min_failed { +sub min_failed($) { # Returns: # the number of sshlogins this command has failed on # the minimal number of times this command has failed @@ -7672,7 +8055,7 @@ sub min_failed { return ($number_of_sshlogins_failed_on,$min_failures); } -sub total_failed { +sub total_failed($) { # Returns: # $total_failures = the number of times this command has failed my $self = shift; @@ -7712,7 +8095,7 @@ sub total_failed { { my $script; - sub fifo_wrap { + sub fifo_wrap() { # Script to create a fifo, run a command on the fifo # while copying STDIN to the fifo, and finally # remove the fifo and return the exit code of the command. @@ -7749,7 +8132,7 @@ sub total_failed { } } -sub wrapped { +sub wrapped($) { # Wrap command with: # * --shellquote # * --nice @@ -7764,7 +8147,7 @@ sub wrapped { # * --nice/--cat/--fifo should be done on the remote machine # * --pipepart/--pipe should be done on the local machine inside --tmux # Uses: - # $opt::shellquote + # @opt::shellquote # $opt::nice # $Global::shell # $opt::cat @@ -7781,31 +8164,26 @@ sub wrapped { # This will force them to run correctly, but will fail in # tcsh so we do not do it. # $command .= "\n\n"; - if($opt::shellquote) { - # Prepend /bin/echo (echo no-/bin is wrong in csh) - # and quote twice - $command = "/bin/echo " . - ::shell_quote_scalar(::shell_quote_scalar($command)); - } - if($ENV{'PARALLEL_ENV'}) { - if(-e $ENV{'PARALLEL_ENV'}) { - # This is a file/fifo: Replace envvar with content of file - open(my $parallel_env, "<", $ENV{'PARALLEL_ENV'}) || - ::die_bug("Cannot read parallel_env from $ENV{'PARALLEL_ENV'}"); - local $/; - $ENV{'PARALLEL_ENV'} = <$parallel_env>; - close $parallel_env; + if(@opt::shellquote) { + # Quote one time for each --shellquote + my $c = $command; + for(@opt::shellquote) { + $c = ::Q($c); } + # Prepend "echo" (it is written in perl because + # quoting '-e' causes problem in some versions and + # csh's version does something wrong) + $command = q(perl -e '$,=" "; print "@ARGV\n";' -- ) . ::Q($c); + } + if($Global::parallel_env) { # If $PARALLEL_ENV set, put that in front of the command # Used for env_parallel.* - # Map \001 to \n to make it easer to quote \n in $PARALLEL_ENV - $ENV{'PARALLEL_ENV'} =~ s/\001/\n/g; if($Global::shell =~ /zsh/) { # The extra 'eval' will make aliases work, too - $command = $ENV{'PARALLEL_ENV'}."\n". - "eval ".::shell_quote_scalar($command); + $command = $Global::parallel_env."\n". + "eval ".::Q($command); } else { - $command = $ENV{'PARALLEL_ENV'}."\n".$command; + $command = $Global::parallel_env."\n".$command; } } if($opt::cat) { @@ -7820,7 +8198,7 @@ sub wrapped { $command = 'cat > $PARALLEL_TMP;'. $command.";". postpone_exit_and_cleanup(). - '$PARALLEL_TMP'; + '$PARALLEL_TMP'; } elsif($opt::fifo) { # Prepend fifo-wrapper. In essence: # mkfifo {} @@ -7830,10 +8208,7 @@ sub wrapped { # wait; rm {} # without affecting $? $command = fifo_wrap(). " ". - $Global::shell. " ". - ::shell_quote_scalar($command). - ' $PARALLEL_TMP'. - ';'; + $Global::shell. " ". ::Q($command). ' $PARALLEL_TMP'. ';'; } # Wrap with ssh + tranferring of files $command = $self->sshlogin_wrap($command); @@ -7851,9 +8226,12 @@ sub wrapped { # # --pipe --tee: wrap: # (rm fifo; ... ) < fifo + # + # --pipe --shard X: + # (rm fifo; ... ) < fifo $command = (shift @Global::cat_prepends). "($command)". (shift @Global::cat_appends); - } elsif($opt::pipe) { + } elsif($opt::pipe and not $opt::roundrobin) { # Wrap with EOF-detector to avoid starting $command if EOF. $command = empty_input_wrapper($command); } @@ -7876,7 +8254,7 @@ sub wrapped { return $self->{'wrapped'}; } -sub set_sshlogin { +sub set_sshlogin($$) { my $self = shift; my $sshlogin = shift; $self->{'sshlogin'} = $sshlogin; @@ -7893,12 +8271,12 @@ sub set_sshlogin { } } -sub sshlogin { +sub sshlogin($) { my $self = shift; return $self->{'sshlogin'}; } -sub string_base64 { +sub string_base64($) { # Base64 encode strings into 1000 byte blocks. # 1000 bytes is the largest word size csh supports # Input: @@ -7910,7 +8288,7 @@ sub string_base64 { return @base64; } -sub string_zip_base64 { +sub string_zip_base64($) { # Pipe string through 'bzip2 -9' and base64 encode it into 1000 # byte blocks. # 1000 bytes is the largest word size csh supports @@ -7937,7 +8315,7 @@ sub string_zip_base64 { return @base64; } -sub base64_zip_eval { +sub base64_zip_eval() { # Script that: # * reads base64 strings from @ARGV # * decodes them @@ -7977,7 +8355,7 @@ sub base64_zip_eval { return $script; } -sub base64_wrap { +sub base64_wrap($) { # base64 encode Perl code # Split it into chunks of < 1000 bytes # Prepend it with a decoder that eval's it @@ -7988,11 +8366,11 @@ sub base64_wrap { my $eval_string = shift; return "perl -e ". - ::shell_quote_scalar(base64_zip_eval())." ". + ::Q(base64_zip_eval())." ". join" ",::shell_quote(string_zip_base64($eval_string)); } -sub base64_eval { +sub base64_eval($) { # Script that: # * reads base64 strings from @ARGV # * decodes them @@ -8015,7 +8393,7 @@ sub base64_eval { return $script; } -sub sshlogin_wrap { +sub sshlogin_wrap($) { # Wrap the command with the commands needed to run remotely # Input: # $command = command to run @@ -8146,7 +8524,7 @@ sub sshlogin_wrap { } else { $bashfuncset = '$bashfunc = "";' } - if($ENV{"parallel_bash_environment"}) { + if($ENV{'parallel_bash_environment'}) { $bashfuncset .= '$bashfunc .= "eval\ \"\$parallel_bash_environment\"\;";'; } ::debug("base64",$envset,$bashfuncset,"\n"); @@ -8156,7 +8534,7 @@ sub sshlogin_wrap { my $self = shift; my $command = shift; # TODO test that *sh -c 'parallel --env' use *sh - if(not defined $self->{'sshlogin_wrap'}) { + if(not defined $self->{'sshlogin_wrap'}{$command}) { my $sshlogin = $self->sshlogin(); my $serverlogin = $sshlogin->serverlogin(); my $quoted_remote_command; @@ -8165,13 +8543,19 @@ sub sshlogin_wrap { if($serverlogin eq ":") { if($opt::workdir) { # Create workdir if needed. Then cd to it. - my $wd = $self->workdir(); + my $wd = $self->workdir(); if($opt::workdir eq "." or $opt::workdir eq "...") { # If $wd does not start with '/': Prepend $HOME $wd =~ s:^([^/]):$ENV{'HOME'}/$1:; } ::mkdir_or_die($wd); - $command = "cd ".::shell_quote_scalar($wd)." || exit 255; ".$command; + my $post = ""; + if($opt::workdir eq "...") { + $post = ";".exitstatuswrapper("rm -rf ".::Q($wd).";"); + + } + $command = "cd ".::Q($wd)." || exit 255; " . + $command . $post;; } if(@opt::env) { # Prepend with environment setter, which sets functions in zsh @@ -8186,18 +8570,18 @@ sub sshlogin_wrap { $command =~ /\n/) { # csh does not deal well with > 1000 chars in one word # csh does not deal well with $ENV with \n - $self->{'sshlogin_wrap'} = base64_wrap($perl_code); + $self->{'sshlogin_wrap'}{$command} = base64_wrap($perl_code); } else { - $self->{'sshlogin_wrap'} = "perl -e ".::shell_quote_scalar($perl_code); + $self->{'sshlogin_wrap'}{$command} = "perl -e ".::Q($perl_code); } } else { - $self->{'sshlogin_wrap'} = $command; + $self->{'sshlogin_wrap'}{$command} = $command; } } else { my $pwd = ""; if($opt::workdir) { # Create remote workdir if needed. Then cd to it. - my $wd = $self->workdir(); + my $wd = ::pQ($self->workdir()); $pwd = qq{system("mkdir","-p","--","$wd"); chdir "$wd" ||}. qq{print(STDERR "parallel: Cannot chdir to $wd\\n") && exit 255;}; } @@ -8205,10 +8589,8 @@ sub sshlogin_wrap { my $remote_command = $pwd.$envset.$bashfuncset. '@ARGV="'.::perl_quote_scalar($command).'";'. monitor_parent_sshd_script(); - $quoted_remote_command = "perl -e ". - ::shell_quote_scalar($remote_command); - my $dq_remote_command = - ::shell_quote_scalar($quoted_remote_command); + $quoted_remote_command = "perl -e ". ::Q($remote_command); + my $dq_remote_command = ::Q($quoted_remote_command); if(length $dq_remote_command > 999 or not $csh_friendly @@ -8217,8 +8599,7 @@ sub sshlogin_wrap { # csh does not deal well with > 1000 chars in one word # csh does not deal well with $ENV with \n $quoted_remote_command = - "perl -e ". - ::shell_quote_scalar(::shell_quote_scalar(base64_zip_eval()))." ". + "perl -e ". ::Q(::Q(base64_zip_eval()))." ". join" ",::shell_quote(::shell_quote(string_zip_base64($remote_command))); } else { $quoted_remote_command = $dq_remote_command; @@ -8234,9 +8615,9 @@ sub sshlogin_wrap { $post .= $self->sshcleanup(); if($post) { # We need to save the exit status of the job - $post = '_EXIT_status=$?; ' . $post . ' exit $_EXIT_status;'; + $post = exitstatuswrapper($post); } - $self->{'sshlogin_wrap'} = + $self->{'sshlogin_wrap'}{$command} = ($pre . "$sshcmd $serverlogin -- exec " . $quoted_remote_command @@ -8244,10 +8625,10 @@ sub sshlogin_wrap { . $post); } } - return $self->{'sshlogin_wrap'}; + return $self->{'sshlogin_wrap'}{$command}; } -sub transfer { +sub transfer($) { # Files to transfer # Non-quoted and with {...} substituted # Returns: @@ -8267,12 +8648,12 @@ sub transfer { return @transfer; } -sub transfersize { +sub transfersize($) { my $self = shift; return $self->{'transfersize'}; } -sub add_transfersize { +sub add_transfersize($) { my $self = shift; my $transfersize = shift; $self->{'transfersize'} += $transfersize; @@ -8281,7 +8662,7 @@ sub add_transfersize { $self->{'transfersize'}); } -sub sshtransfer { +sub sshtransfer($) { # Returns for each transfer file: # rsync $file remote:$workdir my $self = shift; @@ -8294,7 +8675,7 @@ sub sshtransfer { return join("",@pre); } -sub return { +sub return($) { # Files to return # Non-quoted and with {...} substituted # Returns: @@ -8304,7 +8685,7 @@ sub return { replace_placeholders($self->{'commandline'}{'return_files'},0,0); } -sub returnsize { +sub returnsize($) { # This is called after the job has finished # Returns: # $number_of_bytes transferred in return @@ -8317,7 +8698,7 @@ sub returnsize { return $self->{'returnsize'}; } -sub add_returnsize { +sub add_returnsize($) { my $self = shift; my $returnsize = shift; $self->{'returnsize'} += $returnsize; @@ -8326,15 +8707,14 @@ sub add_returnsize { $self->{'returnsize'}); } -sub sshreturn { +sub sshreturn($) { # Returns for each return-file: # rsync remote:$workdir/$file . my $self = shift; my $sshlogin = $self->sshlogin(); my $sshcmd = $sshlogin->sshcommand(); my $serverlogin = $sshlogin->serverlogin(); - my $rsync_opts = $ENV{'PARALLEL_RSYNC_OPTS'}. - " -e".::shell_quote_scalar($sshcmd); + my $rsync_opts = $ENV{'PARALLEL_RSYNC_OPTS'}. " -e". ::Q($sshcmd); my $pre = ""; for my $file ($self->return()) { $file =~ s:^\./::g; # Remove ./ if any @@ -8355,9 +8735,8 @@ sub sshreturn { my $nobasedir = $file; $nobasedir =~ s:.*/\./::; $cd = ::shell_quote_file(::dirname($nobasedir)); - my $rsync_cd = '--rsync-path='.::shell_quote_scalar("cd $wd$cd; rsync"); - my $basename = - ::shell_quote_scalar(::shell_quote_file(::basename($file))); + my $rsync_cd = '--rsync-path='.::Q("cd $wd$cd; rsync"); + my $basename = ::Q(::shell_quote_file(::basename($file))); # --return # mkdir -p /home/tange/dir/subdir/; # rsync (--protocol 30) -rlDzR @@ -8370,7 +8749,7 @@ sub sshreturn { return $pre; } -sub sshcleanup { +sub sshcleanup($) { # Return the sshcommand needed to remove the file # Returns: # ssh command needed to remove files from sshlogin @@ -8386,12 +8765,12 @@ sub sshcleanup { $cleancmd .= $sshlogin->cleanup_cmd($file,$workdir).";"; } if(defined $opt::workdir and $opt::workdir eq "...") { - $cleancmd .= "$sshcmd $serverlogin -- rm -rf " . ::shell_quote_scalar($workdir).';'; + $cleancmd .= "$sshcmd $serverlogin -- rm -rf " . ::Q($workdir).';'; } return $cleancmd; } -sub remote_cleanup { +sub remote_cleanup($) { # Returns: # Files to remove at cleanup my $self = shift; @@ -8404,7 +8783,20 @@ sub remote_cleanup { } } -sub workdir { +sub exitstatuswrapper(@) { + if($Global::cshell) { + return ('set _EXIT_status=$status; ' . + join(" ",@_). + 'exit $_EXIT_status;'); + } else { + return ('_EXIT_status=$?; ' . + join(" ",@_). + 'exit $_EXIT_status;'); + } +} + + +sub workdir($) { # Returns: # the workdir on a remote machine my $self = shift; @@ -8455,12 +8847,12 @@ sub workdir { } else { $workdir = "."; } - $self->{'workdir'} = ::shell_quote_scalar($workdir); + $self->{'workdir'} = $workdir; } return $self->{'workdir'}; } -sub parentdirs_of { +sub parentdirs_of($) { # Return: # all parentdirs except . of this dir or file - sorted desc by length my $d = shift; @@ -8473,7 +8865,7 @@ sub parentdirs_of { return @parents; } -sub start { +sub start($) { # Setup STDOUT and STDERR for a job and start it. # Returns: # job-object or undef if job not to run @@ -8608,7 +9000,7 @@ sub start { ::set_fh_non_blocking($stdin_fh); } $job->set_fh(0,"w",$stdin_fh); - if($opt::tee) { $job->set_virgin(0); } + if($opt::tee or $opt::shard) { $job->set_virgin(0); } } elsif ($opt::tty and -c "/dev/tty" and open(my $devtty_fh, "<", "/dev/tty")) { # Give /dev/tty to the command if no one else is using it @@ -8652,16 +9044,20 @@ sub start { } } -sub interactive_start { +sub interactive_start($) { my $self = shift; my $command = $self->wrapped(); if($Global::interactive) { + my $answer; ::status_no_nl("$command ?..."); - open(my $tty_fh, "<", "/dev/tty") || ::die_bug("interactive-tty"); - my $answer = <$tty_fh>; - close $tty_fh; - my $run_yes = ($answer =~ /^\s*y/i); - if (not $run_yes) { + do{ + open(my $tty_fh, "<", "/dev/tty") || ::die_bug("interactive-tty"); + $answer = <$tty_fh>; + close $tty_fh; + # Sometime we get an empty string (not even \n) + # Do not know why, so let us just ignore it and try again + } while(length $answer < 1); + if (not ($answer =~ /^\s*y/i)) { $self->{'commandline'}->skip(); } } else { @@ -8672,7 +9068,7 @@ sub interactive_start { { my $tmuxsocket; - sub tmux_wrap { + sub tmux_wrap($) { # Wrap command with tmux for session pPID # Input: # $actual_command = the actual command being run (incl ssh wrap) @@ -8701,7 +9097,7 @@ sub interactive_start { # ; causes problems # ascii 194-245 annoys tmux $title =~ tr/[\011-\016;\302-\365]/ /s; - $title = ::shell_quote_scalar($title); + $title = ::Q($title); my $l_act = length($actual_command); my $l_tit = length($title); @@ -8709,7 +9105,7 @@ sub interactive_start { # The line to run contains a 118 chars extra code + the title 2x my $l_tot = 2 * $l_tit + $l_act + $l_fifo; - my $quoted_space75 = ::shell_quote_scalar(" ")x75; + my $quoted_space75 = ::Q(" ")x75; while($l_tit < 1000 and ( (890 < $l_tot and $l_tot < 1350) @@ -8753,7 +9149,7 @@ sub interactive_start { return "mkfifo $tmpfifo && $tmux ". # Run in tmux - ::shell_quote_scalar + ::Q ( "(".$actual_command.');'. # The triple print is needed - otherwise the testsuite fails @@ -8768,7 +9164,7 @@ sub interactive_start { } } -sub is_already_in_results { +sub is_already_in_results($) { # Do we already have results for this job? # Returns: # $job_already_run = bool whether there is output for this or not @@ -8778,17 +9174,17 @@ sub is_already_in_results { return(-e $out."stdout" or -f $out); } -sub is_already_in_joblog { +sub is_already_in_joblog($) { my $job = shift; return vec($Global::job_already_run,$job->seq(),1); } -sub set_job_in_joblog { +sub set_job_in_joblog($) { my $job = shift; vec($Global::job_already_run,$job->seq(),1) = 1; } -sub should_be_retried { +sub should_be_retried($) { # Should this job be retried? # Returns # 0 - do not retry @@ -8823,7 +9219,7 @@ sub should_be_retried { { my (%print_later,$job_seq_to_print); - sub print_earlier_jobs { + sub print_earlier_jobs($) { # Print jobs whose output is postponed due to --keep-order # Returns: N/A my $job = shift; @@ -8850,7 +9246,7 @@ sub should_be_retried { } } -sub print { +sub print($) { # Print the output of the jobs # Returns: N/A @@ -8904,7 +9300,7 @@ sub print { } flush $out_fd; } - ::debug("print", "<{'exitstatus'} and not ($self->virgin() and $opt::pipe)) { if($Global::joblog and not $opt::sqlworker) { @@ -8925,14 +9321,14 @@ sub print { { my $header_printed; - sub print_csv { + sub print_csv($) { my $self = shift; my $cmd; if($Global::verbose <= 1) { $cmd = $self->replaced(); } else { # Verbose level > 1: Print the rsync and stuff - $cmd = "@command"; + $cmd = join " ", @{$self->{'commandline'}}; } my $record_ref = $self->{'commandline'}{'arg_list_flat_orig'}; @@ -8975,7 +9371,7 @@ sub print { } } -sub combine_ref { +sub combine_ref($) { # Inspired by Text::CSV_PP::_combine (by Makamaka Hannyaharamitu) my @part = @_; my $sep = $Global::csvsep; @@ -9022,7 +9418,7 @@ sub combine_ref { return @out; } -sub print_files { +sub print_files($) { # Print the name of the file containing stdout on stdout # Uses: # $opt::pipe @@ -9063,7 +9459,7 @@ sub print_files { } } -sub print_linebuffer { +sub print_linebuffer($) { my $self = shift; my ($fdno,$in_fh,$out_fd) = @_; if(defined $self->{'exitstatus'}) { @@ -9097,8 +9493,11 @@ sub print_linebuffer { my $outputlength = 0; my $halfline_ref = $self->{'halfline'}{$fdno}; my ($buf,$i,$rv); - while($rv = sysread($in_fh, $buf, 131072)) { + # 1310720 gives 1.2 GB/s + # 131072 gives 0.9 GB/s + while($rv = sysread($in_fh, $buf,1310720)) { $outputlength += $rv; + # TODO --recend # Treat both \n and \r as line end $i = (rindex($buf,"\n")+1) || (rindex($buf,"\r")+1); if($i) { @@ -9106,6 +9505,7 @@ sub print_linebuffer { if($opt::tag or defined $opt::tagstring) { # Replace ^ with $tag within the full line my $tag = $self->tag(); + # TODO --recend that can be partially in @$halfline_ref substr($buf,0,$i-1) =~ s/(?<=[\n\r])/$tag/gm; # The length changed, so find the new ending pos $i = (rindex($buf,"\n")+1) || (rindex($buf,"\r")+1); @@ -9135,7 +9535,11 @@ sub print_linebuffer { # read remaining my $halfline_ref = $self->{'halfline'}{$fdno}; if(grep /./, @$halfline_ref) { - $self->add_returnsize(length join("",@$halfline_ref)); + my $returnsize = 0; + for(@{$self->{'halfline'}{$fdno}}) { + $returnsize += length $_; + } + $self->add_returnsize($returnsize); if($opt::tag or defined $opt::tagstring) { # Prepend $tag the the remaining half line unshift @$halfline_ref, $self->tag(); @@ -9164,7 +9568,7 @@ sub print_linebuffer { } } -sub print_tag { +sub print_tag(@) { return print_normal(@_); } @@ -9178,7 +9582,7 @@ sub free_ressources() { } } -sub print_normal { +sub print_normal($) { my $self = shift; my ($fdno,$in_fh,$out_fd) = @_; my $buf; @@ -9224,14 +9628,14 @@ sub print_normal { } } -sub print_joblog { +sub print_joblog($) { my $self = shift; my $cmd; if($Global::verbose <= 1) { $cmd = $self->replaced(); } else { # Verbose level > 1: Print the rsync and stuff - $cmd = "@command"; + $cmd = join " ", @{$self->{'commandline'}}; } # Newlines make it hard to parse the joblog $cmd =~ s/\n/\0/g; @@ -9245,7 +9649,7 @@ sub print_joblog { $self->set_job_in_joblog(); } -sub tag { +sub tag($) { my $self = shift; if(not defined $self->{'tag'}) { if($opt::tag or defined $opt::tagstring) { @@ -9258,7 +9662,7 @@ sub tag { return $self->{'tag'}; } -sub hostgroups { +sub hostgroups($) { my $self = shift; if(not defined $self->{'hostgroups'}) { $self->{'hostgroups'} = @@ -9267,12 +9671,12 @@ sub hostgroups { return @{$self->{'hostgroups'}}; } -sub exitstatus { +sub exitstatus($) { my $self = shift; return $self->{'exitstatus'}; } -sub set_exitstatus { +sub set_exitstatus($$) { my $self = shift; my $exitstatus = shift; if($exitstatus) { @@ -9288,17 +9692,17 @@ sub set_exitstatus { $exitstatus); } -sub reset_exitstatus { +sub reset_exitstatus($) { my $self = shift; undef $self->{'exitstatus'}; } -sub exitsignal { +sub exitsignal($) { my $self = shift; return $self->{'exitsignal'}; } -sub set_exitsignal { +sub set_exitsignal($$) { my $self = shift; my $exitsignal = shift; $self->{'exitsignal'} = $exitsignal; @@ -9399,7 +9803,7 @@ sub set_exitsignal { package CommandLine; -sub new { +sub new($) { my $class = shift; my $seq = shift; my $commandref = shift; @@ -9434,17 +9838,17 @@ sub new { }, ref($class) || $class; } -sub seq { +sub seq($) { my $self = shift; return $self->{'seq'}; } -sub set_seq { +sub set_seq($$) { my $self = shift; $self->{'seq'} = shift; } -sub slot { +sub slot($) { # Find the number of a free job slot and return it # Uses: # @Global::slots - list with free jobslots @@ -9464,7 +9868,7 @@ sub slot { { my $already_spread; - sub populate { + sub populate($) { # Add arguments from arg_queue until the number of arguments or # max line length is reached # Uses: @@ -9551,7 +9955,7 @@ sub slot { } } -sub push { +sub push($) { # Add one or more records as arguments # Returns: N/A my $self = shift; @@ -9580,7 +9984,7 @@ sub push { } } -sub pop { +sub pop($) { # Remove last argument # Returns: # the last record @@ -9608,7 +10012,7 @@ sub pop { return $record; } -sub pop_all { +sub pop_all($) { # Remove all arguments and zeros the length of replacement perlexpr # Returns: # all records @@ -9623,7 +10027,7 @@ sub pop_all { return @popped; } -sub number_of_args { +sub number_of_args($) { # The number of records # Returns: # number of records @@ -9632,7 +10036,7 @@ sub number_of_args { return $#{$self->{'arg_list'}}+1; } -sub number_of_recargs { +sub number_of_recargs($) { # The number of args in records # Returns: # number of args records @@ -9645,7 +10049,7 @@ sub number_of_recargs { return $sum; } -sub args_as_string { +sub args_as_string($) { # Returns: # all unmodified arguments joined with ' ' (similar to {}) my $self = shift; @@ -9653,7 +10057,7 @@ sub args_as_string { map { @$_ } @{$self->{'arg_list'}}); } -sub results_out { +sub results_out($) { sub max_file_name_length { # Figure out the max length of a subdir # TODO and the max total length @@ -9729,7 +10133,7 @@ sub results_out { return $out; } -sub args_as_dirname { +sub args_as_dirname($) { # Returns: # all unmodified arguments joined with '/' (similar to {}) # \t \0 \\ and / are quoted as: \t \0 \\ \_ @@ -9762,7 +10166,7 @@ sub args_as_dirname { return join "/", @res; } -sub header_indexes_sorted { +sub header_indexes_sorted($) { # Sort headers first by number then by name. # E.g.: 1a 1b 11a 11b # Returns: @@ -9785,9 +10189,9 @@ sub header_indexes_sorted { return @header_indexes_sorted; } -sub len { +sub len($) { # Uses: - # $opt::shellquote + # @opt::shellquote # The length of the command line with args substituted my $self = shift; my $len = 0; @@ -9825,22 +10229,35 @@ sub len { $self->{'replacecount'}{$replstring}; } } + if(defined $Global::parallel_env) { + # If we are using --env, add the prefix for that, too. + $len += length $Global::parallel_env; + } if($Global::quoting) { # Pessimistic length if -q is set - # Worse than worst case: every char needs to be quoted with \ - $len *= 2; + # Worse than worst case: ' => "'" + " => '"' + # TODO can we count the number of expanding chars? + # and count them in arguments, too? + $len *= 3; } - if($opt::shellquote) { + if(@opt::shellquote) { # Pessimistic length if --shellquote is set - # Worse than worst case: every char needs to be quoted with \ twice - $len *= 4; + # Worse than worst case: ' => "'" + for(@opt::shellquote) { + $len *= 3; + } + $len *= 5; } - # If we are using --env, add the prefix for that, too. - $len += 0; + if(@opt::sshlogin) { + # Pessimistic length if remote + # Worst case is BASE64 encoding 3 bytes -> 4 bytes + $len = int($len*4/3); + } + return $len; } -sub replaced { +sub replaced($) { # Uses: # $Global::noquote # $Global::quoting @@ -9867,163 +10284,194 @@ sub replaced { return $self->{'replaced'}; } -{ - my @target; - my $context_replace; - my $perl_expressions_as_re; - my @arg; - my %words_with_rpl_strings; +sub replace_placeholders($$$$) { + # Replace foo{}bar with fooargbar + # Input: + # $targetref = command as shell words + # $quote = should everything be quoted? + # $quote_arg = should replaced arguments be quoted? + # Uses: + # @Arg::arg = arguments as strings to be use in {= =} + # Returns: + # @target with placeholders replaced + my $self = shift; + my $targetref = shift; + my $quote = shift; + my $quote_arg = shift; + my %replace; - sub fish_out_words_with_rpl_strings { - if(not $words_with_rpl_strings{$context_replace,@target}) { - my %word; - for (@target) { - my $tt = $_; - ::debug("replace", "Target: $tt"); - # Command line template: - # a{1}b{}c{}d - # becomes: - # a{=1 $_=$_ =}b{= $_=$_ =}c{= $_=$_ =}d - # becomes: - # a\257<1 $_=$_ \257>b\257< $_=$_ \257>c\257< $_=$_ \257>d - # Input A B C (no context) becomes: - # A B C => aAbA B CcA B Cd - # Input A B C (context -X) becomes: - # A B C => aAbAcAd aAbBcBd aAbCcCd - if($context_replace) { - while($tt =~ s/([^\s\257]* # before {= - (?: - \257< # {= - (?: (?! \257[<>]). )* # The perl expression - \257> # =} - [^\s\257]* # after =} - )+)/ /xs) { - # $1 = pre \257< perlexpr \257> post - $word{"$1"} ||= 1; - } - } else { - while($tt =~ s/( \257<(?: (?! \257[<>]). )*\257> )//xs) { - # $1 = \257< perlexpr \257> - $word{$1} ||= 1; - } - } - } - @{$words_with_rpl_strings{$context_replace,@target}} = keys %word + # Token description: + # \0spc = unquoted space + # \0end = last token element + # \0ign = dummy token to be ignored + # \257<...\257> = replacement expression + # " " = quoted space, that splits -X group + # text = normal text - possibly part of -X group + my $spacer = 0; + my @tokens = grep { length $_ > 0 } map { + if(/^\257<|^ $/) { + # \257<...\257> or space + $_ + } else { + # Split each space/tab into a token + split /(?=\s)|(?<=\s)/ } - return @{$words_with_rpl_strings{$context_replace,@target}}; } + # Split \257< ... \257> into own token + map { split /(?=\257<)|(?<=\257>)/ } + # Insert "\0spc" between every element + # This space should never be quoted + map { $spacer++ ? ("\0spc",$_) : $_ } + map { $_ eq "" ? "\0empty" : $_ } + @$targetref; - sub replace_placeholders { - # Replace foo{}bar with fooargbar - # Uses: - # @Arg::arg = arguments as strings to be use in {= =} - # Input: - # $targetref = command as shell words - # $quote = should everything be quoted? - # $quote_arg = should replaced arguments be quoted? - # Returns: - # @target with placeholders replaced - my $self = shift; - my $targetref = shift; - my $quote = shift; - my $quote_arg = shift; - my %replace; - # -X = context replace (fish_out_words_with_rpl_strings) - $context_replace = $self->{'context_replace'}; - @target = @$targetref; - ::debug("replace", "Replace @target\n"); - if(not @target) { - # @target is empty: Return empty array - return @target; - } - # Make it possible to use $arg[2] in {= =} - *Arg::arg = $self->{'arg_list_flat_orig'}; - # Flat list: - # $self->{'arg_list'} = [ [Arg11, Arg12], [Arg21, Arg22], [Arg31, Arg32] ] - # $self->{'arg_list_flat'} = [ Arg11, Arg12, Arg21, Arg22, Arg31, Arg32 ] - if(not @{$self->{'arg_list_flat'}}) { - @{$self->{'arg_list_flat'}} = Arg->new(""); - } - my $argref = $self->{'arg_list_flat'}; - # Number of arguments - used for positional arguments - my $n = $#$argref+1; + if(not @tokens) { + # @tokens is empty: Return empty array + return @tokens; + } + ::debug("replace", "Tokens ".join":",@tokens,"\n"); + # Make it possible to use $arg[2] in {= =} + *Arg::arg = $self->{'arg_list_flat_orig'}; + # Flat list: + # $self->{'arg_list'} = [ [Arg11, Arg12], [Arg21, Arg22], [Arg31, Arg32] ] + # $self->{'arg_list_flat'} = [ Arg11, Arg12, Arg21, Arg22, Arg31, Arg32 ] + if(not @{$self->{'arg_list_flat'}}) { + @{$self->{'arg_list_flat'}} = Arg->new(""); + } + my $argref = $self->{'arg_list_flat'}; + # Number of arguments - used for positional arguments + my $n = $#$argref+1; - # $self is actually a CommandLine-object, - # but it looks nice to be able to say {= $job->slot() =} - my $job = $self; - $perl_expressions_as_re = - join("|", map {s/^-?\d+//; "\Q$_\E"} keys %{$self->{'replacecount'}}); - # Fish out the words that have replacement strings in them - for my $word (fish_out_words_with_rpl_strings()) { - # word = AB \257< perlexpr \257> CD \257< perlexpr \257> EF - ::debug("replace", "Replacing in $word\n"); - my $normal_replace; - - # for each arg: - # replace replacement strings with replacement in the word value - # push to replace word value - for my $arg (@$argref) { - my $val = $word; - # Replace {= perl expr =} with value for each arg - $val =~ s{\257<(-?\d+)?($perl_expressions_as_re)\257>} - { - if($1) { + # $self is actually a CommandLine-object, + # but it looks nice to be able to say {= $job->slot() =} + my $job = $self; + # @replaced = tokens with \257< \257> replaced + my @replaced; + if($self->{'context_replace'}) { + my @ctxgroup; + for my $t (@tokens,"\0end") { + # \0end = last token was end of tokens. + if($t eq "\t" or $t eq " " or $t eq "\0end" or $t eq "\0spc") { + # Context group complete: Replace in it + if(grep { /^\257} + { + if($1) { # Positional replace # Find the relevant arg and replace it ($argref->[$1 > 0 ? $1-1 : $n+$1] ? # If defined: replace $argref->[$1 > 0 ? $1-1 : $n+$1]-> replace($2,$quote_arg,$self) : ""); - } else { + } else { # Normal replace $normal_replace ||= 1; ($arg ? $arg->replace($2,$quote_arg,$self) : ""); - } - }gxe; - if($quote) { - CORE::push(@{$replace{::shell_quote_scalar($word)}}, - ::shell_quote_scalar($val)); + } + }sgxe; + $a + } @ctxgroup; + $normal_replace or last; + $space = "\0spc"; + } } else { - CORE::push(@{$replace{$word}}, $val); + # Context group has no a replacement string: Copy it once + CORE::push @replaced, @ctxgroup; } - # No normal replacements => only run once - $normal_replace or last; + # New context group + @ctxgroup=(); + } + if($t eq "\0spc" or $t eq " ") { + CORE::push @replaced,$t; + } else { + CORE::push @ctxgroup,$t; } } - *Arg::arg = []; - if($quote) { - @target = ::shell_quote(@target); - } - if(%replace) { - # Substitute the replace strings with the replacement values - # Must be sorted by length if a short word is a substring of a long word - my $regexp = join('|', map { my $s = $_; $s =~ s/(\W)/\\$1/g; $s } - sort { length $b <=> length $a } keys %replace); - for(@target) { - s/($regexp)/join(" ",@{$replace{$1}})/ge; - } - } - if($Global::escape_string_present) { - # Command line contains \257: Unescape it \257\256 => \257 - # If a replacement resulted in \257\256 - # it will have been escaped into \\\257\\\\256 - # and will not be matched below - for(@target) { - s/\257\256/\257/g; - } - if($opt::q) { - # \257 will be quoted too much - for(@target) { - s/\\\257\\\256/\\\257/g; + } else { + # @group = @token + # Replace in group + # Push output + # repquote = no if {} first on line, no if $quote, yes otherwise + for my $t (@tokens) { + if($t =~ /^\257} + { + if($1) { + # Positional replace + # Find the relevant arg and replace it + ($argref->[$1 > 0 ? $1-1 : $n+$1] ? # If defined: replace + $argref->[$1 > 0 ? $1-1 : $n+$1]-> + replace($2,$quote_arg,$self) + : ""); + } else { + # Normal replace + $normal_replace ||= 1; + ($arg ? $arg->replace($2,$quote_arg,$self) : ""); + } + }sgxe; + CORE::push @replaced, $space, $a; + $normal_replace or last; + $space = "\0spc"; } + } else { + # No replacement + CORE::push @replaced, $t; } } - ::debug("replace", "Return @target\n"); - return wantarray ? @target : "@target"; } + *Arg::arg = []; + ::debug("replace","Replaced: ".join":",@replaced,"\n"); + if($Global::escape_string_present) { + # Command line contains \257: Unescape it \257\256 => \257 + # If a replacement resulted in \257\256 + # it will have been escaped into \\\257\\\\256 + # and will not be matched below + for(@replaced) { + s/\257\256/\257/g; + } + } + + # Put tokens into groups that may be quoted. + my @quotegroup; + my @quoted; + for (map { $_ eq "\0empty" ? "" : $_ } + grep { $_ ne "\0ign" and $_ ne "\0noarg" and $_ ne "'\0noarg'" } + @replaced, "\0end") { + if($_ eq "\0spc" or $_ eq "\0end") { + # \0spc splits quotable groups + if($quote) { + if(@quotegroup) { + CORE::push @quoted, ::Q(join"",@quotegroup);; + } + } else { + CORE::push @quoted, join"",@quotegroup; + } + @quotegroup = (); + } else { + CORE::push @quotegroup, $_; + } + } + ::debug("replace","Quoted: ".join":",@quoted,"\n"); + return wantarray ? @quoted : "@quoted"; } -sub skip { +sub skip($) { # Skip this job my $self = shift; $self->{'skip'} = 1; @@ -10032,7 +10480,7 @@ sub skip { package CommandLineQueue; -sub new { +sub new($) { my $class = shift; my $commandref = shift; my $read_from = shift; @@ -10041,10 +10489,9 @@ sub new { my $transfer_files = shift; my $return_files = shift; my @unget = (); - my ($count,$posrpl,$perlexpr); + my $posrpl; my ($replacecount_ref, $len_ref); my @command = @$commandref; - my $dummy = ''; my $seq = 1; # Replace replacement strings with {= perl expr =} # '{=' 'perlexpr' '=}' => '{= perlexpr =}' @@ -10073,7 +10520,7 @@ sub new { # needed to force matching the shortest {= =} ((?:(?! \Q$Global::parensleft\E|\Q$Global::parensright\E ).)*?) \Q$Global::parensright\E ] # Match =} - {\257<$1\257>}gx; + {\257<$1\257>}gxs; for my $rpl (sort { length $b <=> length $a } keys %Global::rpl) { # Replace long --rpl's before short ones, as a short may be a # substring of a long: @@ -10095,7 +10542,7 @@ sub new { /xs; $grp_regexp ||= ''; my $rplval = $Global::rpl{$rpl}; - while(s{( (?: ^|\257> ) (?: (?! \257[<>])(?:.|\n) )*? ) + while(s{( (?: ^|\257> ) (?: [^\257]*|[\257][^<>] )*? ) # Don't replace after \257 unless \257> \Q$prefix\E $grp_regexp \Q$postfix\E} { @@ -10128,7 +10575,7 @@ sub new { # Only do this if the shorthand start with { $prefix=~s/^\{//; # Don't replace after \257 unless \257> - while(s{( (?: ^|\257> ) (?: (?! \257[<>]). )*? ) + while(s{( (?: ^|\257> ) (?: [^\257]*|[\257][^<>] )*? ) \{(-?\d+) \s* \Q$prefix\E $grp_regexp \Q$postfix\E} { # The start remains the same @@ -10189,7 +10636,7 @@ sub new { }, ref($class) || $class; } -sub merge_rpl_parts { +sub merge_rpl_parts($) { # '{=' 'perlexpr' '=}' => '{= perlexpr =}' # Input: # @in = the @command as given by the user @@ -10207,13 +10654,13 @@ sub merge_rpl_parts { my $s = shift @in; $_ = $s; # Remove matching (right most) parens - while(s/(.*)$l.*?$r/$1/o) {} + while(s/(.*)$l.*?$r/$1/os) {} if(/$l/o) { # Missing right parens while(@in) { $s .= " ".shift @in; $_ = $s; - while(s/(.*)$l.*?$r/$1/o) {} + while(s/(.*)$l.*?$r/$1/os) {} if(not /$l/o) { last; } @@ -10224,7 +10671,7 @@ sub merge_rpl_parts { return @out; } -sub replacement_counts_and_lengths { +sub replacement_counts_and_lengths($$@) { # Count the number of different replacement strings. # Find the lengths of context for context groups and non-context # groups. @@ -10248,7 +10695,7 @@ sub replacement_counts_and_lengths { my $noncontextlen = 0; my $contextgroups = 0; for my $c (@cmd) { - while($c =~ s/ \257<( (?: (?! \257[<>]). )*?)\257> /\000/xs) { + while($c =~ s/ \257<( (?: [^\257]*|[\257][^<>] )*?)\257> /\000/xs) { # %replacecount = { "perlexpr" => number of times seen } # e.g { "s/a/b/" => 2 } $replacecount{$1}++; @@ -10271,7 +10718,7 @@ sub replacement_counts_and_lengths { # Options that can contain replacement strings $_ or next; my $t = $_; - while($t =~ s/ \257<( (?: (?! \257[<>]). )* )\257> //xs) { + while($t =~ s/ \257<( (?: [^\257]*|[\257][^<>] )* )\257> //xs) { # %replacecount = { "perlexpr" => number of times seen } # e.g { "$_++" => 2 } # But for tagstring we just need to mark it as seen @@ -10308,7 +10755,7 @@ sub replacement_counts_and_lengths { return(\%replacecount,\%len,@command); } -sub get { +sub get($) { my $self = shift; if(@{$self->{'unget'}}) { my $cmd_line = shift @{$self->{'unget'}}; @@ -10355,43 +10802,39 @@ sub get { "(e.g. 'cat')."); ::wait_and_exit(255); } - } else { - if($cmd_line->number_of_args() == 0) { - # We did not get more args - maybe at EOF string? - return undef; - } elsif($cmd_line->replaced() eq "") { - # Empty command - get the next instead - return $self->get(); - } + } elsif($cmd_line->number_of_args() == 0) { + # We did not get more args - maybe at EOF string? + return undef; } $self->set_seq($self->seq()+1); return $cmd_line; } } -sub unget { +sub unget($) { my $self = shift; unshift @{$self->{'unget'}}, @_; } -sub empty { +sub empty($) { my $self = shift; - my $empty = (not @{$self->{'unget'}}) && $self->{'arg_queue'}->empty(); + my $empty = (not @{$self->{'unget'}}) && + $self->{'arg_queue'}->empty(); ::debug("run", "CommandLineQueue->empty $empty"); return $empty; } -sub seq { +sub seq($) { my $self = shift; return $self->{'seq'}; } -sub set_seq { +sub set_seq($$) { my $self = shift; $self->{'seq'} = shift; } -sub quote_args { +sub quote_args($) { my $self = shift; # If there is not command emulate |bash return $self->{'command'}; @@ -10401,7 +10844,7 @@ sub quote_args { package Limits::Command; # Maximal command line length (for -m and -X) -sub max_length { +sub max_length($) { # Find the max_length of a command line and cache it # Returns: # number of chars on the longest command line allowed @@ -10435,7 +10878,7 @@ sub max_length { return int($Limits::Command::line_max_len); } -sub real_max_length { +sub real_max_length($) { # Find the max_length of a command line # Returns: # The maximal command line length @@ -10450,7 +10893,9 @@ sub real_max_length { return binary_find_max_length(int($len/16),$len); } -sub binary_find_max_length { +# Prototype forwarding +sub binary_find_max_length($$); +sub binary_find_max_length($$) { # Given a lower and upper bound find the max_length of a command line # Returns: # number of chars on the longest command line allowed @@ -10465,22 +10910,22 @@ sub binary_find_max_length { } } -sub is_acceptable_command_line_length { +sub is_acceptable_command_line_length($) { # Test if a command line of this length can run # in the current environment # Returns: # 0 if the command line length is too long # 1 otherwise my $len = shift; - if($ENV{PARALLEL_ENV}) { - $len += length $ENV{PARALLEL_ENV} + (-s $ENV{PARALLEL_ENV})*2; + if($Global::parallel_env) { + $len += length $Global::parallel_env; } ::qqx("true "."x"x$len); ::debug("init", "$len=$? "); return not $?; } -sub tmux_length { +sub tmux_length($) { # If $opt::tmux set, find the limit for tmux # tmux 1.8 has a 2kB limit # tmux 1.9 has a 16kB limit @@ -10523,7 +10968,7 @@ sub tmux_length { package RecordQueue; -sub new { +sub new($) { my $class = shift; my $fhs = shift; my $colsep = shift; @@ -10546,7 +10991,7 @@ sub new { }, ref($class) || $class; } -sub get { +sub get($) { # Returns: # reference to array of Arg-objects my $self = shift; @@ -10563,17 +11008,23 @@ sub get { my $ret = $self->{'arg_sub_queue'}->get(); if($ret) { if(grep { index($_->orig(),"\0") > 0 } @$ret) { - # Allow for \0 in position 0 because GNU Parallel uses "\0" + # Allow for \0 in position 0 because GNU Parallel uses "\0noarg" # to mean no-string - ::warning("a NUL character occurred in the input.", - "It cannot be passed through in the argument list.", + ::warning("A NUL character in the input was replaced with \\0.", + "NUL cannot be passed through in the argument list.", "Did you mean to use the --null option?"); + for(grep { index($_->orig(),"\0") > 0 } @$ret) { + # Replace \0 with \\0 + my $a = $_->orig(); + $a =~ s/\0/\\0/g; + $_->set_orig($a); + } } if(defined $Global::max_number_of_args and $Global::max_number_of_args == 0) { ::debug("run", "Read 1 but return 0 args\n"); - # \0 => nothing (not the empty string) - map { $_->set_orig("\0"); } @$ret; + # \0noarg => nothing (not the empty string) + map { $_->set_orig("\0noarg"); } @$ret; } # Flush cached computed replacements in Arg-objects # To fix: parallel --bar echo {%} ::: a b c ::: d e f @@ -10582,22 +11033,22 @@ sub get { return $ret; } -sub unget { +sub unget($) { my $self = shift; - ::debug("run", "RecordQueue-unget '@_'\n"); + ::debug("run", "RecordQueue-unget\n"); $self->{'arg_number'} -= @_; unshift @{$self->{'unget'}}, @_; } -sub empty { +sub empty($) { my $self = shift; - my $empty = not @{$self->{'unget'}}; - $empty &&= $self->{'arg_sub_queue'}->empty(); + my $empty = (not @{$self->{'unget'}}) && + $self->{'arg_sub_queue'}->empty(); ::debug("run", "RecordQueue->empty $empty"); return $empty; } -sub arg_number { +sub arg_number($) { my $self = shift; return $self->{'arg_number'}; } @@ -10605,7 +11056,7 @@ sub arg_number { package RecordColQueue; -sub new { +sub new($) { my $class = shift; my $fhs = shift; my @unget = (); @@ -10616,7 +11067,7 @@ sub new { }, ref($class) || $class; } -sub get { +sub get($) { # Returns: # reference to array of Arg-objects my $self = shift; @@ -10659,16 +11110,16 @@ sub get { } } -sub unget { +sub unget($) { my $self = shift; ::debug("run", "RecordColQueue-unget '@_'\n"); unshift @{$self->{'unget'}}, @_; } -sub empty { +sub empty($) { my $self = shift; - my $empty = (not @{$self->{'unget'}} and - $self->{'arg_sub_queue'}->empty()); + my $empty = (not @{$self->{'unget'}}) && + $self->{'arg_sub_queue'}->empty(); ::debug("run", "RecordColQueue->empty $empty"); return $empty; } @@ -10676,7 +11127,7 @@ sub empty { package SQLRecordQueue; -sub new { +sub new($) { my $class = shift; my @unget = (); return bless { @@ -10684,7 +11135,7 @@ sub new { }, ref($class) || $class; } -sub get { +sub get($) { # Returns: # reference to array of Arg-objects my $self = shift; @@ -10694,13 +11145,13 @@ sub get { return $Global::sql->get_record(); } -sub unget { +sub unget($) { my $self = shift; ::debug("run", "SQLRecordQueue-unget '@_'\n"); unshift @{$self->{'unget'}}, @_; } -sub empty { +sub empty($) { my $self = shift; if(@{$self->{'unget'}}) { return 0; } my $get = $self->get(); @@ -10717,14 +11168,14 @@ package MultifileQueue; @Global::unget_argv=(); -sub new { +sub new($$) { my $class = shift; my $fhs = shift; for my $fh (@$fhs) { if(-t $fh and -t ($Global::status_fd || *STDERR)) { - ::warning("Input is read from the terminal. You either know what you", - "are doing (in which case: YOU ARE AWESOME!) or you forgot", - "::: or :::: or to pipe data into parallel. If so", + ::warning("Input is read from the terminal. You are either an expert", + "(in which case: YOU ARE AWESOME!) or maybe you forgot", + "::: or :::: or -a or to pipe data into parallel. If so", "consider going through the tutorial: man parallel_tutorial", "Press CTRL-D to exit."); } @@ -10736,7 +11187,7 @@ sub new { }, ref($class) || $class; } -sub get { +sub get($) { my $self = shift; if($opt::link) { return $self->link_get(); @@ -10745,16 +11196,16 @@ sub get { } } -sub unget { +sub unget($) { my $self = shift; ::debug("run", "MultifileQueue-unget '@_'\n"); unshift @{$self->{'unget'}}, @_; } -sub empty { +sub empty($) { my $self = shift; - my $empty = (not @Global::unget_argv - and not @{$self->{'unget'}}); + my $empty = (not @Global::unget_argv) && + not @{$self->{'unget'}}; for my $fh (@{$self->{'fhs'}}) { $empty &&= eof($fh); } @@ -10762,7 +11213,7 @@ sub empty { return $empty; } -sub link_get { +sub link_get($) { my $self = shift; if(@{$self->{'unget'}}) { return shift @{$self->{'unget'}}; @@ -10792,7 +11243,7 @@ sub link_get { } } -sub nest_get { +sub nest_get($) { my $self = shift; if(@{$self->{'unget'}}) { return shift @{$self->{'unget'}}; @@ -10874,7 +11325,7 @@ sub nest_get { return shift @{$self->{'unget'}}; } -sub read_arg_from_fh { +sub read_arg_from_fh($) { # Read one Arg from filehandle # Returns: # Arg-object with one read line @@ -10947,7 +11398,9 @@ sub read_arg_from_fh { } } -sub expand_combinations { +# Prototype forwarding +sub expand_combinations(@); +sub expand_combinations(@) { # Input: # ([xmin,xmax], [ymin,ymax], ...) # Returns: ([x,y,...],[x,y,...]) @@ -10981,7 +11434,7 @@ sub expand_combinations { package Arg; -sub new { +sub new($) { my $class = shift; my $orig = shift; my @hostgroups; @@ -11012,41 +11465,40 @@ sub new { }, ref($class) || $class; } -sub Q { +sub Q($) { # Q alias for ::shell_quote_scalar - # Run shell_quote_scalar once to set the reference to the sub - my $a = ::shell_quote_scalar(@_); + no warnings 'redefine'; *Q = \&::shell_quote_scalar; - return $a; + return Q(@_); } -sub pQ { +sub pQ($) { # pQ alias for ::perl_quote_scalar *pQ = \&::perl_quote_scalar; return pQ(@_); } -sub total_jobs { +sub total_jobs() { return $Global::JobQueue->total_jobs(); } { my %perleval; my $job; - sub skip { + sub skip() { # shorthand for $job->skip(); $job->skip(); } - sub slot { + sub slot() { # shorthand for $job->slot(); $job->slot(); } - sub seq { + sub seq() { # shorthand for $job->seq(); $job->seq(); } - sub replace { + sub replace($$$$) { # Calculates the corresponding value for a given perl expression # Returns: # The calculated string (quoted if asked for) @@ -11086,28 +11538,28 @@ sub total_jobs { $self->{'cache'}{$perlexpr} = $_; } # Return the value quoted if needed - return($quote ? ::shell_quote_scalar($self->{'cache'}{$perlexpr}) + return($quote ? Q($self->{'cache'}{$perlexpr}) : $self->{'cache'}{$perlexpr}); } } -sub flush_cache { +sub flush_cache($) { # Flush cache of computed values my $self = shift; $self->{'cache'} = undef; } -sub orig { +sub orig($) { my $self = shift; return $self->{'orig'}; } -sub set_orig { +sub set_orig($$) { my $self = shift; $self->{'orig'} = shift; } -sub trim_of { +sub trim_of($) { # Removes white space as specifed by --trim: # n = nothing # l = start @@ -11135,7 +11587,7 @@ sub trim_of { package TimeoutQueue; -sub new { +sub new($) { my $class = shift; my $delta_time = shift; my ($pct); @@ -11156,22 +11608,22 @@ sub new { }, ref($class) || $class; } -sub delta_time { +sub delta_time($) { my $self = shift; return $self->{'delta_time'}; } -sub set_delta_time { +sub set_delta_time($$) { my $self = shift; $self->{'delta_time'} = shift; } -sub remedian { +sub remedian($) { my $self = shift; return $self->{'remedian'}; } -sub set_remedian { +sub set_remedian($$) { # Set median of the last 999^3 (=997002999) values using Remedian # # Rousseeuw, Peter J., and Gilbert W. Bassett Jr. "The remedian: A @@ -11187,7 +11639,7 @@ sub set_remedian { $self->{'remedian'} = (sort @{$rref->[2]})[$#{$rref->[2]}/2]; } -sub update_median_runtime { +sub update_median_runtime($) { # Update delta_time based on runtime of finished job if timeout is # a percentage my $self = shift; @@ -11199,7 +11651,7 @@ sub update_median_runtime { } } -sub process_timeouts { +sub process_timeouts($) { # Check if there was a timeout my $self = shift; # $self->{'queue'} is sorted by start time @@ -11223,7 +11675,7 @@ sub process_timeouts { } } -sub insert { +sub insert($) { my $self = shift; my $in = shift; push @{$self->{'queue'}}, $in; @@ -11232,7 +11684,7 @@ sub insert { package SQL; -sub new { +sub new($) { my $class = shift; my $dburl = shift; $Global::use{"DBI"} ||= eval "use DBI; 1;"; @@ -11278,7 +11730,9 @@ sub new { }, ref($class) || $class; } -sub get_alias { +# Prototype forwarding +sub get_alias($); +sub get_alias($) { my $alias = shift; $alias =~ s/^(sql:)*//; # Accept aliases prepended with sql: if ($alias !~ /^:/) { @@ -11338,7 +11792,7 @@ sub get_alias { } } -sub check_permissions { +sub check_permissions($) { my $file = shift; if(-e $file) { @@ -11357,12 +11811,12 @@ sub check_permissions { } } -sub parse_dburl { +sub parse_dburl($) { my $url = shift; my %options = (); # sql:mysql://[[user][:password]@][host][:port]/[database[/table][?query]] - if($url=~m!(?:sql:)? # You can prefix with 'sql:' + if($url=~m!^(?:sql:)? # You can prefix with 'sql:' ((?:oracle|ora|mysql|pg|postgres|postgresql)(?:s|ssl|)| (?:sqlite|sqlite2|sqlite3|csv)):// # Databasedriver ($1) (?: @@ -11388,7 +11842,7 @@ sub parse_dburl { \? (.*)? # Query ($8) )? - !ix) { + $!ix) { $options{databasedriver} = ::undef_if_empty(lc(uri_unescape($1))); $options{user} = ::undef_if_empty(uri_unescape($2)); $options{password} = ::undef_if_empty(uri_unescape($3)); @@ -11410,7 +11864,7 @@ sub parse_dburl { return %options; } -sub uri_unescape { +sub uri_unescape($) { # Copied from http://cpansearch.perl.org/src/GAAS/URI-1.55/URI/Escape.pm # to avoid depending on URI::Escape # This section is (C) Gisle Aas. @@ -11430,7 +11884,7 @@ sub uri_unescape { $str; } -sub run { +sub run($) { my $self = shift; my $stmt = shift; if($self->{'driver'} eq "CSV") { @@ -11487,7 +11941,7 @@ sub run { return $sth; } -sub get { +sub get($) { my $self = shift; my $sth = $self->run(@_); my @retval; @@ -11500,24 +11954,24 @@ sub get { return \@retval; } -sub table { +sub table($) { my $self = shift; return $self->{'table'}; } -sub append { +sub append($) { my $self = shift; return $self->{'append'}; } -sub update { +sub update($) { my $self = shift; my $stmt = shift; my $table = $self->table(); $self->run("UPDATE $table $stmt",@_); } -sub output { +sub output($) { my $self = shift; my $commandline = shift; @@ -11527,7 +11981,7 @@ sub output { join("",@{$commandline->{'output'}{2}})); } -sub max_number_of_args { +sub max_number_of_args($) { # Maximal number of args for this table my $self = shift; if(not $self->{'max_number_of_args'}) { @@ -11545,12 +11999,12 @@ sub max_number_of_args { return $self->{'max_number_of_args'}; } -sub set_max_number_of_args { +sub set_max_number_of_args($$) { my $self = shift; $self->{'max_number_of_args'} = shift; } -sub create_table { +sub create_table($) { my $self = shift; if($self->append()) { return; } my $max_number_of_args = shift; @@ -11584,7 +12038,7 @@ sub create_table { Stderr $TEXT);}); } -sub insert_records { +sub insert_records($) { my $self = shift; my $seq = shift; my $command_ref = shift; @@ -11592,20 +12046,20 @@ sub insert_records { my $table = $self->table(); # For SQL encode the command with \257 space as split points my $command = join("\257 ",@$command_ref); - my $v_cols = join ",", map { "V$_" } (1..$self->max_number_of_args()); + my @v_cols = map { ", V$_" } (1..$self->max_number_of_args()); # Two extra value due to $seq, Exitval, Send my $v_vals = join ",", map { "?" } (1..$self->max_number_of_args()+4); - $self->run("INSERT INTO $table (Seq,Command,Exitval,Send,$v_cols) ". + $self->run("INSERT INTO $table (Seq,Command,Exitval,Send @v_cols) ". "VALUES ($v_vals);", $seq, $command, -1000, 0, @$record_ref[1..$#$record_ref]); } -sub get_record { +sub get_record($) { my $self = shift; my @retval; my $table = $self->table(); - my $v_cols = join ",", map { "V$_" } (1..$self->max_number_of_args()); - my $v = $self->get("SELECT Seq, Command, $v_cols FROM $table ". + my @v_cols = map { ", V$_" } (1..$self->max_number_of_args()); + my $v = $self->get("SELECT Seq, Command @v_cols FROM $table ". "WHERE Exitval = -1000 ORDER BY Seq LIMIT 1;"); if($v->[0]) { my $val_ref = $v->[0]; @@ -11627,7 +12081,7 @@ sub get_record { } } -sub total_jobs { +sub total_jobs($) { my $self = shift; my $table = $self->table(); my $v = $self->get("SELECT count(*) FROM $table;"); @@ -11638,7 +12092,7 @@ sub total_jobs { } } -sub max_seq { +sub max_seq($) { my $self = shift; my $table = $self->table(); my $v = $self->get("SELECT max(Seq) FROM $table;"); @@ -11649,7 +12103,7 @@ sub max_seq { } } -sub finished { +sub finished($) { # Check if there are any jobs left in the SQL table that do not # have a "real" exitval my $self = shift; @@ -11675,7 +12129,7 @@ package Semaphore; # process holding the entry. If the process dies, the entry can be # taken by another process. -sub new { +sub new($) { my $class = shift; my $id = shift; my $count = shift; @@ -11699,7 +12153,7 @@ sub new { }, ref($class) || $class; } -sub remove_dead_locks { +sub remove_dead_locks($) { my $self = shift; my $lockdir = $self->{'lockdir'}; @@ -11717,7 +12171,7 @@ sub remove_dead_locks { } } -sub acquire { +sub acquire($) { my $self = shift; my $sleep = 1; # 1 ms my $start_time = time; @@ -11756,7 +12210,7 @@ sub acquire { ::debug("sem", "acquired $self->{'pid'}\n"); } -sub release { +sub release($) { my $self = shift; ::rm($self->{'pidfile'}); if($self->nlinks() == 1) { @@ -11771,7 +12225,7 @@ sub release { ::debug("run", "released $self->{'pid'}\n"); } -sub pid_change { +sub pid_change($) { # This should do what release()+acquire() would do without having # to re-acquire the semaphore my $self = shift; @@ -11784,7 +12238,7 @@ sub pid_change { ::rm($old_pidfile); } -sub atomic_link_if_count_less_than { +sub atomic_link_if_count_less_than($) { # Link $file1 to $file2 if nlinks to $file1 < $count my $self = shift; my $retval = 0; @@ -11806,7 +12260,7 @@ sub atomic_link_if_count_less_than { return $retval; } -sub nlinks { +sub nlinks($) { my $self = shift; if(-e $self->{'idfile'}) { return (stat(_))[3]; @@ -11815,7 +12269,7 @@ sub nlinks { } } -sub lock { +sub lock($) { my $self = shift; my $sleep = 100; # 100 ms my $total_sleep = 0; @@ -11878,7 +12332,7 @@ sub lock { ::debug("run", "locked $self->{'lockfile'}"); } -sub unlock { +sub unlock($) { my $self = shift; ::rm($self->{'lockfile'}); close $self->{'lockfh'}; @@ -11890,3 +12344,128 @@ sub unlock { $opt::x = $Semaphore::timeout = $Semaphore::wait = $Job::file_descriptor_warning_printed = $Global::envdef = @Arg::arg = $Global::max_slot_number = $opt::session; + +package main; + +sub main() { + save_stdin_stdout_stderr(); + save_original_signal_handler(); + parse_options(); + ::debug("init", "Open file descriptors: ", join(" ",keys %Global::fd), "\n"); + my $number_of_args; + if($Global::max_number_of_args) { + $number_of_args = $Global::max_number_of_args; + } elsif ($opt::X or $opt::m or $opt::xargs) { + $number_of_args = undef; + } else { + $number_of_args = 1; + } + + my @command = @ARGV; + my @input_source_fh; + if($opt::pipepart) { + if($opt::tee) { + @input_source_fh = map { open_or_exit($_) } @opt::a; + # Remove the first: It will be the file piped. + shift @input_source_fh; + if(not @input_source_fh and not $opt::pipe) { + @input_source_fh = (*STDIN); + } + } else { + # -a is used for data - not for command line args + @input_source_fh = map { open_or_exit($_) } "/dev/null"; + } + } else { + @input_source_fh = map { open_or_exit($_) } @opt::a; + if(not @input_source_fh and not $opt::pipe) { + @input_source_fh = (*STDIN); + } + } + if($opt::sqlmaster) { + # Create SQL table to hold joblog + output + $Global::sql->create_table($#input_source_fh+1); + if($opt::sqlworker) { + # Start a real --sqlworker in the background later + $Global::start_sqlworker = 1; + $opt::sqlworker = undef; + } + } + + if($opt::skip_first_line) { + # Skip the first line for the first file handle + my $fh = $input_source_fh[0]; + <$fh>; + } + + set_input_source_header(\@command,\@input_source_fh); + + if($opt::filter_hosts and (@opt::sshlogin or @opt::sshloginfile)) { + # Parallel check all hosts are up. Remove hosts that are down + filter_hosts(); + } + + if($opt::nonall or $opt::onall) { + onall(\@input_source_fh,@command); + wait_and_exit(min(undef_as_zero($Global::exitstatus),254)); + } + + $Global::JobQueue = JobQueue->new( + \@command,\@input_source_fh,$Global::ContextReplace, + $number_of_args,\@Global::transfer_files,\@Global::ret_files); + + if($opt::pipepart) { + pipepart_setup(); + } elsif($opt::pipe and $opt::tee) { + pipe_tee_setup(); + } elsif($opt::pipe and $opt::shard) { + pipe_shard_setup(); + } + + if($opt::eta or $opt::bar or $opt::shuf or $Global::halt_pct) { + # Count the number of jobs or shuffle all jobs + # before starting any. + # Must be done after ungetting any --pipepart jobs. + $Global::JobQueue->total_jobs(); + } + # Compute $Global::max_jobs_running + # Must be done after ungetting any --pipepart jobs. + max_jobs_running(); + + init_run_jobs(); + my $sem; + if($Global::semaphore) { + $sem = acquire_semaphore(); + } + $SIG{TERM} = $Global::original_sig{TERM}; + $SIG{HUP} = \&start_no_new_jobs; + + if($opt::tee or $opt::shard) { + # All jobs must be running in parallel for --tee/--shard + while(start_more_jobs()) {} + $Global::start_no_new_jobs = 1; + if(not $Global::JobQueue->empty()) { + ::error("--tee requres --jobs to be higher. Try --jobs 0."); + ::wait_and_exit(255); + } + } elsif($opt::pipe and not $opt::pipepart) { + # Fill all jobslots + while(start_more_jobs()) {} + spreadstdin(); + } else { + # Reap one - start one + while(reaper() + start_more_jobs()) {} + } + ::debug("init", "Start draining\n"); + drain_job_queue(@command); + ::debug("init", "Done draining\n"); + reapers(); + ::debug("init", "Done reaping\n"); + if($Global::semaphore) { + $sem->release(); + } + cleanup(); + ::debug("init", "Halt\n"); + halt(); +} + +main(); diff --git a/README.md b/README.md index b82dc84..c8f36e3 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ Support is planned for two other operations: * Generate specs from audio files supported by sox * Rename folders based on the tags of the audio files inside -* **⇩ [Download Minat 0.1.5](http://www.profiteroles.org/downloads/Minat_0.1.5.zip)** +* **⇩ [Download Minat 0.1.6](http://www.profiteroles.org/downloads/Minat_0.1.6.zip)** ## Screenshot diff --git a/bin/keys b/bin/.DS_Store old mode 100755 new mode 100644 similarity index 62% rename from bin/keys rename to bin/.DS_Store index 0b854ba..5008ddf Binary files a/bin/keys and b/bin/.DS_Store differ diff --git a/test b/test deleted file mode 100644 index e69de29..0000000 diff --git a/version.txt b/version.txt index fa71c37..a192233 100755 --- a/version.txt +++ b/version.txt @@ -1 +1 @@ -0.1.5.3 \ No newline at end of file +0.1.6 \ No newline at end of file