From 4fd40781fe3edc4ae5895e3cfddfbfea328ac0e8 Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Fri, 19 Apr 2024 11:43:15 +0200 Subject: Adding upstream version 20240222+ds. Signed-off-by: Daniel Baumann --- src/sem | 15425 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 15425 insertions(+) create mode 100755 src/sem (limited to 'src/sem') diff --git a/src/sem b/src/sem new file mode 100755 index 0000000..e45fcf0 --- /dev/null +++ b/src/sem @@ -0,0 +1,15425 @@ +#!/usr/bin/env perl + +# Copyright (C) 2007-2024 Ole Tange, http://ole.tange.dk 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 +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see +# or write to the Free Software Foundation, Inc., 51 Franklin St, +# Fifth Floor, Boston, MA 02110-1301 USA +# +# SPDX-FileCopyrightText: 2007-2024 Ole Tange, http://ole.tange.dk and Free Software and Foundation, Inc. +# SPDX-License-Identifier: GPL-3.0-or-later + +# open3 used in Job::start +use IPC::Open3; +use POSIX; +# gensym used in Job::start +use Symbol qw(gensym); +# tempfile used in Job::start +use File::Temp qw(tempfile tempdir); +# mkpath used in openresultsfile +use File::Path; +# GetOptions used in get_options_from_array +use Getopt::Long; +# Used to ensure code quality +use strict; +use File::Basename; + +sub set_input_source_header($$) { + my ($command_ref,$input_source_fh_ref) = @_; + if(defined $opt::header and not $opt::pipe) { + # split with colsep or \t + # $header force $colsep = \t if undef? + my $delimiter = defined $opt::colsep ? $opt::colsep : "\t"; + # regexp for {= + my $left = "\Q$Global::parensleft\E"; + my $l = $Global::parensleft; + # regexp for =} + my $right = "\Q$Global::parensright\E"; + my $r = $Global::parensright; + if($opt::header ne "0") { + my $id = 1; + for my $fh (@$input_source_fh_ref) { + my $line = <$fh>; + chomp($line); + $line =~ s/\r$//; + ::debug("init", "Delimiter: '$delimiter'"); + for my $s (split /$delimiter/o, $line) { + ::debug("init", "Colname: '$s'"); + # Replace {colname} with {2} + for(@$command_ref, @Global::ret_files, + @Global::transfer_files, $opt::tagstring, + $opt::workdir, $opt::results, $opt::retries, + @Global::template_contents, @Global::template_names, + @opt::filter) { + # Skip if undefined + $_ or next; + s:\{$s(|/|//|\.|/\.)\}:\{$id$1\}:g; + # {=header1 ... =} => {=1 ... =} + s:$left $s (.*?) $right:$l$id$1$r:gx; + } + $Global::input_source_header{$id} = $s; + $id++; + } + } + } + # Make it possible to do: + # parallel --header 0 echo {file2} {file1} :::: file1 file2 + my $id = 1; + for my $s (@opt::a) { + # ::: are put into files and given a filehandle + # ignore these and only keep the filenames. + fileno $s and next; + for(@$command_ref, @Global::ret_files, + @Global::transfer_files, $opt::tagstring, + $opt::workdir, $opt::results, $opt::retries, + @Global::template_contents, @Global::template_names, + @opt::filter) { + # Skip if undefined + $_ or next; + s:\{\Q$s\E(|/|//|\.|/\.)\}:\{$id$1\}:g; + # {=header1 ... =} => {=1 ... =} + s:$left \Q$s\E (.*?) $right:$l$id$1$r:gx; + } + $Global::input_source_header{$id} = $s; + $id++; + } + } else { + my $id = 1; + for my $fh (@$input_source_fh_ref) { + $Global::input_source_header{$id} = $id; + $id++; + } + } +} + +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(255,"Cannot run any jobs."); + } + return $Global::max_jobs_running; +} + +sub halt() { + # Compute exit value, + # wait for children to complete + # and exit + if($opt::halt and $Global::halt_when ne "never") { + if(not defined $Global::halt_exitstatus) { + if($Global::halt_pct) { + $Global::halt_exitstatus = + ::ceil($Global::total_failed / + ($Global::total_started || 1) * 100); + } elsif($Global::halt_count) { + $Global::halt_exitstatus = + ::min(undef_as_zero($Global::total_failed),101); + } + } + wait_and_exit($Global::halt_exitstatus); + } else { + if($Global::semaphore) { + # --semaphore runs a single job: + # Use exit value of that + wait_and_exit($Global::halt_exitstatus); + } else { + # 0 = all jobs succeeded + # 1-100 = n jobs failed + # 101 = >100 jobs failed + wait_and_exit(min(undef_as_zero($Global::exitstatus),101)); + } + } +} + + +sub __PIPE_MODE__() {} + + +sub pipepart_setup() { + # Compute the blocksize + # Generate the commands to extract the blocks + # Push the commands on queue + # Changes: + # @Global::cat_prepends + # $Global::JobQueue + if($opt::tee) { + # Prepend each command with + # < file + my $cat_string = "< ".Q($opt::a[0]); + for(1..$Global::JobQueue->total_jobs()) { + push @Global::cat_appends, $cat_string; + push @Global::cat_prepends, ""; + } + } else { + if(not $opt::blocksize) { + # --blocksize with 10 jobs per jobslot + $opt::blocksize = -10; + } + if($opt::roundrobin) { + # --blocksize with 1 job per jobslot + $opt::blocksize = -1; + } + if($opt::blocksize < 0) { + my $size = 0; + # Compute size of -a + for(@opt::a) { + if(-f $_) { + $size += -s $_; + } elsif(-b $_) { + $size += size_of_block_dev($_); + } elsif(-e $_) { + ::error(255,"$_ is neither a file nor a block device"); + } else { + ::error(255,"File not found: $_"); + } + } + # Run in total $job_slots*(- $blocksize) jobs + # Set --blocksize = size / no of proc / (- $blocksize) + $Global::dummy_jobs = 1; + $Global::blocksize = 1 + + int($size / max_jobs_running() / + -multiply_binary_prefix($opt::blocksize)); + } + @Global::cat_prepends = (map { pipe_part_files($_) } + # ::: are put into files and given a filehandle + # ignore these and only keep the filenames. + grep { ! fileno $_ } @opt::a); + # Unget the empty arg as many times as there are parts + $Global::JobQueue->{'commandlinequeue'}{'arg_queue'}->unget( + map { [Arg->new("\0noarg")] } @Global::cat_prepends + ); + } +} + +sub pipe_tee_setup() { + # Create temporary fifos + # Run 'tee 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 @fifos; + for(1..$Global::JobQueue->total_jobs()) { + push @fifos, tmpfifo(); + } + # cat foo | tee fifo1 fifo2 fifo3 fifo4 fifo5 > /dev/null + if(not fork()){ + # Test if tee supports --output-error=warn-nopipe + `echo | tee --output-error=warn-nopipe /dev/null >/dev/null 2>/dev/null`; + my $opt = $? ? "" : "--output-error=warn-nopipe"; + ::debug("init","tee $opt"); + if($opt::dryrun) { + # This is not exactly what is run, but it gives the basic idea + print "mkfifo @fifos\n"; + print "tee $opt @fifos >/dev/null &\n"; + } else { + # Let tee inherit our stdin + # and redirect stdout to null + open STDOUT, ">","/dev/null"; + if($opt) { + exec "tee", $opt, @fifos; + } else { + exec "tee", @fifos; + } + } + exit(0); + } + # For each fifo + # (rm fifo1; grep 1) < fifo1 + # (rm fifo2; grep 2) < fifo2 + # (rm fifo3; grep 3) < fifo3 + # Remove the tmpfifo as soon as it is open + @Global::cat_prepends = map { "(rm $_;" } shell_quote(@fifos); + @Global::cat_appends = map { ") < $_" } shell_quote(@fifos); +} + + +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}}) { + # TODO test if 60800 is optimal (2^17 is used elsewhere) + $rv = sysread($infh, $buf, 60800); + 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; + # Perl expression + my $perlexpr = shift; + 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 $_; + } + if($perlexpr) { + my $subref = eval("sub { no strict; no warnings; $perlexpr }"); + while() { + # Split into $col columns (no need to split into more) + @F = split $sep, $_, $col+1; + { + local $_ = $F[$col0]; + &$subref(); + $fh = $fh{ hex(B::hash($_))%$bins }; + } + print $fh $_; + } + } else { + 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 binner_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; + # Perl expression + my $perlexpr = shift; + my $bins = @ARGV; + # Open fifos for writing, fh{0..$bins} + my $t = 0; + my %fh; + # Let the last output fifo be the 0'th + open $fh{$t++}, ">", pop @ARGV; + for(@ARGV) { + open $fh{$t++}, ">", $_; + # open blocks until it is opened by reader + # so unlink only happens when it is ready + unlink $_; + } + if($perlexpr) { + my $subref = eval("sub { no strict; no warnings; $perlexpr }"); + while() { + # Split into $col columns (no need to split into more) + @F = split $sep, $_, $col+1; + { + local $_ = $F[$col0]; + &$subref(); + $fh = $fh{ $_%$bins }; + } + print $fh $_; + } + } else { + while() { + # Split into $col columns (no need to split into more) + @F = split $sep, $_, $col+1; + $fh = $fh{ $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 arguments + max_jobs_running(); + my $njobs = $Global::max_jobs_running; + 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 $shardbin = ($opt::shard || $opt::bin); + my $script; + if($opt::bin) { + $script = binner_script(); + } else { + $script = sharder_script(); + } + + # cat foo | sharder sep col fifo1 fifo2 fifo3 ... fifoN + + if($shardbin =~ /^[a-z_][a-z_0-9]*(\s|$)/i) { + # Group by column name + # (Yes, this will also wrongly match a perlexpr like: chop) + my($read,$char,@line); + # A full line, but nothing more (the rest must be read by the child) + # $Global::header used to prepend block to each job + do { + $read = sysread(STDIN,$char,1); + push @line, $char; + } while($read and $char ne "\n"); + $Global::header = join "", @line; + } + my ($col, $perlexpr, $subref) = + column_perlexpr($shardbin, $Global::header, $opt::colsep); + 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 -0 --block 100k -q --pipe -j), $njobs, + qw(--roundrobin -u perl -e), $script, ($opt::colsep || ","), + $col, $perlexpr, '{}', (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(255,"'parcat' must be in path."); + } + @Global::cat_prepends = + map { "perl -e $parcat ". + join(" ",shell_quote(@$_))." | "} @parcatfifos; +} + +sub pipe_part_files(@) { + # Given the bigfile: + # - find header and split positions + # - make commands that 'cat's the partial file + # Input: + # $file = the file to read + # Returns: + # @commands that will cat_partial each part + my ($file) = @_; + my $buf = ""; + if(not -f $file and not -b $file) { + ::error(255,"--pipepart only works on seekable files, not streams/pipes.", + "$file is not a seekable file."); + } + + my $fh = open_or_exit("<",$file); + my $firstlinelen = 0; + if($opt::skip_first_line) { + my $newline; + # Read a full line one byte at a time + while($firstlinelen += sysread($fh,$newline,1,0)) { + $newline eq "\n" and last; + } + } + my $header = find_header(\$buf,$fh); + # find positions + my @pos = find_split_positions($file,int($Global::blocksize), + $header,$firstlinelen); + # Make @cat_prepends + my @cat_prepends = (); + for(my $i=0; $i<$#pos; $i++) { + push(@cat_prepends, + cat_partial($file, $firstlinelen, $firstlinelen+length($header), + $pos[$i], $pos[$i+1])); + } + return @cat_prepends; +} + +sub find_header($$) { + # Compute the header based on $opt::header + # Input: + # $buf_ref = reference to read-in buffer + # $fh = filehandle to read from + # Uses: + # $opt::header + # $Global::blocksize + # $Global::header + # Returns: + # $header string + my ($buf_ref, $fh) = @_; + my $header = ""; + # $Global::header may be set in group_by_loop() + if($Global::header) { return $Global::header } + if($opt::header) { + if($opt::header eq ":") { $opt::header = "(.*\n)"; } + # Number = number of lines + $opt::header =~ s/^(\d+)$/"(.*\n)"x$1/e; + while(sysread($fh,$$buf_ref,int($Global::blocksize),length $$buf_ref)) { + if($$buf_ref =~ s/^($opt::header)//) { + $header = $1; + last; + } + } + } + return $header; +} + +sub find_split_positions($$$) { + # Find positions in bigfile where recend is followed by recstart + # Input: + # $file = the file to read + # $block = (minimal) --block-size of each chunk + # $header = header to be skipped + # Uses: + # $opt::recstart + # $opt::recend + # Returns: + # @positions of block start/end + my($file, $block, $header, $firstlinelen) = @_; + my $skiplen = $firstlinelen + length $header; + my $size = -s $file; + if(-b $file) { + # $file is a blockdevice + $size = size_of_block_dev($file); + } + $block = int $block; + if($opt::groupby) { + return split_positions_for_group_by($file,$size,$block, + $header,$firstlinelen); + } + # The optimal dd blocksize for mint, redhat, solaris, openbsd = 2^17..2^20 + # The optimal dd blocksize for freebsd = 2^15..2^17 + # The optimal dd blocksize for ubuntu (AMD6376) = 2^16 + my $dd_block_size = 131072; # 2^17 + my @pos; + my ($recstart,$recend) = recstartrecend(); + my $recendrecstart = $recend.$recstart; + my $fh = ::open_or_exit("<",$file); + push(@pos,$skiplen); + for(my $pos = $block+$skiplen; $pos < $size; $pos += $block) { + my $buf; + if($recendrecstart eq "") { + # records ends anywhere + push(@pos,$pos); + } else { + # Seek the the block start + if(not sysseek($fh, $pos, 0)) { + ::error("Cannot seek to $pos in $file"); + edit(255); + } + while(sysread($fh,$buf,$dd_block_size,length $buf)) { + if($opt::regexp) { + # If match /$recend$recstart/ => Record position + if($buf =~ m:^(.*$recend)$recstart:os) { + # Start looking for next record _after_ this match + $pos += length($1); + push(@pos,$pos); + last; + } + } else { + # If match $recend$recstart => Record position + # TODO optimize to only look at the appended + # $dd_block_size + len $recendrecstart + # TODO increase $dd_block_size to optimize for longer records + my $i = index64(\$buf,$recendrecstart); + if($i != -1) { + # Start looking for next record _after_ this match + $pos += $i + length($recend); + push(@pos,$pos); + last; + } + } + } + } + } + if($pos[$#pos] != $size) { + # Last splitpoint was not at end of the file: add $size as the last + push @pos, $size; + } + close $fh; + return @pos; +} + +sub split_positions_for_group_by($$$$) { + my($fh); + my %value; + sub value_at($) { + my $pos = shift; + if(not defined $value{$pos}) { + if($pos != 0) { + seek($fh, $pos-1, 0) || die; + # Read half line + <$fh>; + } + # Read full line + my $linepos = tell($fh); + if(not defined $value{$linepos}) { + $_ = <$fh>; + if(defined $_) { + # Not end of file + my @F; + if(defined $group_by::col) { + $opt::colsep ||= "\t"; + @F = split /$opt::colsep/, $_; + $_ = $F[$group_by::col]; + } + eval $group_by::perlexpr; + } + $value{$linepos} = [$_,$linepos]; + } + $value{$pos} = $value{$linepos}; + } + return (@{$value{$pos}}); + } + + sub binary_search_end($$$) { + my ($s,$spos,$epos) = @_; + # value_at($spos) == $s + # value_at($epos) != $s + my $posdif = $epos - $spos; + my ($v,$vpos); + while($posdif) { + ($v,$vpos) = value_at($spos+$posdif); + if($v eq $s) { + $spos = $vpos; + $posdif = $epos - $spos; + } else { + $epos = $vpos; + } + $posdif = int($posdif/2); + } + return($v,$vpos); + } + + sub binary_search_start($$$) { + my ($s,$spos,$epos) = @_; + # value_at($spos) != $s + # value_at($epos) == $s + my $posdif = $epos - $spos; + my ($v,$vpos); + while($posdif) { + ($v,$vpos) = value_at($spos+$posdif); + if($v eq $s) { + $epos = $vpos; + } else { + $spos = $vpos; + $posdif = $epos - $spos; + } + $posdif = int($posdif/2); + } + return($v,$vpos); + } + + my ($file,$size,$block,$header,$firstlinelen) = @_; + my @pos; + $fh = open_or_exit("<",$file); + # Set $Global::group_by_column $Global::group_by_perlexpr + group_by_loop($fh,$opt::recsep); + if($opt::max_args) { + # Split after n values + my ($a,$apos); + # $xpos = linestart, $x = value at $xpos + $apos = $firstlinelen + length $header; + for(($a,$apos) = value_at($apos); $apos < $size;) { + push @pos, $apos; + ($a,$apos) = binary_search_end($a,$apos,$size); + if(eof($fh)) { + push @pos, $size; last; + } + } + # @pos = start of every value + # Merge n values + # -nX = keep every X'th position + my $i = 0; + @pos = grep { not ($i++ % $opt::max_args) } @pos; + } else { + # Split after any value group + # Preferable < $blocksize + my ($a,$b,$c,$apos,$bpos,$cpos); + # $xpos = linestart, $x = value at $xpos, $apos < $bpos < $cpos + $apos = $firstlinelen + length $header; + for(($a,$apos) = value_at($apos); $apos < $size;) { + push @pos, $apos; + $bpos = $apos + $block; + ($b,$bpos) = value_at($bpos); + if(eof($fh)) { + # EOF is less than 1 block away + push @pos, $size; last; + } + $cpos = $bpos + $block; + ($c,$cpos) = value_at($cpos); + if($a eq $b) { + while($b eq $c) { + # Move bpos, cpos a block forward until $a == $b != $c + $bpos = $cpos; + $cpos += $block; + ($c,$cpos) = value_at($cpos); + if($cpos >= $size) { + $cpos = $size; + last; + } + } + # $a == $b != $c + # Binary search for $b ending between ($bpos,$cpos) + ($b,$bpos) = binary_search_end($b,$bpos,$cpos); + } else { + if($b eq $c) { + # $a != $b == $c + # Binary search for $b starting between ($apos,$bpos) + ($b,$bpos) = binary_search_start($b,$apos,$bpos); + } else { + # $a != $b != $c + # Binary search for $b ending between ($bpos,$cpos) + ($b,$bpos) = binary_search_end($b,$bpos,$cpos); + } + } + ($a,$apos) = ($b,$bpos); + } + } + if($pos[$#pos] != $size) { + # Last splitpoint was not at end of the file: add it + push @pos, $size; + } + return @pos; +} + +sub cat_partial($@) { + # Efficient command to copy from byte X to byte Y + # Input: + # $file = the file to read + # ($start, $end, [$start2, $end2, ...]) = start byte, end byte + # Returns: + # Efficient command to copy $start..$end, $start2..$end2, ... to stdout + my($file, @start_end) = @_; + my($start, $i); + # Convert (start,end) to (start,len) + my @start_len = map { + if(++$i % 2) { $start = $_; } else { $_-$start } + } @start_end; + # The optimal block size differs + # It has been measured on: + # AMD 6376: n*4k-1; small n + # AMD Neo N36L: 44k-200k + # Intel i7-3632QM: 55k- + # ARM Cortex A53: 4k-28k + # Intel i5-2410M: 36k-46k + # + # I choose 2^15-1 = 32767 + # q{ + # expseq() { + # perl -E ' + # $last = pop @ARGV; + # $first = shift || 1; + # $inc = shift || 1.03; + # for($i=$first; $i<=$last;$i*=$inc) { say int $i } + # ' "$@" + # } + # + # seq 111111111 > big; + # f() { ppar --test $1 -a big --pipepart --block -1 'md5sum > /dev/null'; } + # export -f f; + # expseq 1000 1.001 300000 | shuf | parallel -j1 --jl jl-md5sum f; + # }; + my $script = spacefree + (0, + q{ + while(@ARGV) { + sysseek(STDIN,shift,0) || die; + $left = shift; + while($read = + sysread(STDIN,$buf, $left > 32767 ? 32767 : $left)){ + $left -= $read; + syswrite(STDOUT,$buf); + } + } + }); + return "<". Q($file) . + " perl -e '$script' @start_len |"; +} + +sub column_perlexpr($$$) { + # Compute the column number (if any), perlexpression from combined + # string (such as --shard key, --groupby key, {=n perlexpr=} + # Input: + # $column_perlexpr = string with column and perl expression + # $header = header from input file (if column is column name) + # $colsep = column separator regexp + # Returns: + # $col = column number + # $perlexpr = perl expression + # $subref = compiled perl expression as sub reference + my ($column_perlexpr, $header, $colsep) = @_; + my ($col, $perlexpr, $subref); + if($column_perlexpr =~ /^[-a-z0-9_]+(\s|$)/i) { + # Column name/number (possibly prefix) + if($column_perlexpr =~ s/^(-?\d+)(\s|$)//) { + # Column number (possibly prefix) + $col = $1; + } elsif($column_perlexpr =~ s/^([a-z0-9_]+)(\s+|$)//i) { + # Column name (possibly prefix) + my $colname = $1; + # Split on --copsep pattern + my @headers = split /$colsep/, $header; + my %headers; + @headers{@headers} = (1..($#headers+1)); + $col = $headers{$colname}; + if(not defined $col) { + ::error(255,"Column '$colname' $colsep not found in header",keys %headers); + } + } + } + # What is left of $column_perlexpr is $perlexpr (possibly empty) + $perlexpr = $column_perlexpr; + $subref = eval("sub { no strict; no warnings; $perlexpr }"); + return($col, $perlexpr, $subref); +} + +sub group_by_loop($$) { + # Generate perl code for group-by loop + # Insert a $recsep when the column value changes + # The column value can be computed with $perlexpr + my($fh,$recsep) = @_; + my $groupby = $opt::groupby; + if($groupby =~ /^[a-z_][a-z_0-9]*(\s|$)/i) { + # Group by column name + # (Yes, this will also wrongly match a perlexpr like: chop) + my($read,$char,@line); + # Read a full line, but nothing more + # (the rest must be read by the child) + # $Global::header used to prepend block to each job + do { + $read = sysread($fh,$char,1); + push @line, $char; + } while($read and $char ne "\n"); + $Global::header = join "", @line; + } + $opt::colsep ||= "\t"; + ($group_by::col, $group_by::perlexpr, $group_by::subref) = + column_perlexpr($groupby, $Global::header, $opt::colsep); + # Numbered 0..n-1 due to being used by $F[n] + if($group_by::col) { $group_by::col--; } + + my $loop = ::spacefree(0,q{ + BEGIN{ $last = "RECSEP"; } + { + local $_=COLVALUE; + PERLEXPR; + if(($last) ne $_) { + print "RECSEP"; + $last = $_; + } + } + }); + if(defined $group_by::col) { + $loop =~ s/COLVALUE/\$F[$group_by::col]/g; + } else { + $loop =~ s/COLVALUE/\$_/g; + } + $loop =~ s/PERLEXPR/$group_by::perlexpr/g; + $loop =~ s/RECSEP/$recsep/g; + return $loop; +} + +sub pipe_group_by_setup() { + # Record separator with 119 bit random value + $opt::recend = ''; + $opt::recstart = + join "", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..20); + $opt::remove_rec_sep = 1; + my @filter; + push @filter, "perl"; + if($opt::groupby =~ /^[a-z0-9_]+(\s|$)/i) { + # This is column number/name + # Use -a (auto-split) + push @filter, "-a"; + $opt::colsep ||= "\t"; + my $sep = $opt::colsep; + $sep =~ s/\t/\\t/g; + $sep =~ s/\"/\\"/g; + # man perlrun: -Fpattern [...] You can't use literal whitespace + $sep =~ s/ /\\040/g; + push @filter, "-F$sep"; + } + push @filter, "-pe"; + push @filter, group_by_loop(*STDIN,$opt::recstart); + ::debug("init", "@filter\n"); + open(STDIN, '-|', @filter) || die ("Cannot start @filter"); + if(which("mbuffer")) { + # You get a speed up of 30% by going through mbuffer + open(STDIN, '-|', "mbuffer", "-q","-m6M","-b5") || + die ("Cannot start mbuffer"); + } +} + +sub spreadstdin() { + # read a record + # Spawn a job and print the record to it. + # Uses: + # $Global::blocksize + # STDIN + # $opt::r + # $Global::max_lines + # $Global::max_number_of_args + # $opt::regexp + # $Global::start_no_new_jobs + # $opt::roundrobin + # %Global::running + # Returns: N/A + + my $buf = ""; + my ($recstart,$recend) = recstartrecend(); + my $recendrecstart = $recend.$recstart; + my $chunk_number = 1; + my $one_time_through; + my $two_gb = 2**31-1; + my $blocksize = int($Global::blocksize); + my $in = *STDIN; + my $timeout = $Global::blocktimeout; + + if($opt::skip_first_line) { + my $newline; + # Read a full line one byte at a time + while(sysread($in,$newline,1,0)) { + $newline eq "\n" and last; + } + } + my $header = find_header(\$buf,$in); + my $anything_written; + my $eof; + my $garbage_read; + + sub read_block() { + # Read a --blocksize from STDIN + # possibly interrupted by --blocktimeout + # Add up to the next full block + my $readsize = $blocksize - (length $buf) % $blocksize; + my ($nread,$alarm); + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required + # --blocktimeout (or 0 if not set) + alarm $timeout; + if($] >= 5.026) { + do { + $nread = sysread $in, $buf, $readsize, length $buf; + $readsize -= $nread; + } while($readsize and $nread); + } else { + # Less efficient reading, but 32-bit sysread compatible + do { + $nread = sysread($in,substr($buf,length $buf,0),$readsize,0); + $readsize -= $nread; + } while($readsize and $nread); + } + alarm 0; + }; + if ($@) { + die unless $@ eq "alarm\n"; # propagate unexpected errors + $alarm = 1; + } else { + $alarm = 0; + } + $eof = not ($nread or $alarm); + } + + sub pass_n_line_records() { + # Pass records of N lines + my $n_lines = $buf =~ tr/\n/\n/; + my $last_newline_pos = rindex64(\$buf,"\n"); + # Go backwards until there are full n-line records + while($n_lines % $Global::max_lines) { + $n_lines--; + $last_newline_pos = rindex64(\$buf,"\n",$last_newline_pos-1); + } + # Chop at $last_newline_pos as that is where n-line record ends + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,$last_newline_pos+1); + shorten(\$buf,$last_newline_pos+1); + } + + sub pass_n_regexps() { + # Pass records of N regexps + # -N => (start..*?end){n} + # -L -N => (start..*?end){n*l} + if(not $garbage_read) { + $garbage_read = 1; + if($buf !~ /^$recstart/o) { + # Buf does not start with $recstart => There is garbage. + # Make a single record of the garbage + if($buf =~ + /(?s:^)( + (?:(?:(?!$recend$recstart)(?s:.))*?$recend) + ) + # Followed by recstart + (?=$recstart)/mox and length $1 > 0) { + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,length $1); + shorten(\$buf,length $1); + } + } + } + + my $n_records = + $Global::max_number_of_args * ($Global::max_lines || 1); + # (?!negative lookahead) is needed to avoid backtracking + # See: https://unix.stackexchange.com/questions/439356/ + # (?s:.) = (.|[\n]) but faster + while($buf =~ + /(?s:^)( + # n more times recstart.*recend + (?:$recstart(?:(?!$recend$recstart)(?s:.))*?$recend){$n_records} + ) + # Followed by recstart + (?=$recstart)/mox and length $1 > 0) { + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,length $1); + shorten(\$buf,length $1); + } + } + + sub pass_regexp() { + # Find the last recend-recstart in $buf + $eof and return; + # (?s:.) = (.|[\n]) but faster + if($buf =~ /^((?s:.)*$recend)$recstart(?s:.)*?$/mox) { + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,length $1); + shorten(\$buf,length $1); + } + } + + sub pass_csv_record() { + # Pass CVS record + # We define a CSV record as an even number of " + end of line + # This works if you use " as quoting character + my $last_newline_pos = length $buf; + # Go backwards from the last \n and search for a position + # where there is an even number of " + do { + # find last EOL + $last_newline_pos = rindex64(\$buf,"\n",$last_newline_pos-1); + # While uneven " + } while((substr($buf,0,$last_newline_pos) =~ y/"/"/)%2 + and $last_newline_pos >= 0); + # Chop at $last_newline_pos as that is where CSV record ends + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,$last_newline_pos+1); + shorten(\$buf,$last_newline_pos+1); + } + + sub pass_n() { + # Pass n records of --recend/--recstart + # -N => (start..*?end){n} + 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 + and + length $buf) { + $i += length $recend; # find the actual splitting location + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,$i); + shorten(\$buf,$i); + } + } + + sub pass() { + # Pass records of --recend/--recstart + # Split record at fixed string + # Find the last recend+recstart in $buf + $eof and return; + my $i = rindex64(\$buf,$recendrecstart); + if($i != -1) { + $i += length $recend; # find the actual splitting location + $anything_written += + write_record_to_pipe($chunk_number++,\$header,\$buf, + $recstart,$recend,$i); + shorten(\$buf,$i); + } + } + + sub increase_blocksize_maybe() { + if(not $anything_written + and not $opt::blocktimeout + and not $Global::no_autoexpand_block) { + # Nothing was written - maybe the block size < record size? + # Increase blocksize exponentially up to 2GB-1 (2GB causes problems) + if($blocksize < $two_gb) { + my $old_blocksize = $blocksize; + $blocksize = ::min(ceil($blocksize * 1.3 + 1), $two_gb); + ::warning("A record was longer than $old_blocksize. " . + "Increasing to --blocksize $blocksize."); + } + } + } + + while(1) { + $anything_written = 0; + read_block(); + if($opt::r) { + # Remove empty lines + $buf =~ s/^\s*\n//gm; + if(length $buf == 0) { + if($eof) { + last; + } else { + next; + } + } + } + if($Global::max_lines and not $Global::max_number_of_args) { + # Pass n-line records + pass_n_line_records(); + } elsif($opt::csv) { + # Pass a full CSV record + pass_csv_record(); + } elsif($opt::regexp) { + # Split record at regexp + if($Global::max_number_of_args) { + pass_n_regexps(); + } else { + pass_regexp(); + } + } else { + # Pass normal --recend/--recstart record + if($Global::max_number_of_args) { + pass_n(); + } else { + pass(); + } + } + $eof and last; + increase_blocksize_maybe(); + ::debug("init", "Round\n"); + } + ::debug("init", "Done reading input\n"); + + # If there is anything left in the buffer write it + write_record_to_pipe($chunk_number++, \$header, \$buf, $recstart, + $recend, length $buf); + + if($opt::retries) { + $Global::no_more_input = 1; + # We need to start no more jobs: At most we need to retry some + # of the already running. + my @running = values %Global::running; + # Stop any virgins. + for my $job (@running) { + if(defined $job and $job->virgin()) { + close $job->fh(0,"w"); + } + } + # Wait for running jobs to be done + my $sleep = 1; + while($Global::total_running > 0) { + $sleep = ::reap_usleep($sleep); + start_more_jobs(); + } + } + $Global::start_no_new_jobs ||= 1; + if($opt::roundrobin) { + # Flush blocks to roundrobin procs + my $sleep = 1; + while(%Global::running) { + my $something_written = 0; + for my $job (values %Global::running) { + if($job->block_length()) { + $something_written += $job->non_blocking_write(); + } else { + close $job->fh(0,"w"); + } + } + if($something_written) { + $sleep = $sleep/2+0.001; + } + $sleep = ::reap_usleep($sleep); + } + } +} + +sub recstartrecend() { + # Uses: + # $opt::recstart + # $opt::recend + # Returns: + # $recstart,$recend with default values and regexp conversion + my($recstart,$recend); + if(defined($opt::recstart) and defined($opt::recend)) { + # If both --recstart and --recend is given then both must match + $recstart = $opt::recstart; + $recend = $opt::recend; + } elsif(defined($opt::recstart)) { + # If --recstart is given it must match start of record + $recstart = $opt::recstart; + $recend = ""; + } elsif(defined($opt::recend)) { + # If --recend is given then it must match end of record + $recstart = ""; + $recend = $opt::recend; + if($opt::regexp and $recend eq '') { + # --regexp --recend '' + $recend = '(?s:.)'; + } + } + + if($opt::regexp) { + # Do not allow /x comments - to avoid having to quote space + $recstart = "(?-x:".$recstart.")"; + $recend = "(?-x:".$recend.")"; + # If $recstart/$recend contains '|' + # the | should only apply to the regexp + $recstart = "(?:".$recstart.")"; + $recend = "(?:".$recend.")"; + } else { + # $recstart/$recend = printf strings (\n) + $recstart =~ s/\\([0rnt\'\"\\])/"qq|\\$1|"/gee; + $recend =~ s/\\([0rnt\'\"\\])/"qq|\\$1|"/gee; + } + return ($recstart,$recend); +} + +sub nindex($$) { + # See if string is in buffer N times + # Returns: + # the position where the Nth copy is found + my ($buf_ref, $str, $n) = @_; + my $i = 0; + for(1..$n) { + $i = index64($buf_ref,$str,$i+1); + if($i == -1) { last } + } + return $i; +} + +{ + my @robin_queue; + my $sleep = 1; + + sub round_robin_write($$$$$) { + # Input: + # $header_ref = ref to $header string + # $block_ref = ref to $block to be written + # $recstart = record start string + # $recend = record end string + # $endpos = end position of $block + # Uses: + # %Global::running + # Returns: + # $something_written = amount of bytes written + my ($header_ref,$buffer_ref,$recstart,$recend,$endpos) = @_; + my $written = 0; + my $block_passed = 0; + while(not $block_passed) { + # Continue flushing existing buffers + # until one is empty and a new block is passed + if(@robin_queue) { + # Rotate queue once so new blocks get a fair chance + # to be given to another slot + push @robin_queue, shift @robin_queue; + } else { + # Make a queue to spread the blocks evenly + push @robin_queue, (sort { $a->seq() <=> $b->seq() } + values %Global::running); + } + 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; + $written += $job->non_blocking_write(); + last; + } + } + 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($$$) { + # Do index on strings > 2GB. + # index in Perl < v5.22 does not work for > 2GB + # Input: + # as index except STR which must be passed as a reference + # Output: + # as index + my $ref = shift; + my $match = shift; + my $pos = shift || 0; + my $max2gb = 2**31-1; + my $strlen = length($$ref); + # No point in doing extra work if we don't need to. + if($strlen < $max2gb or $] > 5.022) { + return index($$ref, $match, $pos); + } + + my $matchlen = length($match); + my $ret; + my $offset = $pos; + while($offset < $strlen) { + $ret = index( + substr($$ref, $offset, $max2gb), + $match, $pos-$offset); + if($ret != -1) { + return $ret + $offset; + } + $offset += ($max2gb - $matchlen - 1); + } + return -1; +} + +sub rindex64($@) { + # Do rindex on strings > 2GB. + # rindex in Perl < v5.22 does not work for > 2GB + # Input: + # as rindex except STR which must be passed as a reference + # Output: + # as rindex + my $ref = shift; + my $match = shift; + my $pos = shift; + my $block_size = 2**31-1; + my $strlen = length($$ref); + # Default: search from end + $pos = defined $pos ? $pos : $strlen; + # No point in doing extra work if we don't need to. + if($strlen < $block_size or $] > 5.022) { + return rindex($$ref, $match, $pos); + } + + my $matchlen = length($match); + my $ret; + my $offset = $pos - $block_size + $matchlen; + if($offset < 0) { + # The offset is less than a $block_size + # Set the $offset to 0 and + # Adjust block_size accordingly + $block_size = $block_size + $offset; + $offset = 0; + } + while($offset >= 0) { + $ret = rindex( + substr($$ref, $offset, $block_size), + $match); + if($ret != -1) { + return $ret + $offset; + } + $offset -= ($block_size - $matchlen - 1); + } + return -1; +} + +sub shorten($$) { + # Do: substr($buf,0,$i) = ""; + # Some Perl versions do not support $i > 2GB, so do this in 2GB chunks + # Input: + # $buf_ref = \$buf + # $i = position to shorten to + # Returns: N/A + my ($buf_ref, $i) = @_; + my $two_gb = 2**31-1; + while($i > $two_gb) { + substr($$buf_ref,0,$two_gb) = ""; + $i -= $two_gb; + } + substr($$buf_ref,0,$i) = ""; +} + +sub write_record_to_pipe($$$$$$) { + # Fork then + # Write record from pos 0 .. $endpos to pipe + # Input: + # $chunk_number = sequence number - to see if already run + # $header_ref = reference to header string to prepend + # $buffer_ref = reference to record to write + # $recstart = start string of record + # $recend = end string of record + # $endpos = position in $buffer_ref where record ends + # Uses: + # $Global::job_already_run + # $opt::roundrobin + # @Global::virgin_jobs + # Returns: + # Number of chunks written (0 or 1) + 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); + } + # If no virgin found, backoff + my $sleep = 0.0001; # 0.01 ms - better performance on highend + while(not @Global::virgin_jobs) { + ::debug("pipe", "No virgin jobs"); + $sleep = ::reap_usleep($sleep); + # Jobs may not be started because of loadavg + # or too little time between each ssh login + # or retrying failed jobs. + start_more_jobs(); + } + my $job = shift @Global::virgin_jobs; + $job->set_block($header_ref, $buffer_ref, $endpos, $recstart, $recend); + $job->write_block(); + return 1; +} + + +sub __SEM_MODE__() {} + + +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()); + $sem->acquire(); + if($Semaphore::fg) { + # skip + } else { + if(fork()) { + exit(0); + } else { + # If run in the background, the PID will change + $sem->pid_change(); + } + } + return $sem; +} + + +sub __PARSE_OPTIONS__() {} + +sub shell_completion() { + if($opt::shellcompletion eq "zsh") { + # if shell == zsh + zsh_competion(); + } elsif($opt::shellcompletion eq "bash") { + # if shell == bash + bash_competion(); + } elsif($opt::shellcompletion eq "auto") { + if($Global::shell =~ m:/zsh$|^zsh$:) { + # if shell == zsh + zsh_competion(); + } elsif($Global::shell =~ m:/bash$|^bash$:) { + # if shell == bash + bash_competion(); + } else { + ::error(255,"--shellcompletion is not implemented for ". + "'$Global::shell'."); + } + } else { + ::error(255,"--shellcompletion is not implemented for ". + "'$opt::shellcompletion'."); + } +} + +sub bash_competion() { + # Print: + # complete -F _comp_parallel parallel; + # _comp_parallel() { + # COMPREPLY=($(compgen -W "--options" -- + # "${COMP_WORDS[$COMP_CWORD]}")); + # }; + my @bash_completion = + ("complete -F _comp_parallel parallel;", + '_comp_parallel() { COMPREPLY=($(compgen -W "'); + my @och = options_completion_hash(); + while(@och) { + $_ = shift @och; + # Split input like: + # "joblog|jl=s[Logfile for executed jobs]:logfile:_files" + if(/^(.*?)(\[.*?])?(:[^:]*)?(:.*)?$/) { + my $opt = $1; + my $desc = $2; + my $argdesc = $3; + my $func = $4; + # opt=s => opt + $opt =~ s/[:=].$//; + if($opt =~ /^_/) { + # internal options start with --_ + # skip + } else { + push @bash_completion, + (map { (length $_ == 1) ? "-$_ " : "--$_ " } + split /\|/, $opt); + } + } + shift @och; + } + push @bash_completion,'" -- "${COMP_WORDS[$COMP_CWORD]}")); };'."\n"; + print @bash_completion; +} + +sub zsh_competion() { + # Print code used for completion in zsh + my @zsh_completion = + ("compdef _comp_parallel parallel; ", + "setopt localoptions extended_glob; ", + "_comp_parallel() { ", + "_arguments "); + my @och = options_completion_hash(); + while(@och) { + $_ = shift @och; + # Split input like: + # "joblog|jl=s[Logfile for executed jobs]:logfile:_files" + if(/^(.*?)(\[.*?])?(:[^:]*)?(:.*)?$/) { + my $opt = $1; + my $desc = $2; + my $argdesc = $3; + my $func = $4; + # opt=s => opt + $opt =~ s/[:=].$//; + if($opt =~ /^_/) { + # internal options start with --_ + # skip + } else { + # {-o,--option} + my $zsh_opt = join(",", + (map { (length $_ == 1) ? "-$_" : "--$_" } + split /\|/, $opt)); + if($zsh_opt =~ /,/) { $zsh_opt = "{$zsh_opt}"; } + $desc =~ s/'/'"'"'/g; + $argdesc =~ s/'/'"'"'/g; + $func =~ s/'/'"'"'/g; + push @zsh_completion, $zsh_opt."'".$desc.$argdesc.$func."' "; + } + } + shift @och; + } + push @zsh_completion, + q{'(-)1:command:{_command_names -e}' }, + q{'*::arguments:_normal'}, + "};\n"; + print @zsh_completion; +} + +sub options_hash() { + # Returns: + # %hash = for GetOptions + my %och = options_completion_hash(); + my %oh; + my ($k,$v); + while(($k,$v) = each %och) { + # Remove description + $k =~ s/\[.*//; + $oh{$k} = $v; + } + return %oh; +} + +sub options_completion_hash() { + # Returns: + # %hash = for GetOptions and shell completion + return + ("debug|D=s" => \$opt::D, + "xargs[Insert as many arguments as the command line length permits]" + => \$opt::xargs, + "m[Multiple arguments]" => \$opt::m, + ("X[Insert as many arguments with context as the command line ". + "length permits]" + => \$opt::X), + "v[Verbose]" => \@opt::v, + "sql=s[Use --sql-master instead (obsolete)]:DBURL" => \$opt::retired, + ("sql-master|sqlmaster=s". + "[Submit jobs via SQL server. DBURL must point to a table, which ". + "will contain --joblog, the values, and output]:DBURL" + => \$opt::sqlmaster), + ("sql-worker|sqlworker=s". + "[Execute jobs via SQL server. Read the input sources variables ". + "from the table pointed to by DBURL.]:DBURL" + => \$opt::sqlworker), + ("sql-and-worker|sqlandworker=s". + "[--sql-master DBURL --sql-worker DBURL]:DBURL" + => \$opt::sqlandworker), + ("joblog|jl=s[Logfile for executed jobs]:logfile:_files" + => \$opt::joblog), + ("results|result|res=s[Save the output into files]:name:_files" + => \$opt::results), + "resume[Resumes from the last unfinished job]" => \$opt::resume, + ("resume-failed|resumefailed". + "[Retry all failed and resume from the last unfinished job]" + => \$opt::resume_failed), + ("retry-failed|retryfailed[Retry all failed jobs in joblog]" + => \$opt::retry_failed), + "silent[Silent]" => \$opt::silent, + ("keep-order|keeporder|k". + "[Keep sequence of output same as the order of input]" + => \$opt::keeporder), + ("no-keep-order|nokeeporder|nok|no-k". + "[Overrides an earlier --keep-order (e.g. if set in ". + "~/.parallel/config)]" + => \$opt::nokeeporder), + "group[Group output]" => \$opt::group, + "g" => \$opt::retired, + ("ungroup|u". + "[Output is printed as soon as possible and bypasses GNU parallel ". + "internal processing]" + => \$opt::ungroup), + ("latest-line|latestline|ll". + "[Print latest line of each job]" + => \$opt::latestline), + ("line-buffer|line-buffered|linebuffer|linebuffered|lb". + "[Buffer output on line basis]" + => \$opt::linebuffer), + ("tmux". + "[Use tmux for output. Start a tmux session and run each job in a ". + "window in that session. No other output will be produced]" + => \$opt::tmux), + ("tmux-pane|tmuxpane". + "[Use tmux for output but put output into panes in the first ". + "window. Useful if you want to monitor the progress of less than ". + "100 concurrent jobs]" + => \$opt::tmuxpane), + "null|0[Use NUL as delimiter]" => \$opt::null, + "quote|q[Quote command]" => \$opt::quote, + # Replacement strings + ("parens=s[Use parensstring instead of {==}]:parensstring" + => \$opt::parens), + ('rpl=s[Define replacement string]:"tag perl expression"' + => \@opt::rpl), + "plus[Add more replacement strings]" => \$opt::plus, + ("I=s". + "[Use the replacement string replace-str instead of {}]:replace-str" + => \$opt::I), + ("extensionreplace|er=s". + "[Use the replacement string replace-str instead of {.} for input ". + "line without extension]:replace-str" + => \$opt::U), + "U=s" => \$opt::retired, + ("basenamereplace|bnr=s". + "[Use the replacement string replace-str instead of {/} for ". + "basename of input line]:replace-str" + => \$opt::basenamereplace), + ("dirnamereplace|dnr=s". + "[Use the replacement string replace-str instead of {//} for ". + "dirname of input line]:replace-str" + => \$opt::dirnamereplace), + ("basenameextensionreplace|bner=s". + "[Use the replacement string replace-str instead of {/.} for ". + "basename of input line without extension]:replace-str" + => \$opt::basenameextensionreplace), + ("seqreplace=s". + "[Use the replacement string replace-str instead of {#} for job ". + "sequence number]:replace-str" + => \$opt::seqreplace), + ("slotreplace=s". + "[Use the replacement string replace-str instead of {%} for job ". + "slot number]:replace-str" + => \$opt::slotreplace), + ("delay=s". + "[Delay starting next job by duration]:duration" => \$opt::delay), + ("ssh-delay|sshdelay=f". + "[Delay starting next ssh by duration]:duration" + => \$opt::sshdelay), + ("load=s". + "[Only start jobs if load is less than max-load]:max-load" + => \$opt::load), + "noswap[Do not start job is computer is swapping]" => \$opt::noswap, + ("max-line-length-allowed|maxlinelengthallowed". + "[Print maximal command line length]" + => \$opt::max_line_length_allowed), + ("number-of-cpus|numberofcpus". + "[Print the number of physical CPU cores and exit (obsolete)]" + => \$opt::number_of_cpus), + ("number-of-sockets|numberofsockets". + "[Print the number of CPU sockets and exit]" + => \$opt::number_of_sockets), + ("number-of-cores|numberofcores". + "[Print the number of physical CPU cores and exit]" + => \$opt::number_of_cores), + ("number-of-threads|numberofthreads". + "[Print the number of hyperthreaded CPU cores and exit]" + => \$opt::number_of_threads), + ("use-sockets-instead-of-threads|usesocketsinsteadofthreads". + "[Determine how GNU Parallel counts the number of CPUs]" + => \$opt::use_sockets_instead_of_threads), + ("use-cores-instead-of-threads|usecoresinsteadofthreads". + "[Determine how GNU Parallel counts the number of CPUs]" + => \$opt::use_cores_instead_of_threads), + ("use-cpus-instead-of-cores|usecpusinsteadofcores". + "[Determine how GNU Parallel counts the number of CPUs]" + => \$opt::use_cpus_instead_of_cores), + ("shell-quote|shellquote|shell_quote". + "[Does not run the command but quotes it. Useful for making ". + "quoted composed commands for GNU parallel]" + => \@opt::shellquote), + ('nice=i[Run the command at this niceness]:niceness:($(seq -20 19))' + => \$opt::nice), + "tag[Tag lines with arguments]" => \$opt::tag, + ("tag-string|tagstring=s". + "[Tag lines with a string]:str" => \$opt::tagstring), + "ctag[Color tag]:str" => \$opt::ctag, + "ctag-string|ctagstring=s[Colour tagstring]:str" => \$opt::ctagstring, + "color|colour[Colourize output]" => \$opt::color, + ("color-failed|colour-failed|colorfailed|colourfailed|". + "color-fail|colour-fail|colorfail|colourfail|cf". + "[Colour failed jobs red]" + => \$opt::colorfailed), + ("onall[Run all the jobs on all computers given with --sshlogin]" + => \$opt::onall), + "nonall[--onall with no arguments]" => \$opt::nonall, + ("filter-hosts|filterhosts|filter-host[Remove down hosts]" + => \$opt::filter_hosts), + ('sshlogin|S=s'. + '[Distribute jobs to remote computers]'. + ':[@hostgroups/][ncpus/]sshlogin'. + '[,[@hostgroups/][ncpus/]sshlogin[,...]] or @hostgroup'. + ':_users') => \@opt::sshlogin, + ("sshloginfile|slf=s". + "[File with sshlogins on separate lines. Lines starting with '#' ". + "are ignored.]:filename:_files" + => \@opt::sshloginfile), + ("controlmaster|M". + "[Use ssh's ControlMaster to make ssh connections faster]" + => \$opt::controlmaster), + ("ssh=s". + "[Use this command instead of ssh for remote access]:sshcommand" + => \$opt::ssh), + ("transfer-file|transferfile|transfer-files|transferfiles|tf=s". + "[Transfer filename to remote computers]:filename:_files" + => \@opt::transfer_files), + ("return=s[Transfer files from remote computers]:filename:_files" + => \@opt::return), + ("trc=s[--transfer --return filename --cleanup]:filename:_files" + => \@opt::trc), + "transfer[Transfer files to remote computers]" => \$opt::transfer, + "cleanup[Remove transferred files]" => \$opt::cleanup, + ("basefile|bf=s". + "[Transfer file to each sshlogin before first job is started]". + ":file:_files" + => \@opt::basefile), + ("template|tmpl=s". + "[Replace replacement strings in file and save it in repl]". + ":file=repl:_files" + => \%opt::template), + "B=s" => \$opt::retired, + "ctrl-c|ctrlc" => \$opt::retired, + "no-ctrl-c|no-ctrlc|noctrlc" => \$opt::retired, + ("work-dir|workdir|wd=s". + "[Jobs will be run in the dir mydir. (default: the current dir ". + "for the local machine, the login dir for remote computers)]". + ":mydir:_cd" + => \$opt::workdir), + "W=s" => \$opt::retired, + ("rsync-opts|rsyncopts=s[Options to pass on to rsync]:options" + => \$opt::rsync_opts), + ("tmpdir|tempdir=s[Directory for temporary files]:dirname:_cd" + => \$opt::tmpdir), + ("use-compress-program|compress-program|". + "usecompressprogram|compressprogram=s". + "[Use prg for compressing temporary files]:prg:_commands" + => \$opt::compress_program), + ("use-decompress-program|decompress-program|". + "usedecompressprogram|decompressprogram=s". + "[Use prg for decompressing temporary files]:prg:_commands" + => \$opt::decompress_program), + "compress[Compress temporary files]" => \$opt::compress, + "open-tty|o[Open terminal tty]" => \$opt::open_tty, + "tty[Open terminal tty]" => \$opt::tty, + "T" => \$opt::retired, + "H=i" => \$opt::retired, + ("dry-run|dryrun|dr". + "[Print the job to run on stdout (standard output), but do not ". + "run the job]" + => \$opt::dryrun), + "progress[Show progress of computations]" => \$opt::progress, + ("eta[Show the estimated number of seconds before finishing]" + => \$opt::eta), + "bar[Show progress as a progress bar]" => \$opt::bar, + ("total-jobs|totaljobs|total=s". + "[Set total number of jobs]" => \$opt::totaljobs), + "shuf[Shuffle jobs]" => \$opt::shuf, + ("arg-sep|argsep=s". + "[Use sep-str instead of ::: as separator string]:sep-str" + => \$opt::arg_sep), + ("arg-file-sep|argfilesep=s". + "[Use sep-str instead of :::: as separator string ". + "between command and argument files]:sep-str" + => \$opt::arg_file_sep), + ('trim=s[Trim white space in input]:trim_method:'. + '((n\:"No trim" l\:"Left\ trim" r\:"Right trim" '. + 'lr\:"Both trim" rl\:"Both trim"))' + => \$opt::trim), + "env=s[Copy environment variable var]:var:_vars" => \@opt::env, + "recordenv|record-env[Record environment]" => \$opt::record_env, + ('session'. + '[Record names in current environment in $PARALLEL_IGNORED_NAMES '. + 'and exit. Only used with env_parallel. '. + 'Aliases, functions, and variables with names i]' + => \$opt::session), + ('plain[Ignore --profile, $PARALLEL, and ~/.parallel/config]' + => \$opt::plain), + ("profile|J=s". + "[Use profile profilename for options]:profilename:_files" + => \@opt::profile), + "tollef" => \$opt::tollef, + "gnu[Behave like GNU parallel]" => \$opt::gnu, + "link|xapply[Link input sources]" => \$opt::link, + "linkinputsource|xapplyinputsource=i" => \@opt::linkinputsource, + # Before changing these lines, 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 + # You accept to be put in a public hall-of-shame by removing + # these lines + ("bibtex|citation". + "[Print the citation notice and BibTeX entry for GNU parallel, ". + "silence citation notice for all future runs, and exit. ". + "It will not run any commands]" + => \$opt::citation), + "will-cite|willcite|nn|nonotice|no-notice" => \$opt::willcite, + # Termination and retries + ('halt-on-error|haltonerror|halt=s'. + '[When should GNU parallel terminate]'. + ':when:((now\:"kill all running jobs and halt immediately" '. + 'soon\:"wait for all running jobs to complete, start no new jobs"))' + => \$opt::halt), + 'limit=s[Dynamic job limit]:"command args"' => \$opt::limit, + ("memfree=s". + "[Minimum memory free when starting another job]:size" + => \$opt::memfree), + ("memsuspend=s". + "[Suspend jobs when there is less memory available]:size" + => \$opt::memsuspend), + "retries=s[Try failing jobs n times]:n" => \$opt::retries, + ("timeout=s". + "[Time out for command. If the command runs for longer than ". + "duration seconds it will get killed as per --term-seq]:duration" + => \$opt::timeout), + ("term-seq|termseq=s". + "[Termination sequence]:sequence" => \$opt::termseq), + # xargs-compatibility - implemented, man, testsuite + ("max-procs|maxprocs|P|jobs|j=s". + "[Add N to/Subtract N from/Multiply N% with/ the number of CPU ". + "threads or read parameter from file]:+N/-N/N%/N/procfile:_files" + => \$opt::jobs), + ("delimiter|d=s[Input items are terminated by delim]:delim" + => \$opt::d), + ("max-chars|maxchars|s=s[Limit length of command]:max-chars" + => \$opt::max_chars), + ("arg-file|argfile|a=s". + "[Use input-file as input source]:input-file:_files" => \@opt::a), + "no-run-if-empty|norunifempty|r[Do not run empty input]" => \$opt::r, + ("replace|i:s". + "[This option is deprecated; use -I instead]:replace-str" + => \$opt::i), + "E=s" => \$opt::eof, + ("eof|e:s[Set the end of file string to eof-str]:eof-str" + => \$opt::eof), + ("process-slot-var|processslotvar=s". + "[Set this variable to job slot number]:varname" + => \$opt::process_slot_var), + ("max-args|maxargs|n=s". + "[Use at most max-args arguments per command line]:max-args" + => \$opt::max_args), + ("max-replace-args|maxreplaceargs|N=s". + "[Use at most max-args arguments per command line]:max-args" + => \$opt::max_replace_args), + "col-sep|colsep|C=s[Column separator]:regexp" => \$opt::colsep, + "csv[Treat input as CSV-format]"=> \$opt::csv, + ("help|h[Print a summary of the options to GNU parallel and exit]" + => \$opt::help), + ("L=s[When used with --pipe: Read records of recsize]:recsize" + => \$opt::L), + ("max-lines|maxlines|l:f". + "[When used with --pipe: Read records of recsize lines]:recsize" + => \$opt::max_lines), + "interactive|p[Ask user before running a job]" => \$opt::interactive, + ("verbose|t[Print the job to be run on stderr (standard error)]" + => \$opt::verbose), + ("version|V[Print the version GNU parallel and exit]" + => \$opt::version), + ('min-version|minversion=i'. + '[Print the version GNU parallel and exit]'. + ':version:($(parallel --minversion 0))' + => \$opt::minversion), + ("show-limits|showlimits". + "[Display limits given by the operating system]" + => \$opt::show_limits), + ("exit|x[Exit if the size (see the -s option) is exceeded]" + => \$opt::x), + # Semaphore + "semaphore[Work as a counting semaphore]" => \$opt::semaphore, + ("semaphore-timeout|semaphoretimeout|st=s". + "[If secs > 0: If the semaphore is not released within secs ". + "seconds, take it anyway]:secs" + => \$opt::semaphoretimeout), + ("semaphore-name|semaphorename|id=s". + "[Use name as the name of the semaphore]:name" + => \$opt::semaphorename), + "fg[Run command in foreground]" => \$opt::fg, + "bg[Run command in background]" => \$opt::bg, + "wait[Wait for all commands to complete]" => \$opt::wait, + # Shebang #!/usr/bin/parallel --shebang + ("shebang|hashbang". + "[GNU parallel can be called as a shebang (#!) command as the ". + "first line of a script. The content of the file will be treated ". + "as inputsource]" + => \$opt::shebang), + ("_pipe-means-argfiles[internal]" + => \$opt::_pipe_means_argfiles), + "Y" => \$opt::retired, + ("skip-first-line|skipfirstline". + "[Do not use the first line of input]" + => \$opt::skip_first_line), + "_bug" => \$opt::_bug, + "_unsafe" => \$opt::_unsafe, + # --pipe + ("pipe|spreadstdin". + "[Spread input to jobs on stdin (standard input)]" => \$opt::pipe), + ("round-robin|roundrobin|round". + "[Distribute chunks of standard input in a round robin fashion]" + => \$opt::roundrobin), + "recstart=s" => \$opt::recstart, + ("recend=s". + "[Split record between endstring and startstring]:endstring" + => \$opt::recend), + ("regexp|regex". + "[Interpret --recstart and --recend as regular expressions]" + => \$opt::regexp), + ("remove-rec-sep|removerecsep|rrs". + "[Remove record separator]" => \$opt::remove_rec_sep), + ("output-as-files|outputasfiles|files[Save output to files]" + => \$opt::files), + ("output-as-files0|outputasfiles0|files0". + "[Save output to files separated by NUL]" + => \$opt::files0), + ("block-size|blocksize|block=s". + "[Size of block in bytes to read at a time]:size" + => \$opt::blocksize), + ("block-timeout|blocktimeout|bt=s". + "[Timeout for reading block when using --pipe]:duration" + => \$opt::blocktimeout), + "header=s[Use regexp as header]:regexp" => \$opt::header, + "cat[Create a temporary file with content]" => \$opt::cat, + "fifo[Create a temporary fifo with content]" => \$opt::fifo, + ("pipe-part|pipepart[Pipe parts of a physical file]" + => \$opt::pipepart), + "tee[Pipe all data to all jobs]" => \$opt::tee, + ("shard=s". + "[Use shardexpr as shard key and shard input to the jobs]:shardexpr" + => \$opt::shard), + ("bin=s". + "[Use binexpr as binning key and bin input to the jobs]:binexpr" + => \$opt::bin), + "group-by|groupby=s[Group input by value]:val" => \$opt::groupby, + # + ("hgrp|hostgrp|hostgroup|hostgroups[Enable hostgroups on arguments]" + => \$opt::hostgroups), + "embed[Embed GNU parallel in a shell script]" => \$opt::embed, + ("filter=s[Only run jobs where filter is true]:filter" + => \@opt::filter), + "combineexec|combine-exec|combineexecutable|combine-executable=s". + "[Embed GNU parallel in a shell script]" => \$opt::combineexec, + ("filter=s[Only run jobs where filter is true]:filter" + => \@opt::filter), + "_parset=s[Generate shell code for parset]" => \$opt::_parset, + ("shell-completion|shellcompletion=s". + "[Generate shell code for shell completion]:shell:(bash zsh)" + => \$opt::shellcompletion), + # Parameter for testing optimal values + "_test=s" => \$opt::_test, + ); +} + +sub get_options_from_array($@) { + # Run GetOptions on @array + # Input: + # $array_ref = ref to @ARGV to parse + # @keep_only = Keep only these options (e.g. --profile) + # Uses: + # @ARGV + # Returns: + # true if parsing worked + # false if parsing failed + # @$array_ref is changed + my ($array_ref, @keep_only) = @_; + if(not @$array_ref) { + # Empty array: No need to look more at that + return 1; + } + # A bit of shuffling of @ARGV needed as GetOptionsFromArray is not + # supported everywhere + my @save_argv; + my $this_is_ARGV = (\@::ARGV == $array_ref); + if(not $this_is_ARGV) { + @save_argv = @::ARGV; + @::ARGV = @{$array_ref}; + } + # If @keep_only set: Ignore all values except @keep_only + my %options = options_hash(); + if(@keep_only) { + my (%keep,@dummy); + @keep{@keep_only} = @keep_only; + for my $k (grep { not $keep{$_} } keys %options) { + # Store the value of the option in @dummy + $options{$k} = \@dummy; + } + } + my $retval = GetOptions(%options); + if(not $this_is_ARGV) { + @{$array_ref} = @::ARGV; + @::ARGV = @save_argv; + } + return $retval; +} + +sub parse_parset() { + $Global::progname = "parset"; + @Global::parset_vars = split /[ ,]/, $opt::_parset; + my $var_or_assoc = shift @Global::parset_vars; + # Legal names: var _v2ar arrayentry[2] + my @illegal = (grep { not /^[a-zA-Z_][a-zA-Z_0-9]*(\[\d+\])?$/ } + @Global::parset_vars); + if(@illegal) { + ::error + (255,"@illegal is an invalid variable name.", + "Variable names must be letter followed by letters or digits.", + "Usage:", + " parset varname GNU Parallel options and command"); + } + if($var_or_assoc eq "assoc") { + my $var = shift @Global::parset_vars; + print "$var=("; + $Global::parset = "assoc"; + $Global::parset_endstring=")\n"; + } elsif($var_or_assoc eq "var") { + if($#Global::parset_vars > 0) { + $Global::parset = "var"; + } else { + my $var = shift @Global::parset_vars; + print "$var=("; + $Global::parset = "array"; + $Global::parset_endstring=")\n"; + } + } else { + ::die_bug("parset: unknown '$opt::_parset'"); + } +} + +sub parse_options(@) { + # Returns: N/A + init_globals(); + my @argv_before = @ARGV; + @ARGV = read_options(); + # Before changing these 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 + # You accept to be added to a public hall-of-shame by removing the lines + if(defined $opt::citation) { + citation(\@argv_before,\@ARGV); + wait_and_exit(0); + } + # no-* overrides * + if($opt::nokeeporder) { $opt::keeporder = undef; } + + if(@opt::v) { $Global::verbose = $#opt::v+1; } # Convert -v -v to v=2 + if($opt::_bug) { ::die_bug("test-bug"); } + $Global::debug = $opt::D; + # + ## Shell + # + $Global::shell = $ENV{'PARALLEL_SHELL'} || parent_shell($$) + || $ENV{'SHELL'} || "/bin/sh"; + if(not -x $Global::shell and not which($Global::shell)) { + ::error(255,"Shell '$Global::shell' not found."); + } + ::debug("init","Global::shell $Global::shell\n"); + $Global::cshell = $Global::shell =~ m:(/[-a-z]*)?csh:; + $Global::fish = $Global::shell =~ m:(/[-a-z]*)?fish:; + if(defined $opt::_parset) { parse_parset(); } + if(defined $opt::X) { $Global::ContextReplace = 1; } + if(defined $opt::silent) { $Global::verbose = 0; } + if(defined $opt::null) { $/ = "\0"; } + if(defined $opt::files) { $Global::files = 1; $Global::files_sep = "\n"; } + if(defined $opt::files0) { $Global::files = 1; $Global::files_sep = "\0"; } + if(defined $opt::d) { $/ = unquote_printf($opt::d) } + parse_replacement_string_options(); + $opt::tag ||= $opt::ctag; + $opt::tagstring ||= $opt::ctagstring; + if(defined $opt::ctag or defined $opt::ctagstring + or defined $opt::color) { + $Global::color = 1; + } + if($opt::linebuffer or $opt::latestline) { + $Global::linebuffer = 1; + Job::latestline_init(); + } + if(defined $opt::tag and not defined $opt::tagstring) { + # Default = {} + $opt::tagstring = $Global::parensleft.$Global::parensright; + } + if(defined $opt::tagstring) { + $opt::tagstring = unquote_printf($opt::tagstring); + if($opt::tagstring =~ + /\Q$Global::parensleft\E.*\S+.*\Q$Global::parensright\E/ + and + $Global::linebuffer) { + # --tagstring contains {= ... =} and --linebuffer => + # recompute replacement string for each use (do not cache) + $Global::cache_replacement_eval = 0; + } + } + if(defined $opt::interactive) { $Global::interactive = $opt::interactive; } + if(defined $opt::quote) { $Global::quoting = 1; } + if(defined $opt::r) { $Global::ignore_empty = 1; } + if(defined $opt::verbose) { $Global::stderr_verbose = 1; } + if(defined $opt::eof) { $Global::end_of_file_string = $opt::eof; } + if(defined $opt::max_args) { + $opt::max_args = multiply_binary_prefix($opt::max_args); + $Global::max_number_of_args = $opt::max_args; + if($opt::pipepart and $opt::groupby) { $Global::max_number_of_args = 1; } + } + if(defined $opt::blocktimeout) { + $Global::blocktimeout = int(multiply_time_units($opt::blocktimeout)); + if($Global::blocktimeout < 1) { + ::error(255,"--block-timeout must be at least 1"); + } + } + if(defined $opt::timeout) { + $Global::timeoutq = TimeoutQueue->new($opt::timeout); + } + if(defined $opt::tmpdir) { $ENV{'TMPDIR'} = $opt::tmpdir; } + $ENV{'PARALLEL_RSYNC_OPTS'} = $opt::rsync_opts || + $ENV{'PARALLEL_RSYNC_OPTS'} || '-rlDzR'; + # Default: Same nice level as GNU Parallel is started at + $opt::nice ||= eval { getpriority(0,0) } || 0; + if(defined $opt::help) { usage(); exit(0); } + if(defined $opt::shellcompletion) { shell_completion(); exit(0); } + if(defined $opt::embed) { embed(); exit(0); } + if(defined $opt::sqlandworker) { + $opt::sqlmaster = $opt::sqlworker = $opt::sqlandworker; + } + if(defined $opt::tmuxpane) { $opt::tmux = $opt::tmuxpane; } + if(defined $opt::colsep) { $Global::trim = 'lr'; } + if(defined $opt::csv) { + if(not $Global::use{"Text::CSV"} ||= eval "use Text::CSV; 1;") { + ::error(255,"The perl module Text::CSV is not installed.", + "Try installing libtext-csv-perl or perl-Text-CSV."); + } + $opt::colsep = defined $opt::colsep ? $opt::colsep : ","; + my $csv_setting = { binary => 1, sep_char => $opt::colsep }; + my $sep = $csv_setting->{sep_char}; + $Global::csv = Text::CSV->new($csv_setting) + or die "Cannot use CSV: ".Text::CSV->error_diag (); + } + if(defined $opt::header) { + $opt::colsep = defined $opt::colsep ? $opt::colsep : "\t"; + } + if(defined $opt::trim) { $Global::trim = $opt::trim; } + if(defined $opt::arg_sep) { $Global::arg_sep = $opt::arg_sep; } + if(defined $opt::arg_file_sep) { + $Global::arg_file_sep = $opt::arg_file_sep; + } + if(not defined $opt::process_slot_var) { + $opt::process_slot_var = 'PARALLEL_JOBSLOT0'; + } + 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_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); + } + if(defined $opt::max_chars) { + $opt::max_chars = multiply_binary_prefix($opt::max_chars); + } + if(defined $opt::version) { version(); wait_and_exit(0); } + if(defined $opt::record_env) { record_env(); wait_and_exit(0); } + if(@opt::sshlogin) { @Global::sshlogin = @opt::sshlogin; } + if(@opt::sshloginfile) { read_sshloginfiles(@opt::sshloginfile); } + if(@opt::return) { push @Global::ret_files, @opt::return; } + if($opt::transfer) { + push @Global::transfer_files, $opt::i || $opt::I || "{}"; + } + push @Global::transfer_files, @opt::transfer_files; + if(%opt::template) { + while (my ($source, $template_name) = each %opt::template) { + push @Global::template_names, $template_name; + push @Global::template_contents, slurp_or_exit($source); + } + } + if(not defined $opt::recstart and + not defined $opt::recend) { $opt::recend = "\n"; } + $Global::blocksize = multiply_binary_prefix($opt::blocksize || "1M"); + if($Global::blocksize > 2**31-1 and not $opt::pipepart) { + warning("--blocksize >= 2G causes problems. Using 2G-1."); + $Global::blocksize = 2**31-1; + } + if($^O eq "cygwin" and + ($opt::pipe or $opt::pipepart or $opt::roundrobin) + and $Global::blocksize > 65535) { + warning("--blocksize >= 64K causes problems on Cygwin."); + } + $opt::memfree = multiply_binary_prefix($opt::memfree); + $opt::memsuspend = multiply_binary_prefix($opt::memsuspend); + $Global::memlimit = $opt::memsuspend + $opt::memfree; + check_invalid_option_combinations(); + if((defined $opt::fifo or defined $opt::cat) and not $opt::pipepart) { + $opt::pipe = 1; + } + if(defined $opt::minversion) { + print $Global::version,"\n"; + if($Global::version < $opt::minversion) { + wait_and_exit(255); + } else { + wait_and_exit(0); + } + } + if(not defined $opt::delay) { + # Set --delay to --sshdelay if not set + $opt::delay = $opt::sshdelay; + } + $Global::sshdelayauto = $opt::sshdelay =~ s/auto$//; + $opt::sshdelay = multiply_time_units($opt::sshdelay); + $Global::delayauto = $opt::delay =~ s/auto$//; + $opt::delay = multiply_time_units($opt::delay); + if($opt::compress_program) { + $opt::compress = 1; + $opt::decompress_program ||= $opt::compress_program." -dc"; + } + + if(defined $opt::results) { + # Is the output a dir or CSV-file? + if($opt::results =~ /\.csv$/i) { + # CSV with , as separator + $Global::csvsep = ","; + $Global::membuffer ||= 1; + } elsif($opt::results =~ /\.tsv$/i) { + # CSV with TAB as separator + $Global::csvsep = "\t"; + $Global::membuffer ||= 1; + } elsif($opt::results =~ /\.json$/i) { + # JSON output + $Global::jsonout ||= 1; + $Global::membuffer ||= 1; + } + } + if($opt::compress) { + my ($compress, $decompress) = find_compression_program(); + $opt::compress_program ||= $compress; + $opt::decompress_program ||= $decompress; + if(($opt::results and not $Global::csvsep) or $Global::files) { + # No need for decompressing + $opt::decompress_program = "cat >/dev/null"; + } + } + if(defined $opt::dryrun) { + # Force grouping due to bug #51039: --dry-run --timeout 3600 -u breaks + $opt::ungroup = 0; + $opt::group = 1; + } + if(defined $opt::nonall) { + # Append a dummy empty argument if there are no arguments + # on the command line to avoid reading from STDIN. + # arg_sep = random 50 char + # \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, "\0noarg"; + } + if(defined $opt::tee) { + if(not defined $opt::jobs) { + $opt::jobs = 0; + } + } + if(defined $opt::tty) { + # Defaults for --tty: -j1 -u + # Can be overridden with -jXXX -g + if(not defined $opt::jobs) { + $opt::jobs = 1; + } + if(not defined $opt::group) { + $opt::ungroup = 1; + } + } + if(@opt::trc) { + push @Global::ret_files, @opt::trc; + if(not @Global::transfer_files) { + # Defaults to --transferfile {} + push @Global::transfer_files, $opt::i || $opt::I || "{}"; + } + $opt::cleanup = 1; + } + if(defined $opt::max_lines) { + if($opt::max_lines eq "-0") { + # -l -0 (swallowed -0) + $opt::max_lines = 1; + $opt::null = 1; + $/ = "\0"; + } else { + $opt::max_lines = multiply_binary_prefix($opt::max_lines); + if ($opt::max_lines == 0) { + # If not given (or if 0 is given) => 1 + $opt::max_lines = 1; + } + } + + $Global::max_lines = $opt::max_lines; + if(not $opt::pipe) { + # --pipe -L means length of record - not max_number_of_args + $Global::max_number_of_args ||= $Global::max_lines; + } + } + + # Read more than one arg at a time (-L, -N) + if(defined $opt::L) { + $opt::L = multiply_binary_prefix($opt::L); + $Global::max_lines = $opt::L; + if(not $opt::pipe) { + # --pipe -L means length of record - not max_number_of_args + $Global::max_number_of_args ||= $Global::max_lines; + } + } + if(defined $opt::max_replace_args) { + $opt::max_replace_args = + multiply_binary_prefix($opt::max_replace_args); + $Global::max_number_of_args = $opt::max_replace_args; + $Global::ContextReplace = 1; + } + if((defined $opt::L or defined $opt::max_replace_args) + and + not ($opt::xargs or $opt::m)) { + $Global::ContextReplace = 1; + } + # Deal with ::: :::+ :::: ::::+ and -a +file + my @ARGV_with_argsep = @ARGV; + @ARGV = read_args_from_command_line(); + if(defined $opt::combineexec) { + pack_combined_executable(\@argv_before,\@ARGV_with_argsep,\@ARGV); + exit(0); + } + parse_semaphore(); + + if(defined $opt::eta) { $opt::progress = $opt::eta; } + if(defined $opt::bar) { $opt::progress = $opt::bar; } + if(defined $opt::bar or defined $opt::latestline) { + my $fh = $Global::status_fd || *STDERR; + # Activate decode_utf8 + eval q{ + # Enable utf8 if possible + use utf8; + binmode $fh, "encoding(utf8)"; + *decode_utf8 = \&Encode::decode_utf8; + }; + if(eval { decode_utf8("x") }) { + # Great: decode works + } else { + # UTF8-decode not supported: Dummy decode + eval q{sub decode_utf8($;$) { $_[0]; }}; + } + # Activate decode_utf8 + eval q{ + # Enable utf8 if possible + use utf8; + use Encode qw( encode_utf8 ); + use Text::CharWidth qw( mbswidth ); + use Unicode::Normalize qw( NFC NFD ); + }; + if(eval { mbswidth("ヌー平行") }) { + # Great: mbswidth works + } else { + # mbswidth not supported: Dummy mbswidth + eval q{ sub mbswidth { return length @_; } }; + } + } + + # If you want GNU Parallel to be maintained in the future you + # should keep this. + # *YOU* will be harming free software by removing the notice. + # + # 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/ + # + # The FAQ tells you why the citation notice exists: + # https://git.savannah.gnu.org/cgit/parallel.git/tree/doc/citation-notice-faq.txt + # + # If you want GNU Parallel to be maintained in the future, and not + # just wither away like so many other free software tools, you + # need to help finance the development. + # + # The citation notice is a simple way of doing so, as citations + # makes it possible to me to get a job where I can maintain GNU + # Parallel as part of the job. + # + # This means you can help financing development + # + # WITHOUT PAYING A SINGLE CENT! + # + # 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 in + # a way where the software can be confused with 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 + # 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' + # + # If you want GNU Parallel to be maintained in the future, you + # should keep this line: + citation_notice(); + # This is because _YOU_ actively make it harder to justify + # spending time developing GNU Parallel by removing it. + + # If you disagree, please read (especially 77-): + # https://www.fordfoundation.org/media/2976/roads-and-bridges-the-unseen-labor-behind-our-digital-infrastructure.pdf + + # *YOU* will be harming free software by removing the notice. You + # accept to be added to a public hall of shame by removing the + # line. That includes you, George and Andreas. + + 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 + $penv = slurp_or_exit($penv); + } + # 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(defined $opt::show_limits) { show_limits(); } + + if(remote_hosts() and + (defined $opt::X or defined $opt::m or defined $opt::xargs)) { + # As we do not know the max line length on the remote machine + # long commands generated by xargs may fail + # If $opt::max_replace_args is set, it is probably safe + ::warning("Using -X or -m with --sshlogin may fail."); + } + + if(not defined $opt::jobs) { $opt::jobs = "100%"; } + open_joblog(); + open_json_csv(); + if(defined $opt::sqlmaster or defined $opt::sqlworker) { + $Global::sql = SQL->new($opt::sqlmaster || $opt::sqlworker); + } + if(defined $opt::sqlworker) { $Global::membuffer ||= 1; } + # The sqlmaster groups the arguments, so the should just read one + if(defined $opt::sqlworker and not defined $opt::sqlmaster) { + $Global::max_number_of_args = 1; + } + if(defined $Global::color or defined $opt::colorfailed) { + Job::init_color(); + } +} + +sub check_invalid_option_combinations() { + if(defined $opt::timeout and + $opt::timeout !~ /^\d+(\.\d+)?%?$|^(\d+(\.\d+)?[dhms])+$/i) { + ::error(255,"--timeout must be seconds or percentage."); + } + if(defined $opt::fifo and defined $opt::cat) { + ::error(255,"--fifo cannot be combined with --cat."); + } + if(defined $opt::retries and defined $opt::roundrobin) { + ::error(255,"--retries cannot be combined with --roundrobin."); + } + if(defined $opt::pipepart and + (defined $opt::L or defined $opt::max_lines + or defined $opt::max_replace_args)) { + ::error(255,"--pipepart is incompatible with --max-replace-args, ". + "--max-lines, and -L."); + } + if(defined $opt::group and defined $opt::ungroup) { + ::error(255,"--group cannot be combined with --ungroup."); + } + if(defined $opt::group and defined $opt::linebuffer) { + ::error(255,"--group cannot be combined with --line-buffer."); + } + if(defined $opt::ungroup and defined $opt::linebuffer) { + ::error(255,"--ungroup cannot be combined with --line-buffer."); + } + if(defined $opt::tollef and not defined $opt::gnu) { + ::error(255,"--tollef has been retired.", + "Remove --tollef or use --gnu to override --tollef."); + } + if(defined $opt::retired) { + ::error(255, + "-g has been retired. Use --group.", + "-B has been retired. Use --bf.", + "-T has been retired. Use --tty.", + "-U has been retired. Use --er.", + "-W has been retired. Use --wd.", + "-Y has been retired. Use --shebang.", + "-H has been retired. Use --halt.", + "--sql has been retired. Use --sqlmaster.", + "--ctrlc has been retired.", + "--noctrlc has been retired."); + } + if(defined $opt::groupby) { + if(not defined $opt::pipe and not defined $opt::pipepart) { + $opt::pipe = 1; + } + if(defined $opt::remove_rec_sep) { + ::error(255,"--remove-rec-sep is not compatible with --groupby"); + } + if(defined $opt::recstart) { + ::error(255,"--recstart is not compatible with --groupby"); + } + if($opt::recend ne "\n") { + ::error(255,"--recend is not compatible with --groupby"); + } + } + sub unsafe_warn { + # use --_unsafe to only generate a warning + if($opt::_unsafe) { ::warning(@_); } else { ::error(255,@_); } + } + if(defined $opt::results) { + if($opt::nonall or $opt::onall) { + unsafe_warn("--(n)onall + --results not supported (yet)."); + } + } + sub test_safe_chars { + my $var = shift; + if($ENV{$var} =~ m{^[-a-z0-9_+,.%:/= ]*$}i) { + # OK + } else { + unsafe_warn("\$$var can only contain [-a-z0-9_+,.%:/= ]."); + } + } + if($ENV{'TMPDIR'} =~ /\n/) { + if(defined $opt::files) { + ::warning("Use --files0 when \$TMPDIR contains newline."); + } elsif($Global::cshell + and + (defined $opt::cat or defined $opt::fifo)) { + ::warning("--cat/--fifo fails under csh ". + "if \$TMPDIR contains newline."); + } + } elsif($ENV{'TMPDIR'} =~ /\257/) { + unsafe_warn("\$TMPDIR with \\257 (\257) is not supported."); + } else{ + test_safe_chars('TMPDIR'); + } + map { test_safe_chars($_); } qw(PARALLEL_HOME XDG_CONFIG_DIRS + PARALLEL_REMOTE_TMPDIR XDG_CACHE_HOME); +} + +sub init_globals() { + # Defaults: + $Global::version = 20240222; + $Global::progname = 'parallel'; + $::name = "GNU Parallel"; + $Global::infinity = 2**31; + $Global::debug = 0; + $Global::verbose = 0; + # Don't quote every part of the command line + $Global::quoting = 0; + # Quote replacement strings + $Global::quote_replace = 1; + $Global::total_completed = 0; + $Global::cache_replacement_eval = 1; + # Read only table with default --rpl values + %Global::replace = + ( + '{}' => '', + '{#}' => '1 $_=$job->seq()', + '{%}' => '1 $_=$job->slot()', + '{/}' => 's:.*/::', + '{//}' => + ('$Global::use{"File::Basename"} ||= eval "use File::Basename; 1;"; '. + '$_ = dirname($_);'), + '{/.}' => 's:.*/::; s:\.[^/.]*$::;', + '{.}' => 's:\.[^/.]*$::', + ); + %Global::plus = + ( + # {} = {+/}/{/} + # = {.}.{+.} = {+/}/{/.}.{+.} + # = {..}.{+..} = {+/}/{/..}.{+..} + # = {...}.{+...} = {+/}/{/...}.{+...} + '{+/}' => 's:/[^/]*$:: || s:.*$::', + # a.b => b; a => '' + '{+.}' => 's:.*\.:: || s:.*$::', + # a.b.c => b.c; a.b => ''; a => '' + '{+..}' => 's:.*\.([^/.]*\.[^/.]*)$:$1: || s:.*$::', + '{+...}' => 's:.*\.([^/.]*\.[^/.]*\.[^/.]*)$:$1: || s:.*$::', + '{..}' => 's:\.[^/.]*\.[^/.]*$::', + '{...}' => 's:\.[^/.]*\.[^/.]*\.[^/.]*$::', + '{/..}' => 's:.*/::; s:\.[^/.]*\.[^/.]*$::', + '{/...}' => 's:.*/::; s:\.[^/.]*\.[^/.]*\.[^/.]*$::', + # n choose k = Binomial coefficient + '{choose_k}' => ('for $t (2..$#arg)'. + '{ if($arg[$t-1] ge $arg[$t]) { skip() } }'), + # unique values: Skip job if any args are the same + '{uniq}' => 'if(::uniq(@arg) != @arg) { skip(); }', + # {##} = number of jobs + '{##}' => '1 $_=total_jobs()', + # {0#} = 0-padded seq + '{0#}' => ('1 $f=1+int((log(total_jobs())/log(10)));'. + '$_=sprintf("%0${f}d",seq())'), + # {0%} = 0-padded jobslot + '{0%}' => ('1 $f=1+int((log($Global::max_jobs_running||1)/log(10)));'. + '$_=sprintf("%0${f}d",slot())'), + # {seq-1} = seq-1 = counting from 0 + '{seq(.*?)}' => '$_=eval q{$job->seq()}.qq{$$1}', + # {seq-1} = jobslot-1 = counting from 0 + '{slot(.*?)}' => '$_=eval q{$job->slot()}.qq{$$1}', + + ## Bash inspired replacement strings + # Bash ${a:-myval} + '{:-([^}]+?)}' => '$_ ||= $$1', + # Bash ${a:2} + '{:(\d+?)}' => 'substr($_,0,$$1) = ""', + # Bash ${a:2:3} + '{:(\d+?):(\d+?)}' => '$_ = substr($_,$$1,$$2);', + # echo {#z.*z.} ::: z.z.z.foo => z.foo + # echo {##z.*z.} ::: z.z.z.foo => foo + # Bash ${a#bc} + '{#([^#}][^}]*?)}' => + '$nongreedy=::make_regexp_ungreedy($$1);s/^$nongreedy(.*)/$1/;', + # Bash ${a##bc} + '{##([^#}][^}]*?)}' => 's/^$$1//;', + # echo {%.z.*z} ::: foo.z.z.z => foo.z + # echo {%%.z.*z} ::: foo.z.z.z => foo + # Bash ${a%def} + '{%([^}]+?)}' => + '$nongreedy=::make_regexp_ungreedy($$1);s/(.*)$nongreedy$/$1/;', + # Bash ${a%%def} + '{%%([^}]+?)}' => 's/$$1$//;', + # Bash ${a/def/ghi} ${a/def/} + '{/([^#%}/]+?)/([^}]*?)}' => 's/$$1/$$2/;', + # Bash ${a/#def/ghi} ${a/#def/} + '{/#([^}]+?)/([^}]*?)}' => 's/^$$1/$$2/g;', + # Bash ${a/%def/ghi} ${a/%def/} + '{/%([^}]+?)/([^}]*?)}' => 's/$$1$/$$2/g;', + # Bash ${a//def/ghi} ${a//def/} + '{//([^}]+?)/([^}]*?)}' => 's/$$1/$$2/g;', + # Bash ${a^a} + '{^([^}]+?)}' => 's/^($$1)/uc($1)/e;', + # Bash ${a^^a} + '{^^([^}]+?)}' => 's/($$1)/uc($1)/eg;', + # Bash ${a,A} + '{,([^}]+?)}' => 's/^($$1)/lc($1)/e;', + # Bash ${a,,A} + '{,,([^}]+?)}' => 's/($$1)/lc($1)/eg;', + + # {slot} = $PARALLEL_JOBSLOT + '{slot}' => '1 $_="\${PARALLEL_JOBSLOT}";uq()', + # {host} = ssh host + '{host}' => '1 $_="\${PARALLEL_SSHHOST}";uq()', + # {sshlogin} = sshlogin + '{sshlogin}' => '1 $_="\${PARALLEL_SSHLOGIN}";uq()', + # {hgrp} = hostgroups of the host + '{hgrp}' => '1 $_="\${PARALLEL_HOSTGROUPS}";uq()', + # {agrp} = hostgroups of the argument + '{agrp}' => '1 $_="\${PARALLEL_ARGHOSTGROUPS}";uq()', + ); + # Modifiable copy of %Global::replace + %Global::rpl = %Global::replace; + $/ = "\n"; + $Global::ignore_empty = 0; + $Global::interactive = 0; + $Global::stderr_verbose = 0; + $Global::default_simultaneous_sshlogins = 9; + $Global::exitstatus = 0; + $Global::arg_sep = ":::"; + $Global::arg_file_sep = "::::"; + $Global::trim = 'n'; + $Global::max_jobs_running = 0; + $Global::job_already_run = ''; + $ENV{'TMPDIR'} ||= "/tmp"; + $ENV{'PARALLEL_REMOTE_TMPDIR'} ||= "/tmp"; + # bug #55398: set $OLDPWD when using --wd + $ENV{'OLDPWD'} = $ENV{'PWD'}; + if(not $ENV{HOME}) { + # $ENV{HOME} is sometimes not set if called from PHP + ::warning("\$HOME not set. Using /tmp."); + $ENV{HOME} = "/tmp"; + } + # no warnings to allow for undefined $XDG_* + no warnings 'uninitialized'; + # If $PARALLEL_HOME is set, but does not exist, try making it. + if(defined $ENV{'PARALLEL_HOME'}) { + eval { File::Path::mkpath($ENV{'PARALLEL_HOME'}); }; + } + # $xdg_config_home is needed to make env_parallel.fish stop complaining + my $xdg_config_home = $ENV{'XDG_CONFIG_HOME'}; + # Use the first config dir that exists from: + # $PARALLEL_HOME + # $XDG_CONFIG_HOME/parallel + # $(each XDG_CONFIG_DIRS)/parallel + # $HOME/.parallel + # + # Keep only dirs that exist + @Global::config_dirs = + (grep { -d $_ } + $ENV{'PARALLEL_HOME'}, + (map { "$_/parallel" } + $xdg_config_home, + split /:/, $ENV{'XDG_CONFIG_DIRS'}), + $ENV{'HOME'} . "/.parallel"); + # Use first dir as config dir + $Global::config_dir = $Global::config_dirs[0] || + $ENV{'HOME'} . "/.parallel"; + if($ENV{'PARALLEL_HOME'} =~ /./ and not -d $ENV{'PARALLEL_HOME'}) { + ::warning("\$PARALLEL_HOME ($ENV{'PARALLEL_HOME'}) does not exist."); + ::warning("Using $Global::config_dir"); + } + # Use the first cache dir that exists from: + # $PARALLEL_HOME + # $XDG_CACHE_HOME/parallel + # Keep only dirs that exist + @Global::cache_dirs = (grep { -d $_ } + $ENV{'PARALLEL_HOME'}, + $ENV{'XDG_CACHE_HOME'}."/parallel"); + $Global::cache_dir = $Global::cache_dirs[0] || + $ENV{'HOME'} . "/.parallel"; + Job::init_color(); +} + +sub parse_halt() { + # $opt::halt flavours + # Uses: + # $opt::halt + # $Global::halt_when + # $Global::halt_fail + # $Global::halt_success + # $Global::halt_pct + # $Global::halt_count + if(defined $opt::halt) { + my %halt_expansion = ( + "0" => "never", + "1" => "soon,fail=1", + "2" => "now,fail=1", + "-1" => "soon,success=1", + "-2" => "now,success=1", + ); + # Expand -2,-1,0,1,2 into long form + $opt::halt = $halt_expansion{$opt::halt} || $opt::halt; + # --halt 5% == --halt soon,fail=5% + $opt::halt =~ s/^(\d+)%$/soon,fail=$1%/; + # Split: soon,fail=5% + my ($when,$fail_success,$pct_count) = split /[,=]/, $opt::halt; + if(not grep { $when eq $_ } qw(never soon now)) { + ::error(255,"--halt must have 'never', 'soon', or 'now'."); + } + $Global::halt_when = $when; + if($when ne "never") { + if($fail_success eq "fail") { + $Global::halt_fail = 1; + } elsif($fail_success eq "success") { + $Global::halt_success = 1; + } elsif($fail_success eq "done") { + $Global::halt_done = 1; + } else { + ::error(255,"--halt $when must be followed by ". + ",success or ,fail."); + } + if($pct_count =~ /^(\d+)%$/) { + $Global::halt_pct = $1/100; + } elsif($pct_count =~ /^(\d+)$/) { + $Global::halt_count = $1; + } else { + ::error(255,"--halt $when,$fail_success ". + "must be followed by ,number or ,percent%."); + } + } + } +} + +sub parse_replacement_string_options() { + # Deal with --rpl + # Uses: + # %Global::rpl + # $Global::parensleft + # $Global::parensright + # $opt::parens + # $Global::parensleft + # $Global::parensright + # $opt::plus + # %Global::plus + # $opt::I + # $opt::U + # $opt::i + # $opt::basenamereplace + # $opt::dirnamereplace + # $opt::seqreplace + # $opt::slotreplace + # $opt::basenameextensionreplace + + sub rpl($$) { + # Modify %Global::rpl + # Replace $old with $new + my ($old,$new) = @_; + if($old ne $new) { + $Global::rpl{$new} = $Global::rpl{$old}; + delete $Global::rpl{$old}; + } + } + my $parens = "{==}"; + if(defined $opt::parens) { $parens = $opt::parens; } + my $parenslen = 0.5*length $parens; + $Global::parensleft = substr($parens,0,$parenslen); + $Global::parensright = substr($parens,$parenslen); + if(defined $opt::plus) { %Global::rpl = (%Global::plus,%Global::rpl); } + if(defined $opt::I) { rpl('{}',$opt::I); } + if(defined $opt::i and $opt::i) { rpl('{}',$opt::i); } + if(defined $opt::U) { rpl('{.}',$opt::U); } + if(defined $opt::basenamereplace) { rpl('{/}',$opt::basenamereplace); } + if(defined $opt::dirnamereplace) { rpl('{//}',$opt::dirnamereplace); } + if(defined $opt::seqreplace) { rpl('{#}',$opt::seqreplace); } + if(defined $opt::slotreplace) { rpl('{%}',$opt::slotreplace); } + if(defined $opt::basenameextensionreplace) { + rpl('{/.}',$opt::basenameextensionreplace); + } + for(@opt::rpl) { + # Create $Global::rpl entries for --rpl options + # E.g: "{..} s:\.[^.]+$:;s:\.[^.]+$:;" + my ($shorthand,$long) = split/\s/,$_,2; + $Global::rpl{$shorthand} = $long; + } +} + +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 + # Uses: + # $opt::semaphore + # $Global::semaphore + # $opt::semaphoretimeout + # $Semaphore::timeout + # $opt::semaphorename + # $Semaphore::name + # $opt::fg + # $Semaphore::fg + # $opt::wait + # $Semaphore::wait + # $opt::bg + # @opt::a + # @Global::unget_argv + # $Global::default_simultaneous_sshlogins + # $opt::jobs + # $Global::interactive + $Global::semaphore ||= ($0 =~ m:(^|/)sem$:); # called as 'sem' + if(defined $opt::semaphore) { $Global::semaphore = 1; } + if(defined $opt::semaphoretimeout) { $Global::semaphore = 1; } + if(defined $opt::semaphorename) { $Global::semaphore = 1; } + if(defined $opt::fg and not $opt::tmux and not $opt::tmuxpane) { + $Global::semaphore = 1; + } + if(defined $opt::bg) { $Global::semaphore = 1; } + if(defined $opt::wait and not $opt::sqlmaster) { + $Global::semaphore = 1; @ARGV = "true"; + } + if($Global::semaphore) { + if(@opt::a) { + # Assign the first -a to STDIN + open(STDIN,"<",shift @opt::a); + if(@opt::a) { + # We currently have no way of dealing with more -a + ::error(255,"A semaphore cannot take input from ". + "more files\n"); + } + } + @opt::a = ("/dev/null"); + # Append a dummy empty argument + # \0 => nothing (not the empty string) + push(@Global::unget_argv, [Arg->new("\0noarg")]); + $Semaphore::timeout = int(multiply_time_units($opt::semaphoretimeout)) + || 0; + if(defined $opt::semaphorename) { + $Semaphore::name = $opt::semaphorename; + } else { + local $/ = "\n"; + $Semaphore::name = `tty`; + chomp $Semaphore::name; + } + $Semaphore::fg = $opt::fg; + $Semaphore::wait = $opt::wait; + $Global::default_simultaneous_sshlogins = 1; + if(not defined $opt::jobs) { + $opt::jobs = 1; + } + if($Global::interactive and $opt::bg) { + ::error(255,"Jobs running in the ". + "background cannot be interactive."); + } + } +} + +sub record_env() { + # Record current %ENV-keys in $PARALLEL_HOME/ignored_vars + # Returns: N/A + my $ignore_filename = $Global::config_dir . "/ignored_vars"; + write_or_exit($ignore_filename,map { $_,"\n" } keys %ENV); +} + +sub open_joblog() { + # Open joblog as specified by --joblog + # Uses: + # $opt::resume + # $opt::resume_failed + # $opt::joblog + # $opt::results + # $Global::job_already_run + # %Global::fh + my $append = 0; + if(($opt::resume or $opt::resume_failed) + and + not ($opt::joblog or $opt::results)) { + ::error(255,"--resume and --resume-failed require --joblog ". + "or --results."); + } + if(defined $opt::joblog and $opt::joblog =~ s/^\+//) { + # --joblog +filename = append to filename + $append = 1; + } + if($opt::joblog + and + ($opt::sqlmaster + or + not $opt::sqlworker)) { + # Do not log if --sqlworker + if($opt::resume || $opt::resume_failed || $opt::retry_failed) { + if(open(my $joblog_fh, "<", $opt::joblog)) { + # Enable utf8 if possible + eval q{ binmode $joblog_fh, "encoding(utf8)"; }; + # 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; + if($opt::retry_failed) { + # Make a regexp that matches commands with exit+signal=0 + # 4 host 1360490623.067 3.445 1023 1222 0 0 command + $joblog_regexp='^(\d+)(?:\t[^\t]+){5}\t0\t0\t'; + my @group; + 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(255,"Format of '$opt::joblog' is ". + "wrong: $_"); + } + } + if(@group) { + my ($outfh,$name) = ::tmpfile(SUFFIX => ".arg"); + unlink($name); + # Put args into argfile + if(grep /\0/, @group) { + # force --null to deal with \n in commandlines + ::warning("Command lines contain newline. ". + "Forcing --null."); + $opt::null = 1; + $/ = "\0"; + } + # Replace \0 with '\n' as used in print_joblog() + print $outfh (map { s/\0/\n/g; $_,$/ } + map { $_ } @group); + seek $outfh, 0, 0; + exit_if_disk_full(); + # Set filehandle to -a + @opt::a = ($outfh); + } + # Remove $command (so -a is run) + @ARGV = (); + } + if($opt::resume || $opt::resume_failed) { + if($opt::resume_failed) { + # Make a regexp that matches commands with exit+signal=0 + # 4 host 1360490623.067 3.445 1023 1222 0 0 command + $joblog_regexp='^(\d+)(?:\t[^\t]+){5}\t0\t0\t'; + } else { + # Just match the job number + $joblog_regexp='^(\d+)'; + } + 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++; + } elsif(not /\d+\s+[^\s]+\s+([-0-9.]+\s+){6}/) { + ::error(255,"Format of '$opt::joblog' ". + "is wrong: $_"); + } + } + } + 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 + + } elsif($append) { + # Append to joblog + $Global::joblog = open_or_exit(">>", $opt::joblog); + } else { + if($opt::joblog eq "-") { + # Use STDOUT as joblog + $Global::joblog = $Global::fh{1}; + } else { + # Overwrite the joblog + $Global::joblog = open_or_exit(">", $opt::joblog); + } + print $Global::joblog + join("\t", "Seq", "Host", "Starttime", "JobRuntime", + "Send", "Receive", "Exitval", "Signal", "Command" + ). "\n"; + } + } +} + +sub open_json_csv() { + if($opt::results) { + # Output as JSON/CSV/TSV + if($opt::results eq "-.csv" + or + $opt::results eq "-.tsv" + or + $opt::results eq "-.json") { + # Output as JSON/CSV/TSV on stdout + open $Global::csv_fh, ">&", "STDOUT" or + ::die_bug("Can't dup STDOUT in csv: $!"); + # Do not print any other output to STDOUT + # by forcing all other output to /dev/null + open my $fd, ">", "/dev/null" or + ::die_bug("Can't >/dev/null in csv: $!"); + $Global::fh{1} = $fd; + $Global::fh{2} = $fd; + } elsif($Global::csvsep or $Global::jsonout) { + $Global::csv_fh = open_or_exit(">",$opt::results); + } + } +} + +sub find_compression_program() { + # Find a fast compression program + # Returns: + # $compress_program = compress program with options + # $decompress_program = decompress program with options + + # Search for these. Sorted by speed on 128 core + + # seq 120000000|shuf > 1gb & + # apt-get update + # apt install make g++ htop + # wget -O - pi.dk/3 | bash + # apt install zstd clzip liblz4-tool lzop pigz pxz gzip plzip pbzip2 lzma xz-utils lzip bzip2 lbzip2 lrzip pixz + # git clone https://github.com/facebook/zstd.git + # (cd zstd/contrib/pzstd; make -j; cp pzstd /usr/local/bin) + # echo 'lrzip -L $((-$1))' >/usr/local/bin/lrz + # chmod +x /usr/local/bin/lrz + # wait + # onethread="zstd clzip lz4 lzop gzip lzma xz bzip2" + # multithread="pzstd pigz pxz plzip pbzip2 lzip lbzip2 lrz pixz" + # parallel --shuf -j1 --joblog jl-m --arg-sep , parallel --compress-program \'{3}" "-{2}\' cat ::: 1gb '>'/dev/null , 1 2 3 , {1..3} , $multithread + # parallel --shuf -j50% --delay 1 --joblog jl-s --arg-sep , parallel --compress-program \'{3}" "-{2}\' cat ::: 1gb '>'/dev/null , 1 2 3 , {1..3} , $onethread + # sort -nk4 jl-? + + # 1-core: + # 2-cores: pzstd zstd lz4 lzop pigz gzip lbzip2 pbzip2 lrz bzip2 lzma pxz plzip xz lzip clzip + # 4-cores: + # 8-cores: pzstd lz4 zstd pigz lzop lbzip2 pbzip2 gzip lzip lrz plzip pxz bzip2 lzma xz clzip + # 16-cores: pzstd lz4 pigz lzop lbzip2 pbzip2 plzip lzip lrz pxz gzip lzma xz bzip2 + # 32-cores: pzstd lbzip2 pbzip2 zstd pigz lz4 lzop plzip lzip lrz gzip pxz lzma bzip2 xz clzip + # 64-cores: pzstd lbzip2 pbzip2 pigz zstd pixz lz4 plzip lzop lzip lrz gzip pxz lzma bzip2 xz clzip + # 128-core: pzstd lbzip2 pbzip2 zstd pixz lz4 pigz lzop plzip lzip gzip lrz pxz bzip2 lzma xz clzip + + my @prg = qw(pzstd lbzip2 pbzip2 zstd pixz lz4 pigz lzop plzip lzip gzip + lrz pxz bzip2 lzma xz clzip); + for my $p (@prg) { + if(which($p)) { + return ("$p -c -1","$p -dc"); + } + } + # Fall back to cat + return ("cat","cat"); +} + +sub read_options() { + # Read options from command line, profile and $PARALLEL + # Uses: + # $opt::shebang_wrap + # $opt::shebang + # @ARGV + # $opt::plain + # @opt::profile + # $ENV{'HOME'} + # $ENV{'PARALLEL'} + # Returns: + # @ARGV_no_opt = @ARGV without --options + + # This must be done first as this may exec myself + if(defined $ARGV[0] and ($ARGV[0] =~ /^--shebang/ or + $ARGV[0] =~ /^--shebang-?wrap/ or + $ARGV[0] =~ /^--hashbang/)) { + # Program is called from #! line in script + # remove --shebang-wrap if it is set + $opt::shebang_wrap = ($ARGV[0] =~ s/^--shebang-?wrap *//); + # remove --shebang if it is set + $opt::shebang = ($ARGV[0] =~ s/^--shebang *//); + # remove --hashbang if it is set + $opt::shebang .= ($ARGV[0] =~ s/^--hashbang *//); + if($opt::shebang) { + my $argfile = Q(pop @ARGV); + # exec myself to split $ARGV[0] into separate fields + exec "$0 --skip-first-line -a $argfile @ARGV"; + } + if($opt::shebang_wrap) { + my @options; + my @parser; + if ($^O eq 'freebsd') { + # FreeBSD's #! puts different values in @ARGV than Linux' does + my @nooptions = @ARGV; + get_options_from_array(\@nooptions); + while($#ARGV > $#nooptions) { + push @options, shift @ARGV; + } + while(@ARGV and $ARGV[0] ne ":::") { + push @parser, shift @ARGV; + } + if(@ARGV and $ARGV[0] eq ":::") { + shift @ARGV; + } + } else { + @options = shift @ARGV; + } + my $script = Q(Q(shift @ARGV)); # TODO - test if script = " " + my @args = map{ Q($_) } @ARGV; + # exec myself to split $ARGV[0] into separate fields + exec "$0 --_pipe-means-argfiles @options @parser $script ". + "::: @args"; + } + } + if($ARGV[0] =~ / --shebang(-?wrap)? /) { + ::warning("--shebang and --shebang-wrap must be the first ". + "argument.\n"); + } + + Getopt::Long::Configure("bundling","require_order"); + my @ARGV_copy = @ARGV; + my @ARGV_orig = @ARGV; + # Check if there is a --profile to set @opt::profile + get_options_from_array(\@ARGV_copy,"profile|J=s","plain") || die_usage(); + my @ARGV_profile = (); + my @ARGV_env = (); + if(not $opt::plain) { + # Add options from $PARALLEL_HOME/config and other profiles + my @config_profiles = ( + "/etc/parallel/config", + (map { "$_/config" } @Global::config_dirs), + $ENV{'HOME'}."/.parallelrc"); + my @profiles = @config_profiles; + if(@opt::profile) { + # --profile overrides default profiles + @profiles = (); + for my $profile (@opt::profile) { + if($profile =~ m:^\./|^/:) { + # Look for ./profile in . + # Look for /profile in / + push @profiles, grep { -r $_ } $profile; + } else { + # Look for the $profile in @Global::config_dirs + push @profiles, grep { -r $_ } + map { "$_/$profile" } @Global::config_dirs; + } + } + } + for my $profile (@profiles) { + if(-r $profile) { + ::debug("init","Read $profile\n"); + local $/ = "\n"; + open (my $in_fh, "<", $profile) || + ::die_bug("read-profile: $profile"); + while(<$in_fh>) { + /^\s*\#/ and next; + chomp; + push @ARGV_profile, shell_words($_); + } + close $in_fh; + } else { + if(grep /^\Q$profile\E$/, @config_profiles) { + # config file is not required to exist + } else { + ::error(255,"$profile not readable."); + } + } + } + # Add options from shell variable $PARALLEL + if($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"); + get_options_from_array(\@ARGV_profile) || die_usage(); + get_options_from_array(\@ARGV_env) || die_usage(); + get_options_from_array(\@ARGV) || die_usage(); + # What were the options given on the command line? + # Used to start --sqlworker + my $ai = arrayindex(\@ARGV_orig, \@ARGV); + @Global::options_in_argv = @ARGV_orig[0..$ai-1]; + # Prepend non-options to @ARGV (such as commands like 'nice') + unshift @ARGV, @ARGV_profile, @ARGV_env; + return @ARGV; +} + +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; + my $i = index($array1_as_string,$array2_as_string,0); + if($i == -1) { return -1 } + my @before = split /\0/, substr($array1_as_string,0,$i); + return $#before; +} + +sub read_args_from_command_line() { + # Arguments given on the command line after: + # ::: ($Global::arg_sep) + # :::: ($Global::arg_file_sep) + # :::+ ($Global::arg_sep with --link) + # ::::+ ($Global::arg_file_sep with --link) + # Removes the arguments from @ARGV and: + # - puts filenames into -a + # - puts arguments into files and add the files to -a + # - adds --linkinputsource with 0/1 for each -a depending on :::+/::::+ + # Input: + # @::ARGV = command option ::: arg arg arg :::: argfiles + # Uses: + # $Global::arg_sep + # $Global::arg_file_sep + # $opt::_pipe_means_argfiles + # $opt::pipe + # @opt::a + # Returns: + # @argv_no_argsep = @::ARGV without ::: and :::: and following args + my %group_sep = ($Global::arg_sep => ":::", + $Global::arg_sep."+" => ":::+", + $Global::arg_file_sep => "::::", + $Global::arg_file_sep."+" => "::::+"); + sub is_linked($) { + # file is linked if file starts with + + local $_ = shift; + if(/^\+(.*)/) { + my $noplus = $1; + if(-e $_ and -e $noplus) { + ::error(255,"It is unclear whether you mean ". + "+./$noplus or ./+$noplus"); + } elsif(-e $_ and not -e $noplus) { + # This is ./+file = this is not linked + return 0; + } elsif(not -e $_ and -e $noplus) { + # This is +./file = this is linked + return 1; + } elsif(not -e $_ and not -e $noplus) { + # File does not exist, maybe it is stdin? + if($_ eq "-") { + # This is - = this is not linked + return 0; + } elsif($_ eq "+-") { + # This is +- = this is linked + return 1; + } else { + ::error(255,"File not found: $_"); + } + } else { + ::die_bug("noplus: $noplus $_"); + } + } + # not linked + return 0; + } + sub cmd_template() { + # remove command template from @ARGV + # keep ::: / :::: in @ARGV if any + my @cmd_template; + while(@ARGV) { + my $arg = shift @ARGV; + if($group_sep{$arg}) { + # Found separator: push it back and exit loop + unshift @ARGV, $arg; + last; + } + push @cmd_template, $arg; + } + return @cmd_template; + } + sub divide_into_groups() { + # Split arguments from @ARGV into groups: + # ::: 1 2 3 :::: a b c ::::+ d e f + # => + # [ ::: 1 2 3 ], [ :::: a b c ], [ ::::+ d e f ] + my @g; + my @grp; + while(@ARGV) { + my $arg = shift @ARGV; + if($group_sep{$arg}) { + # start a new group + push @grp, [@g]; + @g = ($group_sep{$arg}); + } else { + push @g, $arg; + } + } + push @grp, [@g]; + shift @grp; # The first will always be empty + return @grp; + } + sub save_to_file(@) { + # Put args into a file, return open file handle of file + # Create argfile + my ($fh,$name) = ::tmpfile(SUFFIX => ".arg"); + unlink($name); + # Put args into argfile + print $fh map { $_,$/ } @_; + seek $fh, 0, 0; + exit_if_disk_full(); + return $fh; + } + my @cmd = cmd_template(); + # The rest of @ARGV is ::: / :::: args + # If there are any -a: Rewrite them to use :::: + if(@opt::a) { unshift @ARGV, $Global::arg_file_sep, @opt::a; } + @opt::a = (); + # Convert ::: and :::: into (linked) files and put those into @opt::a + for my $g_ref (divide_into_groups()) { + my $group_sep = shift @$g_ref; + if($group_sep eq ":::" or $group_sep eq ":::+") { + # Group starts with ::: / :::+ + if($opt::_pipe_means_argfiles and $#$g_ref < 0) { + # TODO + # Deal with --shebang-wrap and ::: on the shebang line + } else { + push @opt::a, save_to_file(@$g_ref); + # if $group_sep == ":::+": it is linked + push @opt::linkinputsource, ($group_sep eq ":::+"); + } + } elsif($group_sep eq "::::" or $group_sep eq "::::+") { + # Group starts with :::: / ::::+ + for my $f (@$g_ref) { + if($group_sep eq "::::+") { + # Linking forced + push @opt::a, $f; + push @opt::linkinputsource, 1; + } elsif($group_sep eq "::::") { + # Auto detect linking + if(is_linked($f)) { + # +file + push @opt::linkinputsource, 1; + $f =~ s/^\+//; + } else { + # file (no plus) + push @opt::linkinputsource, 0; + } + push @opt::a, $f; + } else { + ::die_bug("arg link error"); + } + } + } else { + ::die_bug("arg link error"); + } + } + # Output: command to run with options + return @cmd; +} + +sub cleanup() { + # Returns: N/A + unlink keys %Global::unlink; + map { rmdir $_ } keys %Global::unlink; + if(@opt::basefile and $opt::cleanup) { cleanup_basefile(); } + for(keys %Global::sshmaster) { + # If 'ssh -M's are running: kill them + kill "TERM", $_; + } +} + + +sub __QUOTING_ARGUMENTS_FOR_SHELL__() {} + +sub shell_quote(@) { + # Input: + # @strings = strings to be quoted + # Returns: + # @shell_quoted_strings = string quoted as needed by the shell + return wantarray ? (map { Q($_) } @_) : (join" ",map { Q($_) } @_); +} + +sub shell_quote_scalar_rc($) { + # Quote for the rc-shell + my $a = $_[0]; + if(defined $a) { + if(($a =~ s/'/''/g) + + + ($a =~ s/[\n\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\<\=\>\~\|\; \"\!\$\&\'\202-\377]+/'$&'/go)) { + # A string was replaced + # No need to test for "" or \0 + } elsif($a eq "") { + $a = "''"; + } elsif($a eq "\0") { + $a = ""; + } + } + return $a; +} + +sub shell_quote_scalar_csh($) { + # Quote for (t)csh + my $a = $_[0]; + if(defined $a) { + # $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 in csh 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 = ""; + } + } + return $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 + local $_ = $_[0]; + if(/[^-_.+a-z0-9\/]/i) { + s/'+/'"$&"'/g; # "-quote '-quotes: ''' => "'''" + $_ = "'$_'"; # '-quote entire string + s/^''//; # Remove unneeded '' at ends + s/''$//; # (faster than s/^''|''$//g) + return $_; + } elsif ($_ eq "") { + return "''"; + } else { + # No quoting needed + return $_; + } +} + +sub shell_quote_scalar($) { + # Quote the string so the shell will not expand any special chars + # Inputs: + # $string = string to be quoted + # Returns: + # $shell_quoted = string quoted as needed by the shell + + # Speed optimization: Choose the correct shell_quote_scalar_* + # and call that directly from now on + no warnings 'redefine'; + if($Global::cshell) { + # (t)csh + *shell_quote_scalar = \&shell_quote_scalar_csh; + } elsif($Global::shell =~ m:(^|/)rc$:) { + # rc-shell + *shell_quote_scalar = \&shell_quote_scalar_rc; + } else { + # other shells + *shell_quote_scalar = \&shell_quote_scalar_default; + } + # The sub is now redefined. Call it + return shell_quote_scalar($_[0]); +} + +sub Q($) { + # Q alias for ::shell_quote_scalar + my $ret = shell_quote_scalar($_[0]); + no warnings 'redefine'; + *Q = \&::shell_quote_scalar; + return $ret; +} + +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 = shift; + if(defined $a) { + if($a =~ m:^/: or $a =~ m:^\./:) { + # /abs/path or ./rel/path => skip + } else { + # rel/path => ./rel/path + $a = "./".$a; + } + } + return Q($a); +} + +sub shell_words(@) { + # Input: + # $string = shell line + # Returns: + # @shell_words = $string split into words as shell would do + $Global::use{"Text::ParseWords"} ||= eval "use Text::ParseWords; 1;"; + return Text::ParseWords::shellwords(@_); +} + +sub perl_quote_scalar($) { + # Quote the string so perl's eval will not expand any special chars + # Inputs: + # $string = string to be quoted + # Returns: + # $perl_quoted = string quoted with \ as needed by perl's eval + my $a = $_[0]; + if(defined $a) { + $a =~ s/[\\\"\$\@]/\\$&/go; + } + return $a; +} + +# -w complains about prototype +sub pQ($) { + # pQ alias for ::perl_quote_scalar + my $ret = perl_quote_scalar($_[0]); + *pQ = \&::perl_quote_scalar; + return $ret; +} + +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; + s/\\r/\r/g; + s/\\(\d\d\d)/eval 'sprintf "\\'.$1.'"'/ge; + s/\\(\d)/eval 'sprintf "\\'.$1.'"'/ge; + return $_; +} + + +sub __FILEHANDLES__() {} + + +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: + # %Global::fh + # $Global::original_stderr + # $Global::original_stdin + # Returns: N/A + + # TODO Disabled until we have an open3 that will take n filehandles + # for my $fdno (1..61) { + # # /dev/fd/62 and above are used by bash for <(cmd) + # # Find file descriptors that are already opened (by the shell) + # Only focus on stdout+stderr for now + for my $fdno (1..2) { + my $fh; + # 2-argument-open is used to be compatible with old perl 5.8.0 + # bug #43570: Perl 5.8.0 creates 61 files + if(open($fh,">&=$fdno")) { + $Global::fh{$fdno}=$fh; + } + } + open $Global::original_stderr, ">&", "STDERR" or + ::die_bug("Can't dup STDERR: $!"); + open $Global::status_fd, ">&", "STDERR" or + ::die_bug("Can't dup STDERR: $!"); + open $Global::original_stdin, "<&", "STDIN" or + ::die_bug("Can't dup STDIN: $!"); +} + +sub enough_file_handles() { + # Check that we have enough filehandles available for starting + # another job + # Uses: + # $opt::ungroup + # %Global::fh + # Returns: + # 1 if ungrouped (thus not needing extra filehandles) + # 0 if too few filehandles + # 1 if enough filehandles + if(not $opt::ungroup) { + my %fh; + my $enough_filehandles = 1; + # perl uses 7 filehandles for something? + # open3 uses 2 extra filehandles temporarily + # We need a filehandle for each redirected file descriptor + # (normally just STDOUT and STDERR) + for my $i (1..(7+2+keys %Global::fh)) { + $enough_filehandles &&= open($fh{$i}, "<", "/dev/null"); + } + for (values %fh) { close $_; } + return $enough_filehandles; + } else { + # Ungrouped does not need extra file handles + return 1; + } +} + +sub open_or_exit($$) { + # Open a file name or exit if the file cannot be opened + # Inputs: + # $mode = read:"<" write:">" + # $file = filehandle or filename to open + # Uses: + # $Global::original_stdin + # Returns: + # $fh = file handle to opened file + my $mode = shift; + my $file = shift; + if($file eq "-") { + if($mode eq "<") { + return ($Global::original_stdin || *STDIN); + } else { + return ($Global::original_stderr || *STDERR); + } + } + if(ref $file eq "GLOB") { + # This is an open filehandle + return $file; + } + my $fh = gensym; + open($fh, $mode, $file) || ::error(255,"Cannot open `$file': $!"); + return $fh; +} + +sub slurp_or_exit($) { + # Read content of a file or exit if the file cannot be opened + # Inputs: + # $file = filehandle or filename to open + # Returns: + # $content = content as scalar + my $fh = open_or_exit("<",shift); + # $/ = undef => slurp whole file + local $/; + my $content = <$fh>; + close $fh; + return $content; +} + +sub write_or_exit(@) { + # Write content to a file or exit if the file cannot be opened + # Inputs: + # $file = filehandle or filename to open + # @content = content to be written + # Returns: + # N/A + my $file = shift; + sub failed { error(255,"Cannot write to `$file': $!"); } + my $fh = open_or_exit(">",$file); + print($fh @_) or failed(); + close($fh) or failed(); +} + +sub set_fh_blocking($) { + # Set filehandle as blocking + # Inputs: + # $fh = filehandle to be blocking + # Returns: + # N/A + my $fh = shift; + $Global::use{"Fcntl"} ||= eval "use Fcntl qw(:DEFAULT :flock); 1;"; + my $flags; + # Get the current flags on the filehandle + fcntl($fh, &F_GETFL, $flags) || die $!; + # Remove non-blocking from the flags + $flags &= ~&O_NONBLOCK; + # Set the flags on the filehandle + fcntl($fh, &F_SETFL, $flags) || die $!; +} + +sub set_fh_non_blocking($) { + # Set filehandle as non-blocking + # Inputs: + # $fh = filehandle to be blocking + # Returns: + # N/A + my $fh = shift; + $Global::use{"Fcntl"} ||= eval "use Fcntl qw(:DEFAULT :flock); 1;"; + my $flags; + # Get the current flags on the filehandle + fcntl($fh, &F_GETFL, $flags) || die $!; + # Add non-blocking to the flags + $flags |= &O_NONBLOCK; + # Set the flags on the filehandle + fcntl($fh, &F_SETFL, $flags) || die $!; +} + + +sub __RUNNING_THE_JOBS_AND_PRINTING_PROGRESS__() {} + + +# Variable structure: +# +# $Global::running{$pid} = Pointer to Job-object +# @Global::virgin_jobs = Pointer to Job-object that have received no input +# $Global::host{$sshlogin} = Pointer to SSHLogin-object +# $Global::total_running = total number of running jobs +# $Global::total_started = total jobs started +# $Global::max_procs_file = filename if --jobs is given a filename +# $Global::JobQueue = JobQueue object for the queue of jobs +# $Global::timeoutq = queue of times where jobs timeout +# $Global::newest_job = Job object of the most recent job started +# $Global::newest_starttime = timestamp of $Global::newest_job +# @Global::sshlogin +# $Global::minimal_command_line_length = min len supported by all sshlogins +# $Global::start_no_new_jobs = should more jobs be started? +# $Global::original_stderr = file handle for STDERR when the program started +# $Global::total_started = total number of jobs started +# $Global::joblog = filehandle of joblog +# $Global::debug = Is debugging on? +# $Global::exitstatus = status code of GNU Parallel +# $Global::quoting = quote the command to run + +sub init_run_jobs() { + # Set Global variables and progress signal handlers + # Do the copying of basefiles + # Returns: N/A + $Global::total_running = 0; + $Global::total_started = 0; + $SIG{USR1} = \&list_running_jobs; + $SIG{USR2} = \&toggle_progress; + if(@opt::basefile) { setup_basefile(); } +} + +{ + my $last_time; + my %last_mtime; + my $max_procs_file_last_mod; + + sub changed_procs_file { + # If --jobs is a file and it is modfied: + # Force recomputing of max_jobs_running for each $sshlogin + # Uses: + # $Global::max_procs_file + # %Global::host + # Returns: N/A + if($Global::max_procs_file) { + # --jobs filename + my $mtime = (stat($Global::max_procs_file))[9]; + $max_procs_file_last_mod ||= 0; + if($mtime > $max_procs_file_last_mod) { + # file changed: Force re-computing max_jobs_running + $max_procs_file_last_mod = $mtime; + for my $sshlogin (values %Global::host) { + $sshlogin->set_max_jobs_running(undef); + } + } + } + } + + sub changed_sshloginfile { + # If --slf is changed: + # reload --slf + # filter_hosts + # setup_basefile + # Uses: + # @opt::sshloginfile + # @Global::sshlogin + # %Global::host + # $opt::filter_hosts + # Returns: N/A + if(@opt::sshloginfile) { + # Is --sshloginfile changed? + for my $slf (@opt::sshloginfile) { + my $actual_file = expand_slf_shorthand($slf); + my $mtime = (stat($actual_file))[9]; + $last_mtime{$actual_file} ||= $mtime; + if($mtime - $last_mtime{$actual_file} > 1) { + ::debug("run", + "--sshloginfile $actual_file changed. reload\n"); + $last_mtime{$actual_file} = $mtime; + # Reload $slf + # Empty sshlogins + @Global::sshlogin = (); + for (values %Global::host) { + # Don't start new jobs on any host + # except the ones added back later + $_->set_max_jobs_running(0); + } + # This will set max_jobs_running on the SSHlogins + read_sshloginfile($actual_file); + parse_sshlogin(); + $opt::filter_hosts and filter_hosts(); + setup_basefile(); + } + } + } + } + + sub start_more_jobs { + # Run start_another_job() but only if: + # * not $Global::start_no_new_jobs set + # * not JobQueue is empty + # * not load on server is too high + # * not server swapping + # * not too short time since last remote login + # Uses: + # %Global::host + # $Global::start_no_new_jobs + # $Global::JobQueue + # $opt::pipe + # $opt::load + # $opt::noswap + # $opt::delay + # $Global::newest_starttime + # Returns: + # $jobs_started = number of jobs started + my $jobs_started = 0; + if($Global::start_no_new_jobs) { + return $jobs_started; + } + if(time - ($last_time||0) > 1) { + # At most do this every second + $last_time = time; + changed_procs_file(); + changed_sshloginfile(); + } + # 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-0.008 > ::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 or $opt::memsuspend) + and + $sshlogin->memfree() < $Global::memlimit) { + # 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 last login + 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; + } +} + +{ + my $no_more_file_handles_warned; + + sub start_another_job() { + # If there are enough filehandles + # and JobQueue not empty + # and not $job is in joblog + # Then grab a job from Global::JobQueue, + # start it at sshlogin + # mark it as virgin_job + # Inputs: + # $sshlogin = the SSHLogin to start the job on + # Uses: + # $Global::JobQueue + # $opt::pipe + # $opt::results + # $opt::resume + # @Global::virgin_jobs + # Returns: + # 1 if another jobs was started + # 0 otherwise + my $sshlogin = shift; + # Do we have enough file handles to start another job? + if(enough_file_handles()) { + if($Global::JobQueue->empty() and not $opt::pipe) { + # No more commands to run + debug("start", "Not starting: JobQueue empty\n"); + return 0; + } else { + my $job; + # Skip jobs already in job log + # Skip jobs already in results + do { + $job = get_job_with_sshlogin($sshlogin); + if(not defined $job) { + # No command available for that sshlogin + debug("start", "Not starting: no jobs available for ", + $sshlogin->string(), "\n"); + return 0; + } + if($job->is_already_in_joblog()) { + $job->free_slot(); + } + } while ($job->is_already_in_joblog() + or + ($opt::results and $opt::resume + and $job->is_already_in_results())); + debug("start", "Command to run on '", + $job->sshlogin()->string(), "': '", + $job->replaced(),"'\n"); + if($job->start()) { + if($opt::pipe) { + if($job->virgin()) { + push(@Global::virgin_jobs,$job); + } else { + # Block already set: This is a retry + $job->write_block(); + } + } + debug("start", "Started as seq ", $job->seq(), + " pid:", $job->pid(), "\n"); + return 1; + } else { + # Not enough processes to run the job. + # Put it back on the queue. + $Global::JobQueue->unget($job); + # Count down the number of jobs to run for this SSHLogin. + my $max = $sshlogin->max_jobs_running(); + if($max > 1) { $max--; } else { + my @arg; + for my $record (@{$job->{'commandline'}{'arg_list'}}) { + push @arg, map { $_->orig() } @$record; + } + ::error(255,"No more processes: ". + "cannot run a single job. ". + "Something is wrong at @arg."); + } + $sshlogin->set_max_jobs_running($max); + # Sleep up to 300 ms to give other processes time to die + ::usleep(rand()*300); + ::warning("No more processes: ". + "Decreasing number of running jobs to $max.", + "Try increasing 'ulimit -u' (try: ulimit -u `ulimit -Hu`)", + "or increasing 'nproc' in /etc/security/limits.conf", + "or increasing /proc/sys/kernel/pid_max"); + return 0; + } + } + } else { + # No more file handles + $no_more_file_handles_warned++ or + ::warning("No more file handles. ", + "Try running 'parallel -j0 -N 100 --pipe parallel -j0'", + "or increasing 'ulimit -n' (try: ulimit -n `ulimit -Hn`)", + "or increasing 'nofile' in /etc/security/limits.conf", + "or increasing /proc/sys/fs/file-max"); + debug("start", "No more file handles. "); + return 0; + } + } +} + +sub init_progress() { + # Uses: + # $opt::bar + # Returns: + # list of computers for progress output + $|=1; + if($opt::bar) { + return("",""); + } + my $progress = progress(); + my $cpu_units = $opt::use_sockets_instead_of_threads ? "CPU sockets" : + ($opt::use_cores_instead_of_threads ? "CPU cores" : "CPU threads"); + return ("\nComputers / $cpu_units / Max jobs to run\n", + $progress->{'workerlist'},"\n",$progress->{'header'}); +} + +sub drain_job_queue(@) { + # Uses: + # $opt::progress + # $Global::total_running + # $Global::max_jobs_running + # %Global::running + # $Global::JobQueue + # %Global::host + # $Global::start_no_new_jobs + # Returns: N/A + my @command = @_; + my $sleep = 0.2; + my $sleepsum = 0; + do { + while($Global::total_running > 0) { + debug("init",$Global::total_running, "==", scalar + keys %Global::running," slots: ", $Global::max_jobs_running); + if($opt::pipe) { + # When using --pipe sometimes file handles are not + # closed properly + for my $job (values %Global::running) { + close $job->fh(0,"w"); + } + } + if($opt::progress) { + my $progress = progress(); + ::status_no_nl("\r",$progress->{'status'}); + } + if($Global::total_running < $Global::max_jobs_running + and not $Global::JobQueue->empty()) { + # These jobs may not be started because of loadavg + # or too little time between each ssh login. + if(start_more_jobs() > 0) { + # Exponential back-on if jobs were started + $sleep = $sleep/2+0.001; + } + } + # Exponential back-off sleeping + $sleep = ::reap_usleep($sleep); + $sleepsum += $sleep; + if($sleepsum >= 1000) { + # At most do this every second + $sleepsum = 0; + changed_procs_file(); + changed_sshloginfile(); + start_more_jobs(); + } + } + if(not $Global::JobQueue->empty()) { + # These jobs may not be started: + # * because there the --filter-hosts has removed all + %Global::host or + ::error(255,"There are no hosts left to run on."); + # * because of loadavg + # * because of too little time between each ssh login. + $sleep = ::reap_usleep($sleep); + start_more_jobs(); + if($Global::max_jobs_running == 0) { + ::warning("There are no job slots available. Increase --jobs."); + } + } + 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; + if(my $pid = fork()) { + $Global::unkilled_sqlworker = $pid; + } else { + # Replace --sql/--sqlandworker with --sqlworker + my @ARGV = (map { s/^--sql(andworker)?$/--sqlworker/; $_ } + @Global::options_in_argv); + # exec the --sqlworker + exec($0,@ARGV,@command); + } + } + } + } while ($Global::total_running > 0 + or + not $Global::start_no_new_jobs and not $Global::JobQueue->empty() + or + $opt::sqlmaster and not $Global::sql->finished()); + $Global::all_jobs_done = 1; + if($opt::progress) { + my $progress = progress(); + ::status("\r".$progress->{'status'}); + } +} + +sub toggle_progress() { + # Turn on/off progress view + # Uses: + # $opt::progress + # Returns: N/A + $opt::progress = not $opt::progress; + if($opt::progress) { + ::status_no_nl(init_progress()); + } +} + +{ + my $last_header; + my $eol; + + sub progress() { + # Uses: + # $opt::bar + # $opt::eta + # %Global::host + # $Global::total_started + # Returns: + # $workerlist = list of workers + # $header = that will fit on the screen + # $status = message that will fit on the screen + if($opt::bar) { + return {"workerlist" => "", "header" => "", "status" => bar()}; + } + my $eta = ""; + my ($status,$header)=("",""); + if($opt::eta) { + my($total, $completed, $left, $pctcomplete, $avgtime, $this_eta) = + compute_eta(); + $eta = sprintf("ETA: %ds Left: %d AVG: %.2fs ", + $this_eta, $left, $avgtime); + } + my $termcols = terminal_columns(); + my @workers = sort keys %Global::host; + my $workerno = 1; + my %wrk; + for my $w (@workers) { + my %i; + $i{'sshlogin'} = $w eq ":" ? "local" : $w; + $i{'no'} = $workerno++; + $i{'ncpu'} = ($Global::host{$w}->ncpus() || "-"); + $i{'jobslots'} = $Global::host{$w}->max_jobs_running(); + $i{'completed'} = ($Global::host{$w}->jobs_completed() || 0); + $i{'running'} = $Global::host{$w}->jobs_running(); + $i{'pct'} = $Global::total_started ? + (($i{'running'}+$i{'completed'})*100 / + $Global::total_started) : 0; + $i{'time'} = $i{'completed'} ? (time-$^T)/($i{'completed'}) : 0; + $wrk{$w} = \%i; + } + + my $workerlist = ""; + for my $w (@workers) { + $workerlist .= + $wrk{$w}{'no'}.":".$wrk{$w}{'sshlogin'} ." / ". + $wrk{$w}{'ncpu'}." / ". + $wrk{$w}{'jobslots'}."\n"; + } + # Force $status to select one of the below formats + $status = "c"x($termcols+1); + # Select an output format that will fit on a single line + if(length $status > $termcols) { + # sshlogin1:XX/XX/XX%/XX.Xs s2:XX/XX/XX%/XX.Xs s3:XX/XX/XX%/XX.Xs + $header = "Computer:jobs running/jobs completed/". + "%of started jobs/Average seconds to complete"; + $status = $eta . join(" ",map { + sprintf("%s:%d/%d/%d%%/%.1fs ", + @{$wrk{$_}} + {'sshlogin','running','completed','pct','time'} + ); } @workers); + } + if(length $status > $termcols) { + # 1:XX/XX/XX%/X.Xs 2:XX/XX/XX%/X.Xs 3:XX/XX/XX%/X.Xs + $header = "Computer:jobs running/jobs completed/%of started jobs"; + $status = $eta . join(" ",map { + sprintf("%s:%d/%d/%d%%/%.1fs ", + @{$wrk{$_}} + {'no','running','completed','pct','time'} + ); } @workers); + } + if(length $status > $termcols) { + # sshlogin1:XX/XX/XX% sshlogin2:XX/XX/XX% sshlogin3:XX/XX/XX% + $header = "Computer:jobs running/jobs completed/%of started jobs"; + $status = $eta . join(" ",map { + sprintf("%s:%d/%d/%d%%", + @{$wrk{$_}} + {'sshlogin','running','completed','pct'} + ); } @workers); + } + if(length $status > $termcols) { + # 1:XX/XX/XX% 2:XX/XX/XX% 3:XX/XX/XX% 4:XX/XX/XX% 5:XX/XX/XX% + $header = "Computer:jobs running/jobs completed/%of started jobs"; + $status = $eta . join(" ",map { + sprintf("%s:%d/%d/%d%%", + @{$wrk{$_}} + {'no','running','completed','pct'} + ); } @workers); + } + if(length $status > $termcols) { + # sshlogin1:XX/XX sshlogin2:XX/XX sshlogin3:XX/XX + $header = "Computer:jobs running/jobs completed"; + $status = $eta . join(" ", map { + sprintf("%s:%d/%d", + @{$wrk{$_}} + {'sshlogin','running','completed'} + ); } @workers); + } + if(length $status > $termcols) { + # 1:XX/XX 2:XX/XX 3:XX/XX 4:XX/XX 5:XX/XX 6:XX/XX + $header = "Computer:jobs running/jobs completed"; + $status = $eta . join(" ", map { + sprintf("%s:%d/%d", + @{$wrk{$_}} + {'no','running','completed'} + ); } @workers); + } + if(length $status > $termcols) { + # sshlogin1:XX sshlogin2:XX sshlogin3:XX sshlogin4:XX sshlogin5:XX + $header = "Computer:jobs completed"; + $status = $eta . join(" ", map { + sprintf("%s:%d", + @{$wrk{$_}} + {'sshlogin','completed'} + ); } @workers); + } + if(length $status > $termcols) { + # 1:XX 2:XX 3:XX 4:XX 5:XX 6:XX + $header = "Computer:jobs completed"; + $status = $eta . join(" ", map { + sprintf("%s:%d", + @{$wrk{$_}} + {'no','completed'} + ); } @workers); + } + if($last_header ne $header) { + $header .= "\n"; + $last_header = $header; + } else { + $header = ""; + } + if(not $eol) { + $eol = `sh -c "tput el /dev/null`; + chomp($eol); + if($eol eq "") { $eol = "\033[K"; } + } + + return {"workerlist" => $workerlist, "header" => $header, + "status" => $status.$eol}; + } +} + +{ + + my ($first_completed, $smoothed_avg_time, $last_eta); + + sub compute_eta { + # Calculate important numbers for ETA + # Returns: + # $total = number of jobs in total + # $completed = number of jobs completed + # $left = number of jobs left + # $pctcomplete = percent of jobs completed + # $avgtime = averaged time + # $eta = smoothed eta + 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 = ::min($completed / $total,100); + $first_completed ||= time; + my $timepassed = (time - $first_completed); + my $avgtime = $timepassed / $completed; + $smoothed_avg_time ||= $avgtime; + # Smooth the eta so it does not jump wildly + $smoothed_avg_time = (1 - $pctcomplete) * $smoothed_avg_time + + $pctcomplete * $avgtime; + my $eta = int($left * $smoothed_avg_time); + if($eta*0.90 < $last_eta and $last_eta < $eta) { + # Eta jumped less that 10% up: Keep the last eta instead + $eta = $last_eta; + } else { + $last_eta = $eta; + } + return($total, $completed, $left, $pctcomplete, $avgtime, $eta); + } +} + +{ + my ($rev,$reset); + + sub bar() { + # Return: + # $status = bar with eta, completed jobs, arg and pct + $rev ||= "\033[7m"; + $reset ||= "\033[0m"; + my($total, $completed, $left, $pctcomplete, $avgtime, $eta) = + compute_eta(); + if($Global::all_jobs_done) { $eta = now()-$Global::start_time; } + my $arg = $Global::newest_job ? + $Global::newest_job->{'commandline'}-> + replace_placeholders(["\257<\257>"],0,0) : ""; + $arg = decode_utf8($arg); + my $eta_dhms = ::seconds_to_time_units($eta); + my $bar_text = + sprintf("%d%% %d:%d=%s %s", + $pctcomplete*100, $completed, $left, $eta_dhms, $arg); + my $terminal_width = terminal_columns(); + my $s = sprintf("%-${terminal_width}s", + substr($bar_text." "x$terminal_width, + 0,$terminal_width)); + my $width = int($terminal_width * $pctcomplete); + substr($s,$width,0) = $reset; + my $zenity = sprintf("%-${terminal_width}s", + substr("# $eta sec $arg", + 0,$terminal_width)); + # Prefix with zenity header + $s = "\r" . $zenity . "\r" . $pctcomplete*100 . + "\r" . $rev . $s . $reset; + return $s; + } +} + +{ + my ($rows,$columns,$last_update_time); + + sub compute_terminal_size() { + # && true is to force spawning a shell and not just exec'ing + my @tput = qx{ tput lines cols /dev/null && true }; + $rows = 0 + $tput[0]; + $columns = 0 + $tput[1]; + if(not ($rows && $columns)) { + # && true is to force spawning a shell and not just exec'ing + my $stty = qx{ stty -a /dev/null && true }; + # FreeBSD/OpenBSD/NetBSD/Dragonfly/MirOS + # MacOSX/IRIX/AIX/Tru64 + $stty =~ /(\d+) columns/ and do { $columns = $1; }; + $stty =~ /(\d+) rows/ and do { $rows = $1; }; + # GNU/Linux/Solaris + $stty =~ /columns (\d+)/ and do { $columns = $1; }; + $stty =~ /rows (\d+)/ and do { $rows = $1; }; + # Solaris-x86/HPUX/SCOsysV/UnixWare/OpenIndiana + $stty =~ /columns = (\d+)/ and do { $columns = $1; }; + $stty =~ /rows = (\d+)/ and do { $rows = $1; }; + # QNX + $stty =~ /rows=(\d+),(\d+)/ and do { ($rows,$columns) = ($1,$2); }; + } + if(not ($rows && $columns)) { + # && true is to force spawning a shell and not just exec'ing + my $resize = qx{ resize 2>/dev/null && true }; + $resize =~ /COLUMNS=(\d+);/ and do { $columns ||= $1; }; + $resize =~ /LINES=(\d+);/ and do { $rows ||= $1; }; + } + $rows ||= 24; + $columns ||= 80; + } + + sub update_terminal_size() { + # Only update once per second. + if($last_update_time < time) { + $last_update_time = time; + compute_terminal_size(); + # Set signal WINdow CHange to force recompute + $SIG{WINCH} = \&compute_terminal_size; + } + } + + sub terminal_rows() { + # Get the number of rows of the terminal. + # Returns: + # number of rows of the screen + update_terminal_size(); + return $rows; + } + + sub terminal_columns() { + # Get the number of columns of the terminal. + # Returns: + # number of columns of the screen + update_terminal_size(); + return $columns; + } +} + +sub untabify($) { + # Convert \t into spaces + my @out; + my ($src); + # Deal with multi-byte characters + for my $src (split("\t",$_[0])) { + push @out, $src. " "x(8-mbswidth($src)%8); + } + return join "",@out; +} + +# Prototype forwarding +sub get_job_with_sshlogin($); +sub get_job_with_sshlogin($) { + # Input: + # $sshlogin = which host should the job be run on? + # Uses: + # $opt::hostgroups + # $Global::JobQueue + # Returns: + # $job = next job object for $sshlogin if any available + my $sshlogin = shift; + my $job; + + if ($opt::hostgroups) { + my @other_hostgroup_jobs = (); + + while($job = $Global::JobQueue->get()) { + if($sshlogin->in_hostgroups($job->hostgroups())) { + # Found a job to be run on a hostgroup of this + # $sshlogin + last; + } else { + # This job was not in the hostgroups of $sshlogin + push @other_hostgroup_jobs, $job; + } + } + $Global::JobQueue->unget(@other_hostgroup_jobs); + if(not defined $job) { + # No more jobs + return undef; + } + } else { + $job = $Global::JobQueue->get(); + if(not defined $job) { + # No more jobs + ::debug("start", "No more jobs: JobQueue empty\n"); + return undef; + } + } + if(not $job->suspended()) { + $job->set_sshlogin($sshlogin); + } + if(defined $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 + if($no_of_failed_sshlogins == + grep { $_->max_jobs_running() > 0 } values %Global::host + and $job->failed_here() == $min_failures) { + # It failed the same or more times on another host: + # run it on this host + } else { + # If it failed fewer times on another host: + # Find another job to run + my $nextjob; + if(not $Global::JobQueue->empty()) { + # This can potentially recurse for all args + no warnings 'recursion'; + $nextjob = get_job_with_sshlogin($sshlogin); + } + # Push the command back on the queue + $Global::JobQueue->unget($job); + return $nextjob; + } + } + return $job; +} + + +sub __REMOTE_SSH__() {} + + +sub read_sshloginfiles(@) { + # Read a list of --slf's + # Input: + # @files = files or symbolic file names to read + # Returns: N/A + for my $s (@_) { + read_sshloginfile(expand_slf_shorthand($s)); + } +} + +sub expand_slf_shorthand($) { + # Expand --slf shorthand into a read file name + # Input: + # $file = file or symbolic file name to read + # Returns: + # $file = actual file name to read + my $file = shift; + if($file eq "-") { + # skip: It is stdin + } elsif($file eq "..") { + $file = $Global::config_dir."/sshloginfile"; + } elsif($file eq ".") { + $file = "/etc/parallel/sshloginfile"; + } elsif(not -r $file) { + for(@Global::config_dirs) { + if(not -r $_."/".$file) { + # Try prepending $PARALLEL_HOME + ::error(255,"Cannot open $file."); + } else { + $file = $_."/".$file; + last; + } + } + } + return $file; +} + +sub read_sshloginfile($) { + # Read sshloginfile into @Global::sshlogin + # Input: + # $file = file to read + # Uses: + # @Global::sshlogin + # Returns: N/A + local $/ = "\n"; + my $file = shift; + my $close = 1; + my $in_fh; + ::debug("init","--slf ",$file); + if($file eq "-") { + $in_fh = *STDIN; + $close = 0; + } else { + $in_fh = open_or_exit("<", $file); + } + while(<$in_fh>) { + chomp; + /^\s*#/ and next; + /^\s*$/ and next; + push @Global::sshlogin, $_; + } + if($close) { + close $in_fh; + } +} + +sub parse_sshlogin() { + # Parse @Global::sshlogin into %Global::host. + # Keep only hosts that are in one of the given ssh hostgroups. + # Uses: + # @Global::sshlogin + # $Global::minimal_command_line_length + # %Global::host + # $opt::transfer + # @opt::return + # $opt::cleanup + # @opt::basefile + # @opt::trc + # Returns: N/A + sub expand_range($) { + # Expand host[9-11,15]a[09-11]b + # [9-11,15] => 9 10 11 15 + # [09-11] => 09 10 11 + my ($in) = @_; + my ($prefix, $range, $suffix); + if(($prefix, $range, $suffix) = $in =~ /^(.*?)\[([-0-9,]*)\](.*)$/) { + my @res; + while(length $range) { + if($range =~ s/^,//) { + # skip + } elsif($range =~ s/^(\d+)-(\d+)//) { + my ($start, $end) = ($1, $2); + push @res, map { $prefix . $_ . $suffix } $start..$end; + } elsif($range =~ s/^(\d+)//) { + push @res, map { $prefix . $_ . $suffix } $1; + } else { + die "Cannot parse $in (at $range)"; + } + } + return map { expand_range($_) } @res; + } else { + return $in; + } + } + my @login; + if(not @Global::sshlogin) { @Global::sshlogin = (":"); } + for my $sshlogin (@Global::sshlogin) { + # Split up -S sshlogin,sshlogin + # Parse ,, and \, as , but do not split on that + # -S "ssh -J jump1,,jump2 host1,host2" => + # ssh -J jump1,jump2 host1 + # host2 + # Protect \, and ,, as \0 + $sshlogin =~ s/\\,|,,/\0/g; + # Protect , in ranges: [___,___] => [___\0___] + while($sshlogin =~ s/(\[[-0-9\0]*),(.*\])/$1\0$2/g) {} + for my $s (split /,|\n/, $sshlogin) { + # Replace \0 => , + $s =~ s/\0/,/g; + if ($s eq ".." or $s eq "-") { + # This may add to @Global::sshlogin - possibly bug + read_sshloginfile(expand_slf_shorthand($s)); + } else { + $s =~ s/\s*$//; + # Expand host[1-12,15]a[01-10]b + push @login, expand_range($s); + } + } + } + $Global::minimal_command_line_length = 100_000_000; + my @allowed_hostgroups; + for my $ncpu_sshlogin_string (::uniq(@login)) { + my $sshlogin = SSHLogin->new($ncpu_sshlogin_string); + my $sshlogin_string = $sshlogin->string(); + if($sshlogin_string eq "") { + # This is an ssh group: -S @webservers + push @allowed_hostgroups, $sshlogin->hostgroups(); + next; + } + if($Global::host{$sshlogin_string}) { + # This sshlogin has already been added: + # It is probably a host that has come back + # Set the max_jobs_running back to the original + debug("run","Already seen $sshlogin_string\n"); + if($sshlogin->{'ncpus'}) { + # If ncpus set by '#/' of the sshlogin, overwrite it: + $Global::host{$sshlogin_string}->set_ncpus($sshlogin->ncpus()); + } + $Global::host{$sshlogin_string}->set_max_jobs_running(undef); + next; + } + $sshlogin->set_maxlength(Limits::Command::max_length()); + + $Global::minimal_command_line_length = + ::min($Global::minimal_command_line_length, $sshlogin->maxlength()); + $Global::host{$sshlogin_string} = $sshlogin; + } + $Global::usable_command_line_length = + # Usable len = maxlen - 3000 for wrapping, div 2 for hexing + int(($Global::minimal_command_line_length - 3000)/2); + if($opt::max_chars) { + if($opt::max_chars <= $Global::usable_command_line_length) { + $Global::usable_command_line_length = $opt::max_chars; + } else { + ::warning("Value for option -s should be < ". + $Global::usable_command_line_length."."); + } + } + if(@allowed_hostgroups) { + # Remove hosts that are not in these groups + while (my ($string, $sshlogin) = each %Global::host) { + if(not $sshlogin->in_hostgroups(@allowed_hostgroups)) { + delete $Global::host{$string}; + } + } + } + + # debug("start", "sshlogin: ", my_dump(%Global::host),"\n"); + if(@Global::transfer_files or @opt::return + or $opt::cleanup or @opt::basefile) { + if(not remote_hosts()) { + # There are no remote hosts + if(@opt::trc) { + ::warning("--trc ignored as there are no remote --sshlogin."); + } elsif (defined $opt::transfer) { + ::warning("--transfer ignored as there are ". + "no remote --sshlogin."); + } elsif (@opt::transfer_files) { + ::warning("--transferfile ignored as there ". + "are no remote --sshlogin."); + } elsif (@opt::return) { + ::warning("--return ignored as there are no remote --sshlogin."); + } elsif (defined $opt::cleanup and not %opt::template) { + ::warning("--cleanup ignored as there ". + "are no remote --sshlogin."); + } elsif (@opt::basefile) { + ::warning("--basefile ignored as there ". + "are no remote --sshlogin."); + } + } + } +} + +sub remote_hosts() { + # Return sshlogins that are not ':' + # Uses: + # %Global::host + # Returns: + # list of sshlogins with ':' removed + return grep !/^:$/, keys %Global::host; +} + +sub setup_basefile() { + # Transfer basefiles to each $sshlogin + # This needs to be done before first jobs on $sshlogin is run + # Uses: + # %Global::host + # @opt::basefile + # Returns: N/A + my @cmd; + my $rsync_destdir; + my $workdir; + for my $sshlogin (values %Global::host) { + if($sshlogin->local()) { next } + for my $file (@opt::basefile) { + if($file !~ m:^/: and $opt::workdir eq "...") { + ::error(255,"Work dir '...' will not work with ". + "relative basefiles."); + } + if(not $workdir) { + my $dummycmdline = + CommandLine->new(1,["true"],{},0,0,[],[],[],[],{},{}); + my $dummyjob = Job->new($dummycmdline); + $workdir = $dummyjob->workdir(); + } + push @cmd, $sshlogin->rsync_transfer_cmd($file,$workdir); + } + } + debug("init", "basesetup: @cmd\n"); + my ($exitstatus,$stdout_ref,$stderr_ref) = + run_gnu_parallel((join "\n",@cmd),"-j0","--retries",5); + if($exitstatus) { + my @stdout = @$stdout_ref; + my @stderr = @$stderr_ref; + ::error(255,"Copying of --basefile failed: @stdout@stderr"); + } +} + +sub cleanup_basefile() { + # Remove the basefiles transferred + # Uses: + # %Global::host + # @opt::basefile + # Returns: N/A + my @cmd; + my $workdir; + if(not $workdir) { + my $dummycmdline = CommandLine->new(1,["true"],{},0,0,[],[],[],[],{},{}); + my $dummyjob = Job->new($dummycmdline); + $workdir = $dummyjob->workdir(); + } + for my $sshlogin (values %Global::host) { + if($sshlogin->local()) { next } + for my $file (@opt::basefile) { + push @cmd, $sshlogin->cleanup_cmd($file,$workdir); + } + } + debug("init", "basecleanup: @cmd\n"); + my ($exitstatus,$stdout_ref,$stderr_ref) = + run_gnu_parallel(join("\n",@cmd),"-j0","--retries",5); + if($exitstatus) { + my @stdout = @$stdout_ref; + my @stderr = @$stderr_ref; + ::error(255,"Cleanup of --basefile failed: @stdout@stderr"); + } +} + +sub run_gnu_parallel() { + my ($stdin,@args) = @_; + my $cmd = join "",map { " $_ & " } split /\n/, $stdin; + print $Global::original_stderr ` $cmd wait` ; + return 0 +} + +sub _run_gnu_parallel() { + # Run GNU Parallel + # This should ideally just fork an internal copy + # and not start it through a shell + # Input: + # $stdin = data to provide on stdin for GNU Parallel + # @args = command line arguments + # Returns: + # $exitstatus = exitcode of GNU Parallel run + # \@stdout = standard output + # \@stderr = standard error + my ($stdin,@args) = @_; + my ($exitstatus,@stdout,@stderr); + my ($stdin_fh,$stdout_fh)=(gensym(),gensym()); + my ($stderr_fh, $stderrname) = ::tmpfile(SUFFIX => ".par"); + unlink $stderrname; + + my $pid = ::open3($stdin_fh,$stdout_fh,$stderr_fh, + $0,qw(--plain --shell /bin/sh --will-cite), @args); + if(my $writerpid = fork()) { + close $stdin_fh; + @stdout = <$stdout_fh>; + # Now stdout is closed: + # These pids should be dead or die very soon + while(kill 0, $writerpid) { ::usleep(1); } + die; +# reap $writerpid; +# while(kill 0, $pid) { ::usleep(1); } +# reap $writerpid; + $exitstatus = $?; + seek $stderr_fh, 0, 0; + @stderr = <$stderr_fh>; + close $stdout_fh; + close $stderr_fh; + } else { + close $stdout_fh; + close $stderr_fh; + print $stdin_fh $stdin; + close $stdin_fh; + exit(0); + } + return ($exitstatus,\@stdout,\@stderr); +} + +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 ($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."); + + $Global::minimal_command_line_length = 100_000_000; + while (my ($string, $sshlogin) = each %Global::host) { + if($sshlogin->local()) { next } + my ($nsockets,$ncores,$nthreads,$time_to_login,$maxlen) = + ($nsockets_ref->{$string},$ncores_ref->{$string}, + $nthreads_ref->{$string},$time_to_login_ref->{$string}, + $maxlen_ref->{$string}); + defined $nsockets or ::die_bug("nsockets missing: $string"); + defined $ncores or ::die_bug("ncores missing: $string"); + defined $nthreads or ::die_bug("nthreads missing: $string"); + defined $time_to_login or ::die_bug("time_to_login missing: $string"); + defined $maxlen or ::die_bug("maxlen missing: $string"); + # ncpus may be set by 4/hostname or may be undefined yet + my $ncpus = $sshlogin->{'ncpus'}; + # $nthreads may be 0 if GNU Parallel is not installed remotely + $ncpus = $nthreads || $ncpus || $sshlogin->ncpus(); + if($opt::use_cpus_instead_of_cores) { + $ncpus = $ncores || $ncpus; + } elsif($opt::use_sockets_instead_of_threads) { + $ncpus = $nsockets || $ncpus; + } elsif($opt::use_cores_instead_of_threads) { + $ncpus = $ncores || $ncpus; + } + $sshlogin->set_ncpus($ncpus); + $sshlogin->set_time_to_login($time_to_login); + $maxlen = $maxlen || Limits::Command::max_length(); + $sshlogin->set_maxlength($maxlen); + ::debug("init", "Timing from -S:$string ", + " ncpus:", $ncpus, + " nsockets:",$nsockets, + " ncores:", $ncores, + " nthreads:",$nthreads, + " time_to_login:", $time_to_login, + " maxlen:", $maxlen, + " min_max_len:", $Global::minimal_command_line_length,"\n"); + } +} + +sub parse_host_filtering() { + # Input: + # @lines = output from parallelized_host_filtering() + # Returns: + # \%nsockets = number of sockets of {host} + # \%ncores = number of cores 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 (%nsockets, %ncores, %nthreads, %time_to_login, %maxlen, %echo, + @down_hosts); + for (@_) { + ::debug("init","Read: ",$_); + chomp; + my @col = split /\t/, $_; + if($col[0] =~ /^parallel: Warning:/) { + # Timed out job: Ignore it + next; + } elsif(defined $col[6]) { + # This is a line from --joblog + # seq host time spent sent received exit signal command + # 2 : 1372607672.654 0.675 0 0 0 0 eval true\ m\;ssh\ m\ parallel\ --number-of-cores + if($col[0] eq "Seq" and $col[1] eq "Host" and + $col[2] eq "Starttime") { + # Header => skip + next; + } + # Get server from: eval true server\; + $col[8] =~ /eval .?true.?\s([^\;]+);/ or + ::die_bug("col8 does not contain host: $col[8] in $_"); + my $host = $1; + $host =~ tr/\\//d; + $Global::host{$host} or next; + if($col[6] eq "255" or $col[6] eq "-1" or $col[6] eq "1") { + # exit == 255 or exit == timeout (-1): ssh failed/timedout + # exit == 1: lsh failed + # Remove sshlogin + ::debug("init", "--filtered $host\n"); + push(@down_hosts, $host); + } elsif($col[6] eq "127") { + # signal == 127: parallel not installed remote + # Set nsockets, ncores, nthreads = 1 + ::warning("Could not figure out ". + "number of cpus on $host. Using 1."); + $nsockets{$host} = 1; + $ncores{$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 + # 2 : 1372607672.654 0.675 0 0 0 0 eval true\ m\;ssh\ m\ echo + $time_to_login{$host} = ::min($time_to_login{$host},$col[3]); + } else { + ::die_bug("host check unmatched long jobline: $_"); + } + } elsif($Global::host{$col[0]}) { + # This output from --number-of-cores, --number-of-cpus, + # --max-line-length-allowed + # ncores: server 8 + # ncpus: server 2 + # maxlen: server 131071 + if(/parallel: Warning: Cannot figure out number of/) { + next; + } + if(/\t(perl: warning:|LANGUAGE =|LC_ALL =|LANG =|are supported and installed|Disconnected from|Received disconnect from)/ + or + /\tWarning: / + or + /\t(Host key fingerprint is|\+-.*-\+|\|.*\|)/ + or + /\t\S+: Undefined variable./ + ) { + # Skip these (from perl): + # perl: warning: Setting locale failed. + # perl: warning: Please check that your locale settings: + # LANGUAGE = (unset), + # LC_ALL = (unset), + # LANG = "en_US.UTF-8" + # are supported and installed on your system. + # perl: warning: Falling back to the standard locale ("C"). + # Disconnected from 127.0.0.1 port 22 + # + # Skip these (from ssh): + # Warning: Permanently added * to the list of known hosts. + # Warning: Identity file * not accessible: * + # (VisualHostKey=yes) + # Host key fingerprint is SHA256:... + # +--[ED25519 256]--+ + # | o | + # +----[SHA256]-----+ + # + # Skip these (from csh): + # MANPATH: Undefined variable. + } elsif(not defined $nsockets{$col[0]}) { + $nsockets{$col[0]} = $col[1]; + } elsif(not defined $ncores{$col[0]}) { + $ncores{$col[0]} = $col[1]; + } elsif(not defined $nthreads{$col[0]}) { + $nthreads{$col[0]} = $col[1]; + } elsif(not defined $maxlen{$col[0]}) { + $maxlen{$col[0]} = $col[1]; + } elsif(not defined $echo{$col[0]}) { + $echo{$col[0]} = $col[1]; + } else { + ::die_bug("host check too many col0: $_"); + } + } else { + ::die_bug("host check unmatched short jobline ($col[0]): $_"); + } + } + @down_hosts = uniq(@down_hosts); + return(\%nsockets, \%ncores, \%nthreads, \%time_to_login, + \%maxlen, \%echo, \@down_hosts); +} + +sub parallelized_host_filtering() { + # Uses: + # %Global::host + # Returns: + # text entries with: + # * joblog line + # * hostname \t number of cores + # * hostname \t number of cpus + # * hostname \t max-line-length-allowed + # * hostname \t empty + + sub sshwrapped { + # Wrap with ssh and --env + # Return $default_value if command fails + my $sshlogin = shift; + my $command = shift; + # wrapper that returns output "0\n" if the command fails + # E.g. parallel not installed => "0\n" + my $wcmd = q(perl -e '$a=`).$command.q(`; print $? ? "0".v010 : $a'); + my $commandline = CommandLine->new(1,[$wcmd],{},0,0,[],[],[],[],{},{}); + my $job = Job->new($commandline); + $job->set_sshlogin($sshlogin); + $job->wrapped(); + return($job->{'wrapped'}); + } + + 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(@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 + push(@echo, $host."\t"."true $host; ". + $sshlogin->wrap("echo $host")."\n\0"); + } + # --timeout 10: Setting up an SSH connection and running a simple + # command should never take > 10 sec. + # --delay 0.1: If multiple sshlogins use the same proxy the delay + # will make it less likely to overload the ssh daemon. + # --retries 3: If the ssh daemon is overloaded, try 3 times + 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 ".Q($cmd); + ::debug("init", $cmd, "\n"); + my @out; + my $prepend = ""; + + my ($host_fh,$in,$err); + open3($in, $host_fh, $err, $cmd) || ::die_bug("parallel host check: $cmd"); + ::debug("init", map { $_,"\n" } @sockets, @cores, @threads, @maxline, @echo); + + if(not fork()) { + # Give the commands to run to the $cmd + close $host_fh; + print $in @sockets, @cores, @threads, @maxline, @echo; + close $in; + exit(); + } + close $in; + # If -0: $/ must be \n + local $/ = "\n"; + for(<$host_fh>) { + # 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, $_; + } + close $host_fh; + return @out; +} + +sub onall($@) { + # Runs @command on all hosts. + # Uses parallel to run @command on each host. + # --jobs = number of hosts to run on simultaneously. + # For each host a parallel command with the args will be running. + # Uses: + # $Global::debug + # $Global::exitstatus + # $Global::joblog + # $Global::quoting + # $opt::D + # $opt::arg_file_sep + # $opt::arg_sep + # $opt::colsep + # $opt::files + # $opt::files0 + # $opt::group + # $opt::joblog + # $opt::jobs + # $opt::keeporder + # $opt::linebuffer + # $opt::max_chars + # $opt::plain + # $opt::retries + # $opt::tag + # $opt::tee + # $opt::timeout + # $opt::ungroup + # %Global::host + # @opt::basefile + # @opt::env + # @opt::v + # Input: + # @command = command to run on all hosts + # Returns: N/A + sub tmp_joblog { + # Input: + # $joblog = filename of joblog - undef if none + # Returns: + # $tmpfile = temp file for joblog - undef if none + my $joblog = shift; + if(not defined $joblog) { + return undef; + } + my ($fh, $tmpfile) = ::tmpfile(SUFFIX => ".log"); + close $fh; + return $tmpfile; + } + my ($input_source_fh_ref,@command) = @_; + if($Global::quoting) { + @command = shell_quote(@command); + } + + # Copy all @input_source_fh (-a and :::) into tempfiles + my @argfiles = (); + for my $fh (@$input_source_fh_ref) { + my ($outfh, $name) = ::tmpfile(SUFFIX => ".all", UNLINK => not $opt::D); + print $outfh (<$fh>); + close $outfh; + push @argfiles, $name; + } + if(@opt::basefile) { setup_basefile(); } + # for each sshlogin do: + # parallel -S $sshlogin $command :::: @argfiles + # + # Pass some of the options to the sub-parallels, not all of them as + # -P should only go to the first, and -S should not be copied at all. + my $options = + join(" ", + ((defined $opt::sshdelay) ? "--delay ".$opt::sshdelay : ""), + ((defined $opt::memfree) ? "--memfree ".$opt::memfree : ""), + ((defined $opt::memsuspend) ? "--memfree ".$opt::memsuspend : ""), + ((defined $opt::D) ? "-D $opt::D" : ""), + ((defined $opt::group) ? "--group" : ""), + ((defined $opt::jobs) ? "-P $opt::jobs" : ""), + ((defined $opt::keeporder) ? "--keeporder" : ""), + ((defined $opt::linebuffer) ? "--linebuffer" : ""), + ((defined $opt::max_chars) ? "--max-chars ".$opt::max_chars : ""), + ((defined $opt::plain) ? "--plain" : ""), + (($opt::ungroup == 1) ? "-u" : ""), + ((defined $opt::tee) ? "--tee" : ""), + ); + my $suboptions = + join(" ", + ((defined $opt::sshdelay) ? "--delay ".$opt::sshdelay : ""), + ((defined $opt::D) ? "-D $opt::D" : ""), + ((defined $opt::arg_file_sep) ? "--arg-file-sep ".$opt::arg_file_sep : ""), + ((defined $opt::arg_sep) ? "--arg-sep ".$opt::arg_sep : ""), + ((defined $opt::colsep) ? "--colsep ".shell_quote($opt::colsep) : ""), + ((defined $opt::files) ? "--files" : ""), + ((defined $opt::files0) ? "--files0" : ""), + ((defined $opt::group) ? "--group" : ""), + ((defined $opt::cleanup) ? "--cleanup" : ""), + ((defined $opt::keeporder) ? "--keeporder" : ""), + ((defined $opt::linebuffer) ? "--linebuffer" : ""), + ((defined $opt::max_chars) ? "--max-chars ".$opt::max_chars : ""), + ((defined $opt::plain) ? "--plain" : ""), + ((defined $opt::plus) ? "--plus" : ""), + ((defined $opt::retries) ? "--retries ".$opt::retries : ""), + ((defined $opt::timeout) ? "--timeout ".$opt::timeout : ""), + (($opt::ungroup == 1) ? "-u" : ""), + ((defined $opt::ssh) ? "--ssh '".$opt::ssh."'" : ""), + ((defined $opt::tee) ? "--tee" : ""), + ((defined $opt::workdir) ? "--wd ".Q($opt::workdir) : ""), + (@Global::transfer_files ? map { "--tf ".Q($_) } + @Global::transfer_files : ""), + (@Global::ret_files ? map { "--return ".Q($_) } + @Global::ret_files : ""), + (@opt::env ? map { "--env ".Q($_) } @opt::env : ""), + (map { "-v" } @opt::v), + ); + ::debug("init", "| $0 $options\n"); + 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) { + my $sshlogin = $Global::host{$host}; + my $qsshlogin = Q($sshlogin->string()); + my $joblog = tmp_joblog($opt::joblog); + if($joblog) { + push @joblogs, $joblog; + $joblog = "--joblog ".::Q($joblog); + } + my $quad = $opt::arg_file_sep || "::::"; + # If PARALLEL_ENV is set: Pass it on + my $penv=$Global::parallel_env ? + "PARALLEL_ENV=".Q($Global::parallel_env) : + ''; + my $results; + if(defined $opt::results) { + $results = Q($opt::results) . $qsshlogin; + } + ::debug("init", "$penv $0 $suboptions -j1 $joblog ", + ((defined $opt::tag) ? "--tagstring ".$qsshlogin : ""), + ((defined $opt::results) ? "--results ".$results : ""), + " -S $qsshlogin ", + join(" ",shell_quote(@command,$quad,@argfiles)),"\n"); + print $parallel_fh "$penv $0 $suboptions -j1 $joblog ", + ((defined $opt::tag) ? "--tagstring ".$qsshlogin : ""), + ((defined $opt::results) ? "--results ".$results : ""), + " -S $qsshlogin ", + join(" ",shell_quote(@command,$quad,@argfiles)),"\0"; + } + close $parallel_fh; + $Global::exitstatus = $? >> 8; + debug("init", "--onall exitvalue ", $?); + if(@opt::basefile and $opt::cleanup) { cleanup_basefile(); } + $Global::debug or unlink(@argfiles); + my %seen; + for my $joblog (@joblogs) { + # Append to $joblog + my $fh = open_or_exit("<", $joblog); + # Skip first line (header); + <$fh>; + print $Global::joblog (<$fh>); + close $fh; + unlink($joblog); + } +} + + +sub __SIGNAL_HANDLING__() {} + + +sub sigtstp() { + # Send TSTP signal (Ctrl-Z) to all children process groups + # Uses: + # %SIG + # Returns: N/A + signal_children("TSTP"); +} + +sub sigpipe() { + # Send SIGPIPE signal to all children process groups + # Uses: + # %SIG + # Returns: N/A + signal_children("PIPE"); +} + +sub signal_children() { + # Send signal to all children process groups + # and GNU Parallel itself + # Uses: + # %SIG + # Returns: N/A + my $signal = shift; + debug("run", "Sending $signal "); + kill $signal, map { -$_ } keys %Global::running; + # Use default signal handler for GNU Parallel itself + $SIG{$signal} = undef; + kill $signal, $$; +} + +sub save_original_signal_handler() { + # Remember the original signal handler + # Uses: + # %Global::original_sig + # Returns: N/A + $SIG{INT} = sub { + if($opt::tmux) { ::qqx("tmux kill-session -t p$$"); } + wait_and_exit(255); + }; + $SIG{TERM} = sub { + if($opt::tmux) { ::qqx("tmux kill-session -t p$$"); } + wait_and_exit(255); + }; + %Global::original_sig = %SIG; + $SIG{TERM} = sub {}; # Dummy until jobs really start + $SIG{ALRM} = 'IGNORE'; + # Allow Ctrl-Z to suspend and `fg` to continue + $SIG{TSTP} = \&sigtstp; + $SIG{PIPE} = \&sigpipe; + $SIG{CONT} = sub { + # Set $SIG{TSTP} again (it is undef'ed in sigtstp() ) + $SIG{TSTP} = \&sigtstp; + for my $job (values %Global::running) { + if($job->suspended()) { + # Force jobs to suspend, if they are marked as suspended. + # --memsupspend can suspend a job that will be resumed + # if the user presses CTRL-Z followed by `fg`. + $job->suspend(); + } else { + # Resume the rest of the jobs + $job->resume(); + } + } + }; +} + +sub list_running_jobs() { + # Print running jobs on tty + # Uses: + # %Global::running + # Returns: N/A + for my $job (values %Global::running) { + ::status("$Global::progname: ".$job->replaced()); + } +} + +sub start_no_new_jobs() { + # Start no more jobs + # Uses: + # %Global::original_sig + # %Global::unlink + # $Global::start_no_new_jobs + # Returns: N/A + unlink keys %Global::unlink; + ::status + ("$Global::progname: SIGHUP received. No new jobs will be started.", + "$Global::progname: Waiting for these ".(keys %Global::running). + " jobs to finish. Send SIGTERM to stop now."); + list_running_jobs(); + $Global::start_no_new_jobs ||= 1; +} + +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::running + # $opt::timeout + # $Global::timeoutq + # $opt::keeporder + # $Global::total_running + # Returns: + # $stiff = PID of child finished + my $stiff; + debug("run", "Reaper "); + if(($stiff = waitpid(-1, &WNOHANG)) <= 0) { + # No jobs waiting to be reaped + return 0; + } + + # $stiff = pid of dead process + my $job = $Global::running{$stiff}; + + # '-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_exitsignal($? & 127); + if($job->exitstatus()) { + # Exit status already set - probably by --timeout + } elsif($? & 127) { + # Killed by signal. Many shells return: 128 | $signal + $job->set_exitstatus(128 | $?); + } else { + # Normal exit + $job->set_exitstatus($? >> 8); + } + } + + debug("run", "\nseq ",$job->seq()," died (", $job->exitstatus(), ")"); + if($Global::delayauto or $Global::sshdelayauto) { + if($job->exitstatus()) { + # Job failed: Increase delay (if $opt::(ssh)delay set) + $opt::delay &&= $opt::delay * 1.3; + $opt::sshdelay &&= $opt::sshdelay * 1.3; + } else { + # Job succeeded: Decrease delay (if $opt::(ssh)delay set) + $opt::delay &&= $opt::delay * 0.9; + $opt::sshdelay &&= $opt::sshdelay * 0.9; + } + debug("run", "delay:$opt::delay ssh:$opt::sshdelay "); + } + $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 and not $opt::latestline) { + # --latestline fixes --keeporder in Job::row() + $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(); + + if($opt::progress) { + my $progress = progress(); + ::status_no_nl("\r",$progress->{'status'}); + } + + debug("run", "jobdone \n"); + return $stiff; +} + + +sub __USAGE__() {} + + +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(@) { + # Send jobs TERM,TERM,KILL to processgroups + # Input: + # @pids = list of pids that are also processgroups + # Convert pids to process groups ($processgroup = -$pid) + my @pgrps = map { -$_ } @_; + my @term_seq = split/,/,$opt::termseq; + if(not @term_seq) { + @term_seq = ("TERM",200,"TERM",100,"TERM",50,"KILL",25); + } + # for each signal+waittime: kill process groups still not dead + while(@term_seq) { + @pgrps = kill_sleep(shift @term_seq, shift @term_seq, @pgrps); + } +} + +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; + + while(@pids and $sleepsum < $sleep_max) { + if($Global::killall) { + # Killall => don't run reaper + while(waitpid(-1, &WNOHANG) > 0) { + $sleep = $sleep/2+0.001; + } + } elsif(reapers()) { + $sleep = $sleep/2+0.001; + } + $sleep *= 1.1; + ::usleep($sleep); + $sleepsum += $sleep; + # Keep only living children + @pids = grep { kill(0, $_) } @pids; + } + return @pids; +} + +sub wait_and_exit($) { + # If we do not wait, we sometimes get segfault + # Returns: N/A + my $error = shift; + unlink keys %Global::unlink; + if($error) { + # Kill all jobs without printing + killall(); + } + for (keys %Global::unkilled_children) { + # Kill any (non-jobs) children (e.g. reserved processes) + kill 9, $_; + waitpid($_,0); + delete $Global::unkilled_children{$_}; + } + if($Global::unkilled_sqlworker) { + waitpid($Global::unkilled_sqlworker,0); + } + # Avoid: Warning: unable to close filehandle properly: No space + # left on device during global destruction. + $SIG{__WARN__} = sub {}; + if($opt::_parset) { + # Make the shell script return $error + print "$Global::parset_endstring\nreturn $error"; + } + exit($error); +} + +sub die_usage() { + # Returns: N/A + usage(); + wait_and_exit(255); +} + +sub usage() { + # Returns: N/A + print join + ("\n", + "Usage:", + "", + "$Global::progname [options] [command [arguments]] < list_of_arguments", + "$Global::progname [options] [command [arguments]] (::: arguments|:::: argfile(s))...", + "cat ... | $Global::progname --pipe [options] [command [arguments]]", + "", + "-j n Run n jobs in parallel", + "-k Keep same order", + "-X Multiple arguments with context replace", + "--colsep regexp Split input on regexp for positional replacements", + "{} {.} {/} {/.} {#} {%} {= perl code =} Replacement strings", + "{3} {3.} {3/} {3/.} {=3 perl code =} Positional replacement strings", + "With --plus: {} = {+/}/{/} = {.}.{+.} = {+/}/{/.}.{+.} = {..}.{+..} =", + " {+/}/{/..}.{+..} = {...}.{+...} = {+/}/{/...}.{+...}", + "", + "-S sshlogin Example: foo\@server.example.com", + "--slf .. Use ~/.parallel/sshloginfile as the list of sshlogins", + "--trc {}.bar Shorthand for --transfer --return {}.bar --cleanup", + "--onall Run the given command with argument on all sshlogins", + "--nonall Run the given command with no arguments on all sshlogins", + "", + "--pipe Split stdin (standard input) to multiple jobs.", + "--recend str Record end separator for --pipe.", + "--recstart str Record start separator for --pipe.", + "", + "GNU Parallel can do much more. See 'man $Global::progname' for details", + "", + "Academic tradition requires you to cite works you base your article on.", + "If you use programs that use GNU Parallel to process data for an article in a", + "scientific publication, please cite:", + "", + " Tange, O. (2024, February 22). GNU Parallel 20240222 ('Навальный').", + " Zenodo. https://doi.org/10.5281/zenodo.10719803", + "", + # Before changing these lines, 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 + # You accept to be put in a public hall of shame by removing + # these lines + "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() { + # if --will-cite or --plain: do nothing + # if stderr redirected: do nothing + # if $PARALLEL_HOME/will-cite: do nothing + # else: print citation notice to stderr + if($opt::willcite + or + $opt::plain + or + not -t $Global::original_stderr + or + grep { -e "$_/will-cite" } @Global::config_dirs) { + # skip + } else { + ::status + ("Academic tradition requires you to cite works you base your article on.", + "If you use programs that use GNU Parallel to process data for an article in a", + "scientific publication, please cite:", + "", + " Tange, O. (2024, February 22). GNU Parallel 20240222 ('Навальный').", + " Zenodo. https://doi.org/10.5281/zenodo.10719803", + "", + # Before changing these line, please read + # https://www.gnu.org/software/parallel/parallel_design.html#citation-notice and + # https://git.savannah.gnu.org/cgit/parallel.git/tree/doc/citation-notice-faq.txt + # You accept to be put in a public hall of shame by + # removing these lines + "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://www.gnu.org/software/parallel/parallel_design.html#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(@) { + my @w = @_; + my $fh = $Global::status_fd || *STDERR; + print $fh map { ($_, "\n") } @w; + flush $fh; +} + +sub status_no_nl(@) { + my @w = @_; + my $fh = $Global::status_fd || *STDERR; + print $fh @w; + flush $fh; +} + +sub warning(@) { + my @w = @_; + my $prog = $Global::progname || "parallel"; + status_no_nl(map { ($prog, ": Warning: ", $_, "\n"); } @w); +} + +{ + my %warnings; + sub warning_once(@) { + my @w = @_; + my $prog = $Global::progname || "parallel"; + $warnings{@w}++ or + status_no_nl(map { ($prog, ": Warning: ", $_, "\n"); } @w); + } +} + +sub error(@) { + my ($exitcode,@w) = @_; + my $prog = $Global::progname || "parallel"; + if($exitcode =~ /^\d+$/) { + # If $exitcode is set, exit the program + status(map { ($prog.": Error: ". $_); } @w); + wait_and_exit($exitcode); + } else { + # Otherwise $exitcode is just a string + status(map { ($prog.": Error: ". $_); } $exitcode, @w); + } +} + +sub die_bug($) { + my $bugid = shift; + print STDERR + ("$Global::progname: This should not happen. You have found a bug. ", + "Please follow\n", + "https://www.gnu.org/software/parallel/man.html#reporting-bugs\n", + "\n", + "Include this in the report:\n", + "* The version number: $Global::version\n", + "* The bugid: $bugid\n", + "* The command line being run\n", + "* The files being read (put the files on a webserver if they are big)\n", + "\n", + "If you get the error on smaller/fewer files, please include those instead.\n"); + ::wait_and_exit(255); +} + +sub version() { + # Returns: N/A + print join + ("\n", + "GNU $Global::progname $Global::version", + "Copyright (C) 2007-2024 Ole Tange, http://ole.tange.dk 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: https://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() { + # Returns: N/A + my ($all_argv_ref,$argv_options_removed_ref) = @_; + my $all_argv = "@$all_argv_ref"; + my $no_opts = "@$argv_options_removed_ref"; + $all_argv=~s/--citation//; + if($all_argv ne $no_opts) { + ::warning("--citation ignores all other options and arguments."); + ::status(""); + } + + ::status( + "Academic tradition requires you to cite works you base your article on.", + "If you use programs that use GNU Parallel to process data for an article in a", + "scientific publication, please cite:", + "", + "\@software{tange_2024_10719803,", + " author = {Tange, Ole},", + " title = {GNU Parallel 20240222 ('Навальный')},", + " month = Feb,", + " year = 2024,", + " note = {{GNU Parallel is a general parallelizer to run", + " multiple serial command line programs in parallel", + " without changing them.}},", + " publisher = {Zenodo},", + " doi = {10.5281/zenodo.10719803},", + " url = {https://doi.org/10.5281/zenodo.10719803}", + "}", + "", + "(Feel free to use \\nocite{tange_2024_10719803})", + "", + # Before changing these lines, please read + # https://www.gnu.org/software/parallel/parallel_design.html#citation-notice and + # https://git.savannah.gnu.org/cgit/parallel.git/tree/doc/citation-notice-faq.txt + # You accept to be put in a public hall of shame by removing + # these lines + "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", + "" + ); + while(not grep { -e "$_/will-cite" } @Global::config_dirs) { + print "\nType: 'will cite' and press enter.\n> "; + my $input = ; + if(not defined $input) { + exit(255); + } + if($input =~ /will cite/i) { + if(mkdir $Global::config_dir) { + # Recompute @Global::config_dirs so we can break out of the loop. + init_globals(); + } + if(open (my $fh, ">", $Global::config_dir."/will-cite")) { + close $fh; + ::status( + "", + "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( + "", + "Thank you for your support. It is much appreciated. The citation", + "cannot permanently be silenced. Use '--will-cite' instead.", + "", + "If you use '--will-cite' in scripts to be run by others you are making", + "it harder for others to see the citation notice. The development of", + "GNU Parallel is indirectly financed through citations, so if users", + "do not know they should cite then you are making it harder to finance", + "development. However, if you pay 10000 EUR, you should feel free to", + "use '--will-cite' in scripts.", + ""); + last; + } + } + } +} + +sub show_limits() { + # Returns: N/A + print("Maximal size of command: ",Limits::Command::real_max_length(),"\n", + "Maximal usable size of command: ", + $Global::usable_command_line_length,"\n", + "\n", + "Execution will continue now, ", + "and it will try to read its input\n", + "and run commands; if this is not ", + "what you wanted to happen, please\n", + "press CTRL-D or CTRL-C\n"); +} + +sub embed() { + # Give an embeddable version of GNU Parallel + # Tested with: bash, zsh, ksh, ash, dash, sh + my $randomstring = "cut-here-".join"", + map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..20); + if(not -f $0 or not -r $0) { + ::error(255,"--embed only works if parallel is a readable file"); + } + # Read the source from $0 + my $source = slurp_or_exit($0); + my $user = $ENV{LOGNAME} || $ENV{USERNAME} || $ENV{USER}; + my $env_parallel_source; + my $shell = $Global::shell; + $shell =~ s:.*/::; + for(which("env_parallel.$shell")) { + -r $_ or next; + # Read the source of env_parallel.shellname + $env_parallel_source .= slurp_or_exit($_); + last; + } + print "#!$Global::shell + +# Copyright (C) 2007-2024 $user, Ole Tange, http://ole.tange.dk +# 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 +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see +# or write to the Free Software Foundation, Inc., 51 Franklin St, +# Fifth Floor, Boston, MA 02110-1301 USA +"; + + print q! +# Embedded GNU Parallel created with --embed +parallel() { + # Start GNU Parallel without leaving temporary files + # + # Not all shells support 'perl <(cat ...)' + # This is a complex way of doing: + # perl <(cat <<'cut-here' + # [...] + # ) "$@" + # and also avoiding: + # [1]+ Done cat + + # Make a temporary fifo that perl can read from + _fifo_with_GNU_Parallel_source=`perl -e 'use POSIX qw(mkfifo); + do { + $f = "/tmp/parallel-".join"", + map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..5); + } while(-e $f); + mkfifo($f,0600); + print $f;'` + # Put source code into temporary file + # so it is easy to copy to the fifo + _file_with_GNU_Parallel_source=`mktemp`; +!, + "cat <<'$randomstring' > \$_file_with_GNU_Parallel_source\n", + $source, + $randomstring,"\n", + q! + # Copy the source code from the file to the fifo + # and remove the file and fifo ASAP + # 'sh -c' is needed to avoid + # [1]+ Done cat + sh -c "(rm $_file_with_GNU_Parallel_source; cat >$_fifo_with_GNU_Parallel_source; rm $_fifo_with_GNU_Parallel_source) < $_file_with_GNU_Parallel_source &" + + # Read the source from the fifo + perl $_fifo_with_GNU_Parallel_source "$@" +} +!, + $env_parallel_source, + q! + +# This will call the functions above +parallel -k echo ::: Put your code here +env_parallel --session +env_parallel -k echo ::: Put your code here +parset p,y,c,h -k echo ::: Put your code here +echo $p $y $c $h +echo You can also activate GNU Parallel for interactive use by: +echo . "$0" +!; + ::status("Redirect the output to a file and add your changes at the end:", + " $0 --embed > new_script"); +} + +sub pack_combined_executable { + my ($before_ref,$with_argsep_ref,$argv_ref) = @_; + my @parallelopts; + my $skip_next; + # Remove '--combine-exec file' from options + for(@{$before_ref}[0..(arrayindex($before_ref,$with_argsep_ref))-1]) { + if (/^--combine-?exec(utable)?$/ || $skip_next) { + # Also skip the filename given to --combine-exec + $skip_next = !$skip_next; + next; + } + push @parallelopts, $_; + } + # From ::: and to end + my @argsep = @{$with_argsep_ref}[($#ARGV+1)..$#$with_argsep_ref]; + # The executable is now the first in @ARGV + my $execname = shift @ARGV; + # The rest of @ARGV are options for $execname + my @execopts = @ARGV; + debug("combine", + "Parallel opts: @parallelopts ", + "Executable: $execname ", + "Execopts: @execopts ", + "Argsep: @argsep\n"); + # Read the the executable + my $exec = slurp_or_exit(which($execname)); + # Read the source of GNU Parallel and the executable + my $parallel = slurp_or_exit($0); + # Remove possibly __END__ from GNU Parallel + $parallel =~ s/^__END__.*//s; + if(-t $Global::original_stderr) { + ::status( + "Please be aware that combining GNU Parallel and '$execname'", + "into a combined executable will make the whole executable", + "licensed under GPLv3 (section 5.c).", + "", + "If the license of '$execname' is incompatible with GPLv3,", + "you cannot legally convey copies of the combined executable", + "to others. You can, however, still run them yourself.", + "", + "The combined executable will not have a citation notice,", + "so it is your resposibilty to advice that academic tradition", + "requires the users to cite GNU Parallel.", + "" + ); + my $input; + do { + ::status_no_nl("\nType: 'I agree' and press enter.\n> "); + $input = ; + if(not defined $input) { + exit(255); + } + } until($input =~ /I agree/i); + } + write_or_exit($opt::combineexec, + $parallel, + "\n__END__\n", + (map { "$_\0\n" } @parallelopts), "\0\0\n", + $execname, "\0\0\n", + (map { "$_\0\n" } @execopts), "\0\0\n", + (map { "$_\0\n" } @argsep), "\0\0\n", + $exec); + # Set +x permission + chmod 0700, $opt::combineexec; + exit(0); +} + +sub unpack_combined_executable { + # If the script is a combined executable, + # it will have stuff in (I.e. after __END__) + my $combine_exec = join("",); + if(length $combine_exec) { + # Parse the + # + # __END__ + # Option for GNU Parallel\0\n + # Option for GNU Parallel\0\n + # \0\0\n + # Name of executable\0\0\n + # Option for executable\0\n + # Option for executable\0\n + # \0\0\n + # argsep + args if any\0\n + # argsep + args if any\0\n + # \0\0\n + # <> + # + # parallel --combine --pipe -j10% --recend '' myscript --myopt myval + # __END__ + # --pipe\0\n --pipe + # -j10%\0\n -j10% + # --recend\0\n --recend + # \0\n '' + # \0\0\n end-of-parallel-options + # myscript\0\0\n myscript + # --myopt\0\n --myopt + # myval\0\n myval + # \0\0\n end-of-myscript-options + # \0\0\n no argsep + # <> + # + # parallel --combine -j10% myscript ::: + # __END__ + # -j10%\0\n + # \0\0\n end-of-parallel-options + # myscript\0\0\n + # \0\0\n end-of-myscript-options + # :::\0\n + # \0\0\n + # <> + + my ($opts,$execname,$execopts,$argsep,$exec) = + split /\0\0\n/,$combine_exec,5; + # Make a tmpdir with a file called $execname + local %ENV; + $ENV{TMPDIR} ||= "/tmp"; + my $dir = File::Temp::tempdir($ENV{'TMPDIR'} . "/parXXXXX", CLEANUP => 1); + my $script = $dir."/".$execname; + write_or_exit($script,$exec); + # Set +x permission + chmod 0700, $script; + # Mark it for unlinking later + $Global::unlink{$script}++; + $Global::unlink{$dir}++; + # pass the options for GNU Parallel + my @opts = split /\0\n/, $opts; + my @execopts = split /\0\n/, $execopts; + if(length $argsep) { + # Only add argsep if set + unshift(@ARGV, split(/\0\n/,$argsep)); + } + unshift(@ARGV,@opts,$script,@execopts); + } +} + + +sub __GENERIC_COMMON_FUNCTION__() {} + + +sub mkdir_or_die($) { + # If dir is not executable: die + my $dir = shift; + # The eval is needed to catch exception from mkdir + eval { File::Path::mkpath($dir); }; + if(not -x $dir) { + ::error(255,"Cannot change into non-executable dir $dir: $!"); + } +} + +sub tmpfile(@) { + # Create tempfile as $TMPDIR/parXXXXX + # Returns: + # $filehandle = opened file handle + # $filename = file name created + my($filehandle,$filename) = + ::tempfile(DIR=>$ENV{'TMPDIR'}, TEMPLATE => 'parXXXXX', @_); + if(wantarray) { + return($filehandle,$filename); + } else { + # Separate unlink due to NFS dealing badly with File::Temp + unlink $filename; + return $filehandle; + } +} + +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 + my $name = shift; + my($tmpname); + if(not -w $ENV{'TMPDIR'}) { + my $qtmp = ::Q($ENV{'TMPDIR'}); + if(not -e $ENV{'TMPDIR'}) { + ::error(255,"Tmpdir $qtmp does not exist.", + "Try: mkdir -p $qtmp"); + } else { + ::error(255,"Tmpdir $qtmp is not writable.", + "Try: chmod +w $qtmp"); + } + } + do { + $tmpname = $ENV{'TMPDIR'}."/".$name. + join"", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..5); + } while(-e $tmpname or $Global::unlink{$tmpname}++); + return $tmpname; +} + +sub tmpfifo() { + # Find an unused name and mkfifo on it + my $tmpfifo = tmpname("fif"); + mkfifo($tmpfifo,0600); + return $tmpfifo; +} + +sub rm(@) { + # Remove file and remove it from %Global::unlink + # Uses: + # %Global::unlink + delete @Global::unlink{@_}; + unlink @_; +} + +sub size_of_block_dev() { + # Like -s but for block devices + # Input: + # $blockdev = file name of block device + # Returns: + # $size = in bytes, undef if error + my $blockdev = shift; + my $fh = open_or_exit("<", $blockdev); + seek($fh,0,2) || ::die_bug("cannot seek $blockdev"); + my $size = tell($fh); + close $fh; + return $size; +} + +sub qqx(@) { + # Like qx but with clean environment (except for @keep) + # and STDERR ignored + # This is needed if the environment contains functions + # that /bin/sh does not understand + my %env; + # ssh with ssh-agent needs PATH SSH_AUTH_SOCK SSH_AGENT_PID + # ssh with Kerberos needs KRB5CCNAME + # sshpass needs SSHPASS + # tmux needs LC_CTYPE + # lsh needs HOME LOGNAME + my @keep = qw(PATH SSH_AUTH_SOCK SSH_AGENT_PID KRB5CCNAME LC_CTYPE + HOME LOGNAME SSHPASS); + @env{@keep} = @ENV{@keep}; + local %ENV; + %ENV = %env; + if($Global::debug) { + # && true is to force spawning a shell and not just exec'ing + return qx{ @_ && true }; + } else { + # CygWin does not respect 2>/dev/null + # so we do that by hand + # This trick does not work: + # https://stackoverflow.com/q/13833088/363028 + # local *STDERR; + # open(STDERR, ">", "/dev/null"); + open(local *CHILD_STDIN, '<', '/dev/null') or die $!; + open(local *CHILD_STDERR, '>', '/dev/null') or die $!; + my $out; + # eval is needed if open3 fails (e.g. command line too long) + eval { + my $pid = open3( + '<&CHILD_STDIN', + $out, + '>&CHILD_STDERR', + # && true is to force spawning a shell and not just exec'ing + "@_ && true"); + my @arr = <$out>; + close $out; + # Make sure $? is set + waitpid($pid, 0); + return wantarray ? @arr : join "",@arr; + } or do { + # If eval fails, force $?=false + `false`; + }; + } +} + +sub uniq(@) { + # Remove duplicates and return unique values + return keys %{{ map { $_ => 1 } @_ }}; +} + +sub min(@) { + # Returns: + # Minimum value of array + my $min; + for (@_) { + # Skip undefs + defined $_ or next; + defined $min or do { $min = $_; next; }; # Set $_ to the first non-undef + $min = ($min < $_) ? $min : $_; + } + return $min; +} + +sub max(@) { + # Returns: + # Maximum value of array + my $max; + for (@_) { + # Skip undefs + defined $_ or next; + defined $max or do { $max = $_; next; }; # Set $_ to the first non-undef + $max = ($max > $_) ? $max : $_; + } + return $max; +} + +sub sum(@) { + # Returns: + # Sum of values of array + my @args = @_; + my $sum = 0; + for (@args) { + # Skip undefs + $_ and do { $sum += $_; } + } + return $sum; +} + +sub undef_as_zero($) { + my $a = shift; + return $a ? $a : 0; +} + +sub undef_as_empty($) { + my $a = shift; + return $a ? $a : ""; +} + +sub undef_if_empty($) { + if(defined($_[0]) and $_[0] eq "") { + return undef; + } + return $_[0]; +} + +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 + # K =2^10, M =2^20, G =2^30, T =2^40, P =2^50, E =2^70, Z =2^80, Y =2^80 + # k =10^3, m =10^6, g =10^9, t=10^12, p=10^15, e=10^18, z=10^21, y=10^24 + # 13G = 13*1024*1024*1024 = 13958643712 + # Input: + # $s = string with prefixes + # Returns: + # $value = int with prefixes multiplied + my @v = @_; + for(@v) { + defined $_ or next; + s/ki/*1024/gi; + s/mi/*1024*1024/gi; + s/gi/*1024*1024*1024/gi; + s/ti/*1024*1024*1024*1024/gi; + s/pi/*1024*1024*1024*1024*1024/gi; + s/ei/*1024*1024*1024*1024*1024*1024/gi; + s/zi/*1024*1024*1024*1024*1024*1024*1024/gi; + s/yi/*1024*1024*1024*1024*1024*1024*1024*1024/gi; + s/xi/*1024*1024*1024*1024*1024*1024*1024*1024*1024/gi; + + s/K/*1024/g; + s/M/*1024*1024/g; + s/G/*1024*1024*1024/g; + s/T/*1024*1024*1024*1024/g; + s/P/*1024*1024*1024*1024*1024/g; + s/E/*1024*1024*1024*1024*1024*1024/g; + s/Z/*1024*1024*1024*1024*1024*1024*1024/g; + s/Y/*1024*1024*1024*1024*1024*1024*1024*1024/g; + s/X/*1024*1024*1024*1024*1024*1024*1024*1024*1024/g; + + s/k/*1000/g; + s/m/*1000*1000/g; + s/g/*1000*1000*1000/g; + s/t/*1000*1000*1000*1000/g; + s/p/*1000*1000*1000*1000*1000/g; + s/e/*1000*1000*1000*1000*1000*1000/g; + s/z/*1000*1000*1000*1000*1000*1000*1000/g; + s/y/*1000*1000*1000*1000*1000*1000*1000*1000/g; + s/x/*1000*1000*1000*1000*1000*1000*1000*1000*1000/g; + + $_ = eval $_; + } + return wantarray ? @v : $v[0]; +} + +sub multiply_time_units($) { + # Evalualte numbers with time units + # s=1, m=60, h=3600, d=86400 + # Input: + # $s = string time units + # Returns: + # $value = int in seconds + my @v = @_; + for(@v) { + defined $_ or next; + if(/[dhms]/i) { + s/s/*1+/gi; + s/m/*60+/gi; + s/h/*3600+/gi; + s/d/*86400+/gi; + # 1m/3 => 1*60+/3 => 1*60/3 + s/\+(\D)/$1/gi; + } + $_ = eval $_."-0"; + } + return wantarray ? @v : $v[0]; +} + +sub seconds_to_time_units() { + # Convert seconds into ??d??h??m??s + # s=1, m=60, h=3600, d=86400 + # Input: + # $s = int in seconds + # Returns: + # $str = string time units + my $s = shift; + my $str; + my $d = int($s/86400); + $s -= $d * 86400; + my $h = int($s/3600); + $s -= $h * 3600; + my $m = int($s/60); + $s -= $m * 60; + if($d) { + $str = sprintf("%dd%02dh%02dm%02ds",$d,$h,$m,$s); + } elsif($h) { + $str = sprintf("%dh%02dm%02ds",$h,$m,$s); + } elsif($m) { + $str = sprintf("%dm%02ds",$m,$s); + } else { + $str = sprintf("%ds",$s); + } + return $str; +} + +{ + my ($disk_full_fh, $b8193); + sub exit_if_disk_full() { + # Checks if $TMPDIR is full by writing 8kb to a tmpfile + # If the disk is full: Exit immediately. + # Returns: + # N/A + if(not $disk_full_fh) { + $disk_full_fh = ::tmpfile(SUFFIX => ".df"); + $b8193 = "b"x8193; + } + # Linux does not discover if a disk is full if writing <= 8192 + # Tested on: + # bfs btrfs cramfs ext2 ext3 ext4 ext4dev jffs2 jfs minix msdos + # ntfs reiserfs tmpfs ubifs vfat xfs + # TODO this should be tested on different OS similar to this: + # + # doit() { + # sudo mount /dev/ram0 /mnt/loop; sudo chmod 1777 /mnt/loop + # seq 100000 | parallel --tmpdir /mnt/loop/ true & + # seq 6900000 > /mnt/loop/i && echo seq OK + # seq 6980868 > /mnt/loop/i + # seq 10000 > /mnt/loop/ii + # sleep 3 + # sudo umount /mnt/loop/ || sudo umount -l /mnt/loop/ + # echo >&2 + # } + print $disk_full_fh $b8193; + if(not $disk_full_fh + or + tell $disk_full_fh != 8193) { + # On raspbian the disk can be full except for 10 chars. + ::error(255,"Output is incomplete.", + "Cannot append to buffer file in $ENV{'TMPDIR'}.", + "Is the disk full?", + "Change \$TMPDIR with --tmpdir or use --compress."); + } + truncate $disk_full_fh, 0; + seek($disk_full_fh, 0, 0) || die; + } +} + +sub spacefree($$) { + # Remove comments and spaces + # Inputs: + # $spaces = keep 1 space? + # $s = string to remove spaces from + # Returns: + # $s = with spaces removed + my $spaces = shift; + my $s = shift; + $s =~ s/#.*//mg; + if(1 == $spaces) { + $s =~ s/\s+/ /mg; + } elsif(2 == $spaces) { + # 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; + } + return $s; +} + +{ + my $hostname; + sub hostname() { + local $/ = "\n"; + if(not $hostname) { + $hostname = `hostname`; + chomp($hostname); + $hostname ||= "nohostname"; + } + return $hostname; + } +} + +sub which(@) { + # Input: + # @programs = programs to find the path to + # Returns: + # @full_path = full paths to @programs. Nothing if not found + my @which; + for my $prg (@_) { + push(@which, grep { not -d $_ and -x $_ } + map { $_."/".$prg } split(":",$ENV{'PATH'})); + if($prg =~ m:/:) { + # Test if program with full path exists + push(@which, grep { not -d $_ and -x $_ } $prg); + } + } + ::debug("which", "$which[0] in $ENV{'PATH'}\n"); + return wantarray ? @which : $which[0]; +} + +{ + my ($regexp,$shell,%fakename); + + sub parent_shell { + # Input: + # $pid = pid to see if (grand)*parent is a shell + # Returns: + # $shellpath = path to shell - undef if no shell found + my $pid = shift; + ::debug("init","Parent of $pid\n"); + if(not $regexp) { + # All shells known to mankind + # + # ash bash csh dash fdsh fish fizsh ksh ksh93 mksh pdksh + # posh rbash rc rush rzsh sash sh static-sh tcsh yash zsh + + my @shells = (qw(ash bash bsd-csh csh dash fdsh fish fizsh ksh + ksh93 lksh mksh pdksh posh rbash rc rush rzsh sash sh + static-sh tcsh yash zsh -sh -csh -bash), + '-sh (sh)' # sh on FreeBSD + ); + # Can be formatted as: + # [sh] -sh sh busybox sh -sh (sh) + # /bin/sh /sbin/sh /opt/csw/sh + # But not: foo.sh sshd crash flush pdflush scosh fsflush ssh + $shell = "(?:".join("|",map { "\Q$_\E" } @shells).")"; + $regexp = '^((\[)(-?)('. $shell. ')(\])|(|\S+/|busybox )'. + '(-?)('. $shell. '))( *$| [^(])'; + %fakename = ( + # sh disguises itself as -sh (sh) on FreeBSD + "-sh (sh)" => ["sh"], + # csh and tcsh disguise themselves as -sh/-csh + # E.g.: ssh -tt csh@lo 'ps aux;true' |egrep ^csh + # but sh also disguises itself as -sh + # (TODO When does that happen?) + "-sh" => ["sh"], + "-csh" => ["tcsh", "csh"], + # ash disguises itself as -ash + "-ash" => ["ash", "dash", "sh"], + # dash disguises itself as -dash + "-dash" => ["dash", "ash", "sh"], + # bash disguises itself as -bash + "-bash" => ["bash", "sh"], + # ksh disguises itself as -ksh + "-ksh" => ["ksh", "sh"], + # zsh disguises itself as -zsh + "-zsh" => ["zsh", "sh"], + ); + } + if($^O eq "linux") { + # Optimized for GNU/Linux + my $testpid = $pid; + my $shellpath; + my $shellline; + while($testpid) { + if(open(my $fd, "<", "/proc/$testpid/cmdline")) { + local $/="\0"; + chomp($shellline = <$fd>); + if($shellline =~ /$regexp/o) { + my $shellname = $4 || $8; + my $dash = $3 || $7; + if($shellname eq "sh" and $dash) { + # -sh => csh or sh + if($shellpath = readlink "/proc/$testpid/exe") { + ::debug("init","procpath $shellpath\n"); + if($shellpath =~ m:/$shell$:o) { + ::debug("init", + "proc which ".$shellpath." => "); + return $shellpath; + } + } + } + ::debug("init", "which ".$shellname." => "); + $shellpath = (which($shellname, + @{$fakename{$shellname}}))[0]; + ::debug("init", "shell path $shellpath\n"); + return $shellpath; + } + } + # Get parent pid + if(open(my $fd, "<", "/proc/$testpid/stat")) { + my $line = <$fd>; + close $fd; + # Parent pid is field 4 + $testpid = (split /\s+/, $line)[3]; + } else { + # Something is wrong: fall back to old method + last; + } + } + } + # if -sh or -csh try readlink /proc/$$/exe + my ($children_of_ref, $parent_of_ref, $name_of_ref) = pid_table(); + my $shellpath; + my $testpid = $pid; + while($testpid) { + if($name_of_ref->{$testpid} =~ /$regexp/o) { + my $shellname = $4 || $8; + my $dash = $3 || $7; + if($shellname eq "sh" and $dash) { + # -sh => csh or sh + if($shellpath = readlink "/proc/$testpid/exe") { + ::debug("init","procpath $shellpath\n"); + if($shellpath =~ m:/$shell$:o) { + ::debug("init", "proc which ".$shellpath." => "); + return $shellpath; + } + } + } + ::debug("init", "which ".$shellname." => "); + $shellpath = (which($shellname,@{$fakename{$shellname}}))[0]; + ::debug("init", "shell path $shellpath\n"); + $shellpath and last; + } + if($testpid == $parent_of_ref->{$testpid}) { + # In Solaris zones, the PPID of the zsched process is itself + last; + } + $testpid = $parent_of_ref->{$testpid}; + } + return $shellpath; + } +} + +{ + my %pid_parentpid_cmd; + + sub pid_table() { + # Returns: + # %children_of = { pid -> children of pid } + # %parent_of = { pid -> pid of parent } + # %name_of = { pid -> commandname } + + if(not %pid_parentpid_cmd) { + # Filter for SysV-style `ps` + my $sysv = q( ps -ef |). + q(perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;). + q(s/^.{$s}//; print "@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 |). + q(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 = + ( + 'aix' => $sysv, + 'android' => $sysv, + 'cygwin' => $sysv, + 'darwin' => $bsd, + 'dec_osf' => $sysv, + 'dragonfly' => $bsd, + 'freebsd' => $bsd, + 'gnu' => $sysv, + 'hpux' => $sysv, + 'linux' => $sysv, + 'mirbsd' => $bsd, + 'minix' => $minix, + 'msys' => $sysv, + 'MSWin32' => $sysv, + 'netbsd' => $bsd, + 'nto' => $sysv, + 'openbsd' => $bsd, + 'solaris' => $sysv, + 'svr5' => $sysv, + 'syllable' => "echo ps not supported", + ); + } + $pid_parentpid_cmd{$^O} or + ::die_bug("pid_parentpid_cmd for $^O missing"); + + my (@pidtable,%parent_of,%children_of,%name_of); + # Table with pid -> children of pid + @pidtable = `$pid_parentpid_cmd{$^O}`; + my $p=$$; + for (@pidtable) { + # must match: 24436 21224 busybox ash + # must match: 24436 21224 <> + # must match: 24436 21224 <> + # or: perl -e 'while($0=" "){}' + if(/^\s*(\S+)\s+(\S+)\s+(\S+.*)/ + or + /^\s*(\S+)\s+(\S+)\s+()$/) { + $parent_of{$1} = $2; + push @{$children_of{$2}}, $1; + $name_of{$1} = $3; + } else { + ::die_bug("pidtable format: $_"); + } + } + return(\%children_of, \%parent_of, \%name_of); + } +} + +sub now() { + # Returns time since epoch as in seconds with 3 decimals + # Uses: + # @Global::use + # Returns: + # $time = time now with millisecond accuracy + if(not $Global::use{"Time::HiRes"}) { + if(eval "use Time::HiRes qw ( time );") { + eval "sub TimeHiRestime { return Time::HiRes::time };"; + } else { + eval "sub TimeHiRestime { return time() };"; + } + $Global::use{"Time::HiRes"} = 1; + } + + return (int(TimeHiRestime()*1000))/1000; +} + +sub usleep($) { + # Sleep this many milliseconds. + # Input: + # $ms = milliseconds to sleep + my $ms = shift; + ::debug("timing",int($ms),"ms "); + select(undef, undef, undef, $ms/1000); +} + +sub make_regexp_ungreedy { + my $regexp = shift; + my $class_state = 0; + my $escape_state = 0; + my $found = 0; + my $ungreedy = ""; + my $c; + + for $c (split (//, $regexp)) { + if ($found) { + if($c ne "?") { $ungreedy .= "?"; } + $found = 0; + } + $ungreedy .= $c; + + if ($escape_state) { $escape_state = 0; next; } + if ($c eq "\\") { $escape_state = 1; next; } + if ($c eq '[') { $class_state = 1; next; } + if ($class_state) { + if($c eq ']') { $class_state = 0; } + next; + } + # Quantifiers: + * {...} + if ($c =~ /[*}+]/) { $found = 1; } + } + if($found) { $ungreedy .= '?'; } + return $ungreedy; +} + + +sub __KILLER_REAPER__() {} + +sub reap_usleep() { + # Reap dead children. + # If no dead children: Sleep specified amount with exponential backoff + # Input: + # $ms = milliseconds to sleep + # Returns: + # $ms/2+0.001 if children reaped + # $ms*1.1 if no children reaped + my $ms = shift; + if(reapers()) { + if(not $Global::total_completed % 100) { + if($opt::timeout) { + # Force cleaning the timeout queue for every 100 jobs + # Fixes potential memleak + $Global::timeoutq->process_timeouts(); + } + } + # Sleep exponentially shorter (1/2^n) if a job finished + return $ms/2+0.001; + } else { + if($opt::timeout) { + $Global::timeoutq->process_timeouts(); + } + if($opt::memfree) { + kill_youngster_if_not_enough_mem($opt::memfree*0.5); + } + if($opt::memsuspend) { + suspend_young_if_not_enough_mem($opt::memsuspend); + } + if($opt::limit) { + kill_youngest_if_over_limit(); + } + exit_if_disk_full(); + if($Global::linebuffer) { + my $something_printed = 0; + if($opt::keeporder and not $opt::latestline) { + for my $job (values %Global::running) { + $something_printed += $job->print_earlier_jobs(); + } + } else { + for my $job (values %Global::running) { + $something_printed += $job->print(); + } + } + if($something_printed) { $ms = $ms/2+0.001; } + } + if($ms > 0.002) { + # When a child dies, wake up from sleep (or select(,,,)) + $SIG{CHLD} = sub { kill "ALRM", $$ }; + if($opt::delay and not $Global::linebuffer) { + # The 0.004s is approximately the time it takes for one round + my $next_earliest_start = + $Global::newest_starttime + $opt::delay - 0.004; + my $remaining_ms = 1000 * ($next_earliest_start - ::now()); + # The next job can only start at $next_earliest_start + # so sleep until then (but sleep at least $ms) + usleep(::max($ms,$remaining_ms)); + } else { + usleep($ms); + } + # --compress needs $SIG{CHLD} unset + $SIG{CHLD} = 'DEFAULT'; + } + # Sleep exponentially longer (1.1^n) if a job did not finish, + # though at most 1000 ms. + return (($ms < 1000) ? ($ms * 1.1) : ($ms)); + } +} + +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. + # Uses: + # %Global::running + my %jobs_of; + my @sshlogins; + + for my $job (values %Global::running) { + if(not $jobs_of{$job->sshlogin()}) { + push @sshlogins, $job->sshlogin(); + } + push @{$jobs_of{$job->sshlogin()}}, $job; + } + for my $sshlogin (@sshlogins) { + for my $job (sort { $b->seq() <=> $a->seq() } + @{$jobs_of{$sshlogin}}) { + if($sshlogin->limit() == 2) { + $job->kill(); + last; + } + } + } +} + +sub suspend_young_if_not_enough_mem() { + # Check each $sshlogin if there is enough mem. + # If less than $limit free mem: suspend some of the young children + # Else: Resume all jobs + # Uses: + # %Global::running + my $limit = shift; + my %jobs_of; + my @sshlogins; + + for my $job (values %Global::running) { + if(not $jobs_of{$job->sshlogin()}) { + push @sshlogins, $job->sshlogin(); + } + push @{$jobs_of{$job->sshlogin()}}, $job; + } + for my $sshlogin (@sshlogins) { + my $free = $sshlogin->memfree(); + if($free < 2*$limit) { + # Suspend all jobs (resume some of them later) + map { $_->suspended() or $_->suspend(); } @{$jobs_of{$sshlogin}}; + my @jobs = (sort { $b->seq() <=> $a->seq() } + @{$jobs_of{$sshlogin}}); + # how many should be running? + # limit*1 => 1; + # limit*1.5 => 2; + # limit*1.75 => 4; + # free < limit*(2-1/2^n); + # => + # 1/(2-free/limit) < 2^n; + my $run = int(1/(2-$free/$limit)); + $run = ::min($run,$#jobs); + # Resume the oldest running + for my $job ((sort { $a->seq() <=> $b->seq() } @jobs)[0..$run]) { + ::debug("mem","\nResume ",$run+1, " jobs. Seq ", + $job->seq(), " resumed ", + $sshlogin->memfree()," < ",2*$limit); + $job->resume(); + } + } else { + for my $job (@{$jobs_of{$sshlogin}}) { + if($job->suspended()) { + $job->resume(); + ::debug("mem","\nResume ",$#{$jobs_of{$sshlogin}}+1, + " jobs. Seq ", $job->seq(), " resumed ", + $sshlogin->memfree()," > ",2*$limit); + last; + } + } + } + } +} + +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. + # Uses: + # %Global::running + my $limit = shift; + my %jobs_of; + my @sshlogins; + + for my $job (values %Global::running) { + if(not $jobs_of{$job->sshlogin()}) { + push @sshlogins, $job->sshlogin(); + } + push @{$jobs_of{$job->sshlogin()}}, $job; + } + for my $sshlogin (@sshlogins) { + for my $job (sort { $b->seq() <=> $a->seq() } + @{$jobs_of{$sshlogin}}) { + if($sshlogin->memfree() < $limit) { + ::debug("mem","\n",map { $_->seq()." " } + (sort { $b->seq() <=> $a->seq() } + @{$jobs_of{$sshlogin}})); + ::debug("mem","\n", $job->seq(), "killed ", + $sshlogin->memfree()," < ",$limit); + $job->kill(); + $sshlogin->memfree_recompute(); + } else { + last; + } + } + ::debug("mem","Free mem OK? ", + $sshlogin->memfree()," > ",$limit); + } +} + + +sub __DEBUGGING__() {} + + +sub debug(@) { + # Uses: + # $Global::debug + # %Global::fh + # Returns: N/A + $Global::debug or return; + @_ = grep { defined $_ ? $_ : "" } @_; + if($Global::debug eq "all" or $Global::debug eq $_[0]) { + if($Global::fh{2}) { + # Original stderr was saved + my $stderr = $Global::fh{2}; + print $stderr @_[1..$#_]; + } else { + print STDERR @_[1..$#_]; + } + } +} + +sub my_memory_usage() { + # Returns: + # memory usage if found + # 0 otherwise + use strict; + use FileHandle; + + local $/ = "\n"; + my $pid = $$; + if(-e "/proc/$pid/stat") { + my $fh = FileHandle->new("; + chomp $data; + $fh->close; + + my @procinfo = split(/\s+/,$data); + + return undef_as_zero($procinfo[22]); + } else { + return 0; + } +} + +sub my_size() { + # Returns: + # $size = size of object if Devel::Size is installed + # -1 otherwise + my @size_this = (@_); + eval "use Devel::Size qw(size total_size)"; + if ($@) { + return -1; + } else { + return total_size(@_); + } +} + +sub my_dump(@) { + # Returns: + # ascii expression of object if Data::Dump(er) is installed + # error code otherwise + my @dump_this = (@_); + eval "use Data::Dump qw(dump);"; + if ($@) { + # Data::Dump not installed + eval "use Data::Dumper;"; + if ($@) { + my $err = "Neither Data::Dump nor Data::Dumper is installed\n". + "Not dumping output\n"; + ::status($err); + return $err; + } else { + return Dumper(@dump_this); + } + } else { + # Create a dummy Data::Dump:dump as Hans Schou sometimes has + # it undefined + eval "sub Data::Dump:dump {}"; + eval "use Data::Dump qw(dump);"; + return (Data::Dump::dump(@dump_this)); + } +} + +sub my_croak(@) { + eval "use Carp; 1"; + $Carp::Verbose = 1; + croak(@_); +} + +sub my_carp() { + eval "use Carp; 1"; + $Carp::Verbose = 1; + carp(@_); +} + + +sub __OBJECT_ORIENTED_PARTS__() {} + + +package SSHLogin; + +sub new($$) { + my $class = shift; + my $s = shift; + my $origs = $s; + my %hostgroups; + my $ncpus; + my $sshcommand; + my $user; + my $password; + my $host; + my $port; + my $local; + my $string; + # SSHLogins can have these formats: + # @grp+grp/ncpu//usr/bin/ssh user@server + # ncpu//usr/bin/ssh user@server + # /usr/bin/ssh user@server + # user@server + # ncpu/user@server + # @grp+grp/user@server + # above with: user:password@server + # above with: user@server:port + # So: + # [@grp+grp][ncpu/][ssh command ][[user][:password]@][server[:port]] + + # [@grp+grp]/ncpu//usr/bin/ssh user:pass@server:port + if($s =~ s:^\@([^/]+)/?::) { + # Look for SSHLogin hostgroups + %hostgroups = map { $_ => 1 } split(/\+|,/, $1); + } + # An SSHLogin is always in the hostgroup of its "numcpu/host" + $hostgroups{$s} = 1; + + # [ncpu/]/usr/bin/ssh user:pass@server:port + if ($s =~ s:^(\d+)/::) { $ncpus = $1; } + + # [/usr/bin/ssh ]user:pass@server:port + if($s =~ s/^(.*) //) { $sshcommand = $1; } + + # [user:pass@]server:port + if($s =~ s/^([^@]+)@//) { + my $userpw = $1; + # user[:pass] + if($userpw =~ s/:(.*)//) { + $password = $1; + if($password eq "") { $password = $ENV{'SSHPASS'} } + if(not ::which("sshpass")) { + ::error(255,"--sshlogin with password requires ". + "sshpass installed"); + } + } + $user = $userpw; + } + # [server]:port + if(not $s =~ /:.*:/ + and + $s =~ s/^([-a-z0-9._]+)//i) { + # Not IPv6 (IPv6 has 2 or more ':') + $host = $1; + } elsif($s =~ s/^(\\[\[\]box0-9a-f.]+)//i) { + # RFC2673 allows for: + # \[b11010000011101] \[o64072/14] \[xd074/14] \[208.116.0.0/14] + $host = $1; + } elsif($s =~ s/^\[([0-9a-f:]+)\]//i + or + $s =~ s/^([0-9a-f:]+)//i) { + # RFC5952 + # [2001:db8::1]:80 + # 2001:db8::1.80 + # 2001:db8::1p80 + # 2001:db8::1#80 + # 2001:db8::1:80 - not supported + # 2001:db8::1 port 80 - not supported + $host = $1; + } + + # [:port] + if($s =~ s/^:(\w+)//i) { + $port = $1; + } elsif($s =~ s/^[p\.\#](\w+)//i) { + # RFC5952 + # 2001:db8::1.80 + # 2001:db8::1p80 + # 2001:db8::1#80 + $port = $1; + } + + if($s and $s ne ':') { + ::die_bug("SSHLogin parser failed on '$origs' => '$s'"); + } + + $string = + # Only include the sshcommand in $string if it is set by user + ($sshcommand && $sshcommand." "). + ($user && $user."@"). + ($host && $host). + ($port && ":$port"); + if($host eq ':') { + $local = 1; + $string = ":"; + } else { + $sshcommand ||= $opt::ssh || $ENV{'PARALLEL_SSH'} || "ssh"; + } + # An SSHLogin is always in the hostgroup of its $string-name + $hostgroups{$string} = 1; + @Global::hostgroups{keys %hostgroups} = values %hostgroups; + # Used for file names for loadavg + my $no_slash_string = $string; + $no_slash_string =~ s/[^-a-z0-9:]/_/gi; + return bless { + 'string' => $string, + 'jobs_running' => 0, + 'jobs_completed' => 0, + 'maxlength' => undef, + 'max_jobs_running' => undef, + 'orig_max_jobs_running' => undef, + 'ncpus' => $ncpus, + 'sshcommand' => $sshcommand, + 'user' => $user, + 'password' => $password, + 'host' => $host, + 'port' => $port, + 'hostgroups' => \%hostgroups, + 'local' => $local, + 'control_path_dir' => undef, + 'control_path' => undef, + 'time_to_login' => undef, + 'last_login_at' => undef, + 'loadavg_file' => $Global::cache_dir . "/tmp/sshlogin/" . + $no_slash_string . "/loadavg", + 'loadavg' => undef, + 'last_loadavg_update' => 0, + 'swap_activity_file' => $Global::cache_dir . "/tmp/sshlogin/" . + $no_slash_string . "/swap_activity", + 'swap_activity' => undef, + }, ref($class) || $class; +} + +sub DESTROY($) { + my $self = shift; + # Remove temporary files if they are created. + ::rm($self->{'loadavg_file'}); + ::rm($self->{'swap_activity_file'}); +} + +sub string($) { + my $self = shift; + return $self->{'string'}; +} + +sub host($) { + my $self = shift; + return $self->{'host'}; +} + +sub sshcmd($) { + # Give the ssh command without hostname + # Returns: + # "sshpass -e ssh -p port -l user" + my $self = shift; + my @local; + # [sshpass -e] ssh -p port -l user + if($self->{'password'}) { push @local, "sshpass -e"; } + # [ssh] -p port -l user + # TODO sshpass + space + push @local, $self->{'sshcommand'}; + # [-p port] -l user + if($self->{'port'}) { push @local, '-p',$self->{'port'}; } + # [-l user] + if($self->{'user'}) { push @local, '-l',$self->{'user'}; } + if($opt::controlmaster) { + # Use control_path to make ssh faster + my $control_path = $self->control_path_dir()."/ssh-%r@%h:%p"; + + if(not $self->{'control_path'}{$control_path}++) { + # Master is not running for this control_path + # Start it + my $pid = fork(); + if($pid) { + $Global::sshmaster{$pid} ||= 1; + } else { + push @local, "-S", $control_path; + $SIG{'TERM'} = undef; + # Run a sleep that outputs data, so it will discover + # if the ssh connection closes. + my $sleep = ::Q('$|=1;while(1){sleep 1;print "foo\n"}'); + # Ignore the 'foo' being printed + open(STDOUT,">","/dev/null"); + # STDERR >/dev/null to ignore + open(STDERR,">","/dev/null"); + open(STDIN,"<","/dev/null"); + exec(@local, "-MT", $self->{'host'}, "--", + "perl", "-e", $sleep); + } + } + push @local, "-S", ::Q($control_path); + } + + return "@local"; +} + +sub wrap($@) { + # Input: + # @cmd = shell command to run on remote + # Returns: + # $sshwrapped = ssh remote @cmd + my $self = shift; + my @remote = @_; + return(join " ", + $self->sshcmd(), $self->{'host'}, "--", "exec", @remote); +} + +sub hexwrap($@) { + # Input: + # @cmd = perl expresion to eval + # Returns: + # $hexencoded = perl command that decodes hex and evals @cmd + my $self = shift; + my $cmd = join("",@_); + + # "#" is needed because Perl on MacOS X adds NULs + # when running pack q/H10000000/ + my $hex = unpack "H*", $cmd."#"; + # csh does not deal well with > 1000 chars in one word + # Insert space every 1000 char + $hex =~ s/\G.{1000}\K/ /sg; + # Explanation: + # Write this without special chars: eval pack 'H*', join '',@ARGV + # GNU_Parallel_worker = String so people can see this is from GNU Parallel + # eval+ = way to write 'eval ' without space (gives warning) + # pack+ = way to write 'pack ' without space + # q/H10000000/, = almost the same as "H*" but does not use * + # join+q//, = join '', + return('perl -X -e '. + 'GNU_Parallel_worker,eval+pack+q/H10000000/,join+q//,@ARGV '. + $hex); +} + +sub jobs_running($) { + my $self = shift; + return ($self->{'jobs_running'} || "0"); +} + +sub inc_jobs_running($) { + my $self = shift; + $self->{'jobs_running'}++; +} + +sub dec_jobs_running($) { + my $self = shift; + $self->{'jobs_running'}--; +} + +sub set_maxlength($$) { + my $self = shift; + $self->{'maxlength'} = shift; +} + +sub maxlength($) { + my $self = shift; + return $self->{'maxlength'}; +} + +sub jobs_completed() { + my $self = shift; + return $self->{'jobs_completed'}; +} + +sub in_hostgroups() { + # Input: + # @hostgroups = the hostgroups to look for + # Returns: + # true if intersection of @hostgroups and the hostgroups of this + # SSHLogin is non-empty + my $self = shift; + return grep { defined $self->{'hostgroups'}{$_} } @_; +} + +sub hostgroups() { + my $self = shift; + return keys %{$self->{'hostgroups'}}; +} + +sub inc_jobs_completed($) { + my $self = shift; + $self->{'jobs_completed'}++; + $Global::total_completed++; +} + +sub set_max_jobs_running($$) { + my $self = shift; + if(defined $self->{'max_jobs_running'}) { + $Global::max_jobs_running -= $self->{'max_jobs_running'}; + } + $self->{'max_jobs_running'} = shift; + + if(defined $self->{'max_jobs_running'}) { + # max_jobs_running could be resat if -j is a changed file + $Global::max_jobs_running += $self->{'max_jobs_running'}; + } + # Initialize orig to the first non-zero value that comes around + $self->{'orig_max_jobs_running'} ||= $self->{'max_jobs_running'}; +} + +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() { + my $self = shift; + my $script = memfreescript(); + + # TODO add sshlogin and backgrounding + # Run the script twice if it gives 0 (typically intermittent error) + $self->{'memfree'} = ::qqx($script) || ::qqx($script); + if(not $self->{'memfree'}) { + ::die_bug("Less than 1 byte memory free"); + } + #::debug("mem","New free:",$self->{'memfree'}," "); +} + +{ + my $script; + + sub memfreescript() { + # Returns: + # shellscript for giving available memory in bytes + if(not $script) { + my %script_of = ( + # /proc/meminfo + # MemFree: 7012 kB + # Buffers: 19876 kB + # Cached: 431192 kB + # SwapCached: 0 kB + "linux" => ( + q{ + print 1024 * qx{ + awk '/^((Swap)?Cached|MemFree|Buffers):/ + { sum += \$2} END { print sum }' + /proc/meminfo } + }), + # Android uses same code as GNU/Linux + "android" => ( + q{ + print 1024 * qx{ + awk '/^((Swap)?Cached|MemFree|Buffers):/ + { sum += \$2} END { print sum }' + /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 + # 1 0 0 242793 389737 5 1 0 0 0 0 0 107 978 60 1 1 99 + "hpux" => ( + q{ + print (((reverse `vmstat 1 1`)[0] + =~ /(?:\d+\D+){4}(\d+)/)[0]*1024) + }), + # $ vmstat 1 2 + # kthr memory page disk faults cpu + # r b w swap free re mf pi po fr de sr s3 s4 -- -- in sy cs us sy id + # 0 0 0 6496720 5170320 68 260 8 2 1 0 0 -0 3 0 0 309 1371 255 1 2 97 + # 0 0 0 6434088 5072656 7 15 8 0 0 0 0 0 261 0 0 1889 1899 3222 0 8 92 + # + # The second free value is correct + "solaris" => ( + q{ + print (((reverse `vmstat 1 2`)[0] + =~ /(?:\d+\D+){4}(\d+)/)[0]*1024) + }), + # hw.pagesize: 4096 + # vm.stats.vm.v_cache_count: 0 + # vm.stats.vm.v_inactive_count: 79574 + # vm.stats.vm.v_free_count: 4507 + "freebsd" => ( + q{ + for(qx{/sbin/sysctl -a}) { + if (/^([^:]+):\s+(.+)\s*$/s) { + $sysctl->{$1} = $2; + } + } + print $sysctl->{"hw.pagesize"} * + ($sysctl->{"vm.stats.vm.v_cache_count"} + + $sysctl->{"vm.stats.vm.v_inactive_count"} + + $sysctl->{"vm.stats.vm.v_free_count"}); + }), + # Mach Virtual Memory Statistics: (page size of 4096 bytes) + # Pages free: 198061. + # Pages active: 159701. + # Pages inactive: 47378. + # Pages speculative: 29707. + # Pages wired down: 89231. + # "Translation faults": 928901425. + # Pages copy-on-write: 156988239. + # Pages zero filled: 271267894. + # Pages reactivated: 48895. + # Pageins: 1798068. + # Pageouts: 257. + # Object cache: 6603 hits of 1713223 lookups (0% hit rate) + 'darwin' => ( + q{ + $vm = `vm_stat`; + print (($vm =~ /page size of (\d+)/)[0] * + (($vm =~ /Pages free:\s+(\d+)/)[0] + + ($vm =~ /Pages inactive:\s+(\d+)/)[0])); + }), + ); + my $perlscript = ""; + # Make a perl script that detects the OS ($^O) and runs + # the appropriate command + for my $os (keys %script_of) { + $perlscript .= 'if($^O eq "'.$os.'") { '.$script_of{$os}.'}'; + } + $script = "perl -e " . ::Q(::spacefree(1,$perlscript)); + } + return $script; + } +} + +sub limit($) { + # Returns: + # 0 = Below limit. Start another job. + # 1 = Over limit. Start no jobs. + # 2 = Kill youngest job + my $self = shift; + + if(not defined $self->{'limitscript'}) { + my %limitscripts = + ("io" => q! + io() { + limit=$1; + io_file=$2; + # Do the measurement in the background + ((tmp=$(tempfile); + LANG=C iostat -x 1 2 > $tmp; + mv $tmp $io_file) /dev/null & ); + perl -e '-e $ARGV[0] or exit(1); + for(reverse <>) { + /Device/ and last; + /(\S+)$/ and $max = $max > $1 ? $max : $1; } + exit ('$limit' < $max)' $io_file; + }; + io %s %s + !, + "mem" => q! + mem() { + limit=$1; + awk '/^((Swap)?Cached|MemFree|Buffers):/{ sum += $2} + END { + if (sum*1024 < '$limit'/2) { exit 2; } + else { exit (sum*1024 < '$limit') } + }' /proc/meminfo; + }; + mem %s; + !, + "load" => q! + load() { + limit=$1; + ps ax -o state,command | + grep -E '^[DOR].[^[]' | + wc -l | + perl -ne 'exit ('$limit' < $_)'; + }; + load %s + !, + ); + my ($cmd,@args) = split /\s+/,$opt::limit; + if($limitscripts{$cmd}) { + my $tmpfile = ::tmpname("parlmt"); + ++$Global::unlink{$tmpfile}; + $self->{'limitscript'} = + ::spacefree(1, sprintf($limitscripts{$cmd}, + ::multiply_binary_prefix(@args),$tmpfile)); + } else { + $self->{'limitscript'} = $opt::limit; + } + } + + my %env = %ENV; + local %ENV = %env; + $ENV{'SSHLOGIN'} = $self->string(); + system($Global::shell,"-c",$self->{'limitscript'}); + #::qqx($self->{'limitscript'}); + ::debug("limit","limit `".$self->{'limitscript'}."` result ".($?>>8)."\n"); + return $?>>8; +} + + +sub swapping($) { + my $self = shift; + my $swapping = $self->swap_activity(); + return (not defined $swapping or $swapping) +} + +sub swap_activity($) { + # If the currently known swap activity is too old: + # Recompute a new one in the background + # Returns: + # last swap activity computed + my $self = shift; + # Should we update the swap_activity file? + my $update_swap_activity_file = 0; + # Test with (on 64 core machine): + # seq 100 | parallel --lb -j100 'seq 1000 | parallel --noswap -j 1 true' + if(open(my $swap_fh, "<", $self->{'swap_activity_file'})) { + my $swap_out = <$swap_fh>; + close $swap_fh; + if($swap_out =~ /^(\d+)$/) { + $self->{'swap_activity'} = $1; + ::debug("swap", "New swap_activity: ", $self->{'swap_activity'}); + } + ::debug("swap", "Last update: ", $self->{'last_swap_activity_update'}); + if(time - $self->{'last_swap_activity_update'} > 10) { + # last swap activity update was started 10 seconds ago + ::debug("swap", "Older than 10 sec: ", $self->{'swap_activity_file'}); + $update_swap_activity_file = 1; + } + } else { + ::debug("swap", "No swap_activity file: ", $self->{'swap_activity_file'}); + $self->{'swap_activity'} = undef; + $update_swap_activity_file = 1; + } + if($update_swap_activity_file) { + ::debug("swap", "Updating swap_activity file ", $self->{'swap_activity_file'}); + $self->{'last_swap_activity_update'} = time; + my $dir = ::dirname($self->{'swap_activity_file'}); + -d $dir or eval { File::Path::mkpath($dir); }; + my $swap_activity; + $swap_activity = swapactivityscript(); + if(not $self->local()) { + $swap_activity = $self->wrap($swap_activity); + } + # Run swap_activity measuring. + # As the command can take long to run if run remote + # save it to a tmp file before moving it to the correct file + my $file = $self->{'swap_activity_file'}; + my ($dummy_fh, $tmpfile) = ::tmpfile(SUFFIX => ".swp"); + ::debug("swap", "\n", $swap_activity, "\n"); + my $qtmp = ::Q($tmpfile); + my $qfile = ::Q($file); + ::qqx("($swap_activity > $qtmp && mv $qtmp $qfile || rm $qtmp &)"); + } + return $self->{'swap_activity'}; +} + +{ + my $script; + + sub swapactivityscript() { + # Returns: + # shellscript for detecting swap activity + # + # arguments for vmstat are OS dependant + # swap_in and swap_out are in different columns depending on OS + # + if(not $script) { + my %vmstat = ( + # linux: $7*$8 + # $ vmstat 1 2 + # procs -----------memory---------- ---swap-- -----io---- -system-- ----cpu---- + # r b swpd free buff cache si so bi bo in cs us sy id wa + # 5 0 51208 1701096 198012 18857888 0 0 37 153 28 19 56 11 33 1 + # 3 0 51208 1701288 198012 18857972 0 0 0 0 3638 10412 15 3 82 0 + 'linux' => ['vmstat 1 2 | tail -n1', '$7*$8'], + + # solaris: $6*$7 + # $ vmstat -S 1 2 + # kthr memory page disk faults cpu + # r b w swap free si so pi po fr de sr s3 s4 -- -- in sy cs us sy id + # 0 0 0 4628952 3208408 0 0 3 1 1 0 0 -0 2 0 0 263 613 246 1 2 97 + # 0 0 0 4552504 3166360 0 0 0 0 0 0 0 0 0 0 0 246 213 240 1 1 98 + 'solaris' => ['vmstat -S 1 2 | tail -1', '$6*$7'], + + # darwin (macosx): $21*$22 + # $ vm_stat -c 2 1 + # Mach Virtual Memory Statistics: (page size of 4096 bytes) + # free active specul inactive throttle wired prgable faults copy 0fill reactive purged file-backed anonymous cmprssed cmprssor dcomprs comprs pageins pageout swapins swapouts + # 346306 829050 74871 606027 0 240231 90367 544858K 62343596 270837K 14178 415070 570102 939846 356 370 116 922 4019813 4 0 0 + # 345740 830383 74875 606031 0 239234 90369 2696 359 553 0 0 570110 941179 356 370 0 0 0 0 0 0 + 'darwin' => ['vm_stat -c 2 1 | tail -n1', '$21*$22'], + + # ultrix: $12*$13 + # $ vmstat -S 1 2 + # procs faults cpu memory page disk + # r b w in sy cs us sy id avm fre si so pi po fr de sr s0 + # 1 0 0 4 23 2 3 0 97 7743 217k 0 0 0 0 0 0 0 0 + # 1 0 0 6 40 8 0 1 99 7743 217k 0 0 3 0 0 0 0 0 + 'ultrix' => ['vmstat -S 1 2 | tail -1', '$12*$13'], + + # aix: $6*$7 + # $ vmstat 1 2 + # System configuration: lcpu=1 mem=2048MB + # + # kthr memory page faults cpu + # ----- ----------- ------------------------ ------------ ----------- + # r b avm fre re pi po fr sr cy in sy cs us sy id wa + # 0 0 333933 241803 0 0 0 0 0 0 10 143 90 0 0 99 0 + # 0 0 334125 241569 0 0 0 0 0 0 37 5368 184 0 9 86 5 + 'aix' => ['vmstat 1 2 | tail -n1', '$6*$7'], + + # freebsd: $8*$9 + # $ vmstat -H 1 2 + # procs memory page disks faults cpu + # r b w avm fre flt re pi po fr sr ad0 ad1 in sy cs us sy id + # 1 0 0 596716 19560 32 0 0 0 33 8 0 0 11 220 277 0 0 99 + # 0 0 0 596716 19560 2 0 0 0 0 0 0 0 11 144 263 0 1 99 + 'freebsd' => ['vmstat -H 1 2 | tail -n1', '$8*$9'], + + # mirbsd: $8*$9 + # $ vmstat 1 2 + # procs memory page disks traps cpu + # r b w avm fre flt re pi po fr sr wd0 cd0 int sys cs us sy id + # 0 0 0 25776 164968 34 0 0 0 0 0 0 0 230 259 38 4 0 96 + # 0 0 0 25776 164968 24 0 0 0 0 0 0 0 237 275 37 0 0 100 + 'mirbsd' => ['vmstat 1 2 | tail -n1', '$8*$9'], + + # netbsd: $7*$8 + # $ vmstat 1 2 + # procs memory page disks faults cpu + # r b avm fre flt re pi po fr sr w0 w1 in sy cs us sy id + # 0 0 138452 6012 54 0 0 0 1 2 3 0 4 100 23 0 0 100 + # 0 0 138456 6008 1 0 0 0 0 0 0 0 7 26 19 0 0 100 + 'netbsd' => ['vmstat 1 2 | tail -n1', '$7*$8'], + + # openbsd: $8*$9 + # $ vmstat 1 2 + # procs memory page disks traps cpu + # r b w avm fre flt re pi po fr sr wd0 wd1 int sys cs us sy id + # 0 0 0 76596 109944 73 0 0 0 0 0 0 1 5 259 22 0 1 99 + # 0 0 0 76604 109936 24 0 0 0 0 0 0 0 7 114 20 0 1 99 + 'openbsd' => ['vmstat 1 2 | tail -n1', '$8*$9'], + + # hpux: $8*$9 + # $ vmstat 1 2 + # procs memory page faults cpu + # r b w avm free re at pi po fr de sr in sy cs us sy id + # 1 0 0 247211 216476 4 1 0 0 0 0 0 102 73005 54 6 11 83 + # 1 0 0 247211 216421 43 9 0 0 0 0 0 144 1675 96 25269512791222387000 25269512791222387000 105 + 'hpux' => ['vmstat 1 2 | tail -n1', '$8*$9'], + + # dec_osf (tru64): $11*$12 + # $ vmstat 1 2 + # Virtual Memory Statistics: (pagesize = 8192) + # procs memory pages intr cpu + # r w u act free wire fault cow zero react pin pout in sy cs us sy id + # 3 181 36 51K 1895 8696 348M 59M 122M 259 79M 0 5 218 302 4 1 94 + # 3 181 36 51K 1893 8696 3 15 21 0 28 0 4 81 321 1 1 98 + 'dec_osf' => ['vmstat 1 2 | tail -n1', '$11*$12'], + + # gnu (hurd): $7*$8 + # $ vmstat -k 1 2 + # (pagesize: 4, size: 512288, swap size: 894972) + # free actv inact wired zeroed react pgins pgouts pfaults cowpfs hrat caobj cache swfree + # 371940 30844 89228 20276 298348 0 48192 19016 756105 99808 98% 876 20628 894972 + # 371940 30844 89228 20276 +0 +0 +0 +0 +42 +2 98% 876 20628 894972 + 'gnu' => ['vmstat -k 1 2 | tail -n1', '$7*$8'], + + # -nto (qnx has no swap) + #-irix + #-svr5 (scosysv) + ); + my $perlscript = ""; + # Make a perl script that detects the OS ($^O) and runs + # the appropriate vmstat command + for my $os (keys %vmstat) { + $vmstat{$os}[1] =~ s/\$/\\\\\\\$/g; # $ => \\\$ + $perlscript .= 'if($^O eq "'.$os.'") { print `'.$vmstat{$os}[0].' | awk "{print ' . + $vmstat{$os}[1] . '}"` }'; + } + $script = "perl -e " . ::Q($perlscript); + } + return $script; + } +} + +sub too_fast_remote_login($) { + my $self = shift; + if($self->{'last_login_at'} and $self->{'time_to_login'}) { + # sshd normally allows 10 simultaneous logins + # A login takes time_to_login + # So time_to_login/5 should be safe + # If now <= last_login + time_to_login/5: Then it is too soon. + my $too_fast = (::now() <= $self->{'last_login_at'} + + $self->{'time_to_login'}/5); + ::debug("run", "Too fast? $too_fast "); + return $too_fast; + } else { + # No logins so far (or time_to_login not computed): it is not too fast + return 0; + } +} + +sub last_login_at($) { + my $self = shift; + return $self->{'last_login_at'}; +} + +sub set_last_login_at($$) { + my $self = shift; + $self->{'last_login_at'} = shift; +} + +sub loadavg_too_high($) { + my $self = shift; + my $loadavg = $self->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; + } +} + + + +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 or CPU right now. So it is the server load this instant + # and not averaged over several minutes. This is needed so GNU + # Parallel will at most start one job that will push the load over + # the limit. + # + # Returns: + # $last_loadavg = last load average computed (undef if none) + + my $self = shift; + sub loadavg_cmd() { + if(not $Global::loadavg_cmd) { + # aix => "ps -ae -o state,command" # state wrong + # bsd => "ps ax -o state,command" + # sysv => "ps -ef -o s -o comm" + # cygwin => perl -ne 'close STDERR; /Name/ and print"\n"; \ + # /(Name|Pid|Ppid|State):\s+(\S+)/ and print "$2\t";' /proc/*/status | + # awk '{print $2,$1}' + # dec_osf => bsd + # dragonfly => bsd + # freebsd => bsd + # gnu => bsd + # hpux => ps -el|awk '{print $2,$14,$15}' + # irix => ps -ef -o state -o comm + # linux => bsd + # minix => ps el|awk '{print \$1,\$11}' + # mirbsd => bsd + # netbsd => bsd + # openbsd => bsd + # solaris => sysv + # svr5 => sysv + # ultrix => ps -ax | awk '{print $3,$5}' + # unixware => ps -el|awk '{print $2,$14,$15}' + my $ps = ::spacefree(1,q{ + $sysv="ps -ef -o s -o comm"; + $sysv2="ps -ef -o state -o comm"; + $bsd="ps ax -o state,command"; + # Treat threads as processes + $bsd2="ps axH -o state,command"; + $psel="ps -el|awk '{ print \$2,\$14,\$15 }'"; + $cygwin=q{ perl -ne 'close STDERR; /Name/ and print"\n"; + /(Name|Pid|Ppid|State):\s+(\S+)/ and print "$2\t";' /proc/*/status | + awk '{print $2,$1}' }; + $dummy="echo S COMMAND;echo R dummy"; + %ps=( + # TODO Find better code for AIX/Android + 'aix' => "uptime", + 'android' => "uptime", + 'cygwin' => $cygwin, + 'darwin' => $bsd, + 'dec_osf' => $sysv2, + 'dragonfly' => $bsd, + 'freebsd' => $bsd2, + 'gnu' => $bsd, + 'hpux' => $psel, + 'irix' => $sysv2, + 'linux' => $bsd2, + 'minix' => "ps el|awk '{print \$1,\$11}'", + 'mirbsd' => $bsd, + 'msys' => $cygwin, + 'netbsd' => $bsd, + 'nto' => $dummy, + 'openbsd' => $bsd, + 'solaris' => $sysv, + 'svr5' => $psel, + 'ultrix' => "ps -ax | awk '{print \$3,\$5}'", + 'MSWin32' => $sysv, + ); + print `$ps{$^O}`; + }); + # The command is too long for csh, so base64_wrap the command + $Global::loadavg_cmd = $self->hexwrap($ps); + } + return $Global::loadavg_cmd; + } + # Should we update the loadavg file? + my $update_loadavg_file = 0; + if(open(my $load_fh, "<", $self->{'loadavg_file'})) { + local $/; # $/ = undef => slurp whole file + my $load_out = <$load_fh>; + close $load_fh; + if($load_out =~ /\S/) { + # Content can be empty if ~/ is on NFS + # due to reading being non-atomic. + # + # Count lines starting with D,O,R but command does not start with [ + my $load =()= ($load_out=~/(^\s?[DOR]\S* +(?=[^\[])\S)/gm); + if($load > 0) { + # load is overestimated by 1 + $self->{'loadavg'} = $load - 1; + ::debug("load", "New loadavg: ", $self->{'loadavg'},"\n"); + } elsif ($load_out=~/average: (\d+.\d+)/) { + # AIX does not support instant load average + # 04:11AM up 21 days, 12:55, 1 user, load average: 1.85, 1.57, 1.55 + $self->{'loadavg'} = $1; + } else { + ::die_bug("loadavg_invalid_content: " . + $self->{'loadavg_file'} . "\n$load_out"); + } + } + $update_loadavg_file = 1; + } else { + ::debug("load", "No loadavg file: ", $self->{'loadavg_file'}); + $self->{'loadavg'} = undef; + $update_loadavg_file = 1; + } + if($update_loadavg_file) { + ::debug("load", "Updating loadavg file", $self->{'loadavg_file'}, "\n"); + $self->{'last_loadavg_update'} = time; + my $dir = ::dirname($self->{'swap_activity_file'}); + -d $dir or eval { File::Path::mkpath($dir); }; + -w $dir or ::die_bug("Cannot write to $dir"); + my $cmd = ""; + if($self->{'string'} ne ":") { + $cmd = $self->wrap(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", "Update load\n"); + my $file = ::Q($self->{'loadavg_file'}); + # tmpfile on same filesystem as $file + my $tmpfile = $file.$$; + $ENV{'SSHPASS'} = $self->{'password'}; + ::qqx("($cmd > $tmpfile && mv $tmpfile $file || rm $tmpfile & )"); + } + return $self->{'loadavg'}; +} + +sub max_loadavg($) { + my $self = shift; + # If --load is a file it might be changed + if($Global::max_load_file) { + my $mtime = (stat($Global::max_load_file))[9]; + if($mtime > $Global::max_load_file_last_mod) { + $Global::max_load_file_last_mod = $mtime; + for my $sshlogin (values %Global::host) { + $sshlogin->set_max_loadavg(undef); + } + } + } + if(not defined $self->{'max_loadavg'}) { + $self->{'max_loadavg'} = + $self->compute_max_loadavg($opt::load); + } + ::debug("load", "max_loadavg: ", $self->string(), " ", $self->{'max_loadavg'}); + return $self->{'max_loadavg'}; +} + +sub set_max_loadavg($$) { + my $self = shift; + $self->{'max_loadavg'} = shift; +} + +sub compute_max_loadavg($) { + # Parse the max loadaverage that the user asked for using --load + # Returns: + # max loadaverage + my $self = shift; + my $loadspec = shift; + my $load; + if(defined $loadspec) { + if($loadspec =~ /^\+(\d+)$/) { + # E.g. --load +2 + my $j = $1; + $load = + $self->ncpus() + $j; + } elsif ($loadspec =~ /^-(\d+)$/) { + # E.g. --load -2 + my $j = $1; + $load = + $self->ncpus() - $j; + } elsif ($loadspec =~ /^(\d+)\%$/) { + my $j = $1; + $load = + $self->ncpus() * $j / 100; + } elsif ($loadspec =~ /^(\d+(\.\d+)?)$/) { + $load = $1; + } elsif (-f $loadspec) { + $Global::max_load_file = $loadspec; + $Global::max_load_file_last_mod = (stat($Global::max_load_file))[9]; + $load = $self->compute_max_loadavg( + ::slurp_or_exit($Global::max_load_file) + ); + } else { + ::error("Parsing of --load failed."); + ::die_usage(); + } + if($load < 0.01) { + $load = 0.01; + } + } + return $load; +} + +sub time_to_login($) { + my $self = shift; + return $self->{'time_to_login'}; +} + +sub set_time_to_login($$) { + my $self = shift; + $self->{'time_to_login'} = shift; +} + +sub max_jobs_running($) { + my $self = shift; + if(not defined $self->{'max_jobs_running'}) { + my $nproc = $self->compute_number_of_processes($opt::jobs); + $self->set_max_jobs_running($nproc); + } + return $self->{'max_jobs_running'}; +} + +sub orig_max_jobs_running($) { + my $self = shift; + return $self->{'orig_max_jobs_running'}; +} + +sub compute_number_of_processes($) { + # Number of processes wanted and limited by system resources + # Returns: + # Number of processes + my $self = shift; + my $opt_P = shift; + my $wanted_processes = $self->user_requested_processes($opt_P); + if(not defined $wanted_processes) { + $wanted_processes = $Global::default_simultaneous_sshlogins; + } + ::debug("load", "Wanted procs: $wanted_processes\n"); + my $system_limit = + $self->processes_available_by_system_limit($wanted_processes); + ::debug("load", "Limited to procs: $system_limit\n"); + return $system_limit; +} + +{ + my @children; + my $max_system_proc_reached; + my $more_filehandles; + my %fh; + my $tmpfhname; + my $count_jobs_already_read; + my @jobs; + my $job; + my @args; + my $arg; + + sub reserve_filehandles($) { + # Reserves filehandle + my $n = shift; + for (1..$n) { + $more_filehandles &&= open($fh{$tmpfhname++}, "<", "/dev/null"); + } + } + + sub reserve_process() { + # Spawn a dummy process + my $child; + if($child = fork()) { + push @children, $child; + $Global::unkilled_children{$child} = 1; + } elsif(defined $child) { + # This is the child + # 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" 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 + exec 'sleep', 10101; + } + exit(0); + } else { + # Failed to spawn + $max_system_proc_reached = 1; + } + } + + 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 + return 1; + } elsif(defined $opt::retries and $count_jobs_already_read) { + # For retries we may need to run all jobs on this sshlogin + # so include the already read jobs for this sshlogin + $count_jobs_already_read--; + return 1; + } else { + if($opt::X or $opt::m) { + # The arguments may have to be re-spread over several jobslots + # So pessimistically only read one arg per jobslot + # instead of a full commandline + if($Global::JobQueue->{'commandlinequeue'}->{'arg_queue'}->empty()) { + if($Global::JobQueue->empty()) { + return 0; + } else { + $job = $Global::JobQueue->get(); + push(@jobs, $job); + return 1; + } + } else { + $arg = $Global::JobQueue->{'commandlinequeue'}->{'arg_queue'}->get(); + push(@args, $arg); + return 1; + } + } else { + # If there are no more command lines, then we have a process + # per command line, so no need to go further + if($Global::JobQueue->empty()) { + return 0; + } else { + $job = $Global::JobQueue->get(); + # Replacement must happen here due to seq() + $job and $job->replaced(); + push(@jobs, $job); + return 1; + } + } + } + } + + sub cleanup() { + # Cleanup: Close the files + for (values %fh) { close $_ } + # Cleanup: Kill the children + for my $pid (@children) { + kill 9, $pid; + waitpid($pid,0); + delete $Global::unkilled_children{$pid}; + } + # Cleanup: Unget the command_lines or the @args + $Global::JobQueue->{'commandlinequeue'}{'arg_queue'}->unget(@args); + @args = (); + $Global::JobQueue->unget(@jobs); + @jobs = (); + } + + 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, + # and taking > 1 second to spawn 10 extra processes + # Returns: + # Number of processes + my $self = shift; + my $wanted_processes = shift; + my $system_limit = 0; + my $slow_spawning_warning_printed = 0; + my $time = time; + $more_filehandles = 1; + $tmpfhname = "TmpFhNamE"; + + # perl uses 7 filehandles for something? + # parallel uses 1 for memory_usage + # parallel uses 4 for ? + reserve_filehandles(12); + # Two processes for load avg and ? + reserve_process(); + reserve_process(); + + # For --retries count also jobs already run + $count_jobs_already_read = $Global::JobQueue->next_seq(); + my $wait_time_for_getting_args = 0; + my $start_time = time; + if($wanted_processes < $Global::infinity) { + $Global::dummy_jobs = 1; + } + while(1) { + $system_limit >= $wanted_processes and last; + not $more_filehandles and last; + $max_system_proc_reached and last; + + my $before_getting_arg = time; + if(!$Global::dummy_jobs) { + get_args_or_jobs() or last; + } + $wait_time_for_getting_args += time - $before_getting_arg; + $system_limit++; + + # Every simultaneous process uses 2 filehandles to write to + # and 2 filehandles to read from + reserve_filehandles(4); + + # System process limit + reserve_process(); + + my $forktime = time - $time - $wait_time_for_getting_args; + ::debug("run", "Time to fork $system_limit procs: ". + $wait_time_for_getting_args, " ", $forktime, + " (processes so far: ", $system_limit,")\n"); + if($system_limit > 10 and + $forktime > 1 and + $forktime > $system_limit * 0.01) { + # It took more than 0.01 second to fork a processes on avg. + # Give the user a warning. He can press Ctrl-C if this + # sucks. + ::warning_once( + "Starting $system_limit processes took > $forktime sec.", + "Consider adjusting -j. Press CTRL-C to stop."); + } + } + cleanup(); + + if($system_limit < $wanted_processes) { + # The system_limit is less than the wanted_processes + if($system_limit < 1 and not $Global::JobQueue->empty()) { + ::error(255,"Cannot spawn any jobs.", + "Try increasing 'ulimit -u' (try: ulimit -u `ulimit -Hu`)", + "or increasing 'nproc' in /etc/security/limits.conf", + "or increasing /proc/sys/kernel/pid_max"); + } + if(not $more_filehandles) { + ::warning("Only enough file handles to run ". + $system_limit. " jobs in parallel.", + "Try running 'parallel -j0 -N $system_limit --pipe parallel -j0'", + "or increasing 'ulimit -n' (try: ulimit -n `ulimit -Hn`)", + "or increasing 'nofile' in /etc/security/limits.conf", + "or increasing /proc/sys/fs/file-max"); + } + if($max_system_proc_reached) { + ::warning("Only enough available processes to run ". + $system_limit. " jobs in parallel.", + "Try increasing 'ulimit -u' (try: ulimit -u `ulimit -Hu`)", + "or increasing 'nproc' in /etc/security/limits.conf", + "or increasing /proc/sys/kernel/pid_max"); + } + } + if($] == 5.008008 and $system_limit > 1000) { + # https://savannah.gnu.org/bugs/?36942 + $system_limit = 1000; + } + if($Global::JobQueue->empty()) { + $system_limit ||= 1; + } + if($self->string() ne ":" and + $system_limit > $Global::default_simultaneous_sshlogins) { + $system_limit = + $self->simultaneous_sshlogin_limit($system_limit); + } + return $system_limit; + } +} + +sub simultaneous_sshlogin_limit($) { + # Test by logging in wanted number of times simultaneously + # Returns: + # min($wanted_processes,$working_simultaneous_ssh_logins-1) + my $self = shift; + my $wanted_processes = shift; + if($self->{'time_to_login'}) { + return $wanted_processes; + } + + # Try twice because it guesses wrong sometimes + # Choose the minimal + my $ssh_limit = + ::min($self->simultaneous_sshlogin($wanted_processes), + $self->simultaneous_sshlogin($wanted_processes)); + if($ssh_limit < $wanted_processes) { + my $serverlogin = $self->string(); + ::warning("ssh to $serverlogin only allows ". + "for $ssh_limit simultaneous logins.", + "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 ". + "to avoid race conditions."); + # Race condition can cause problem if using all sshs. + if($ssh_limit > 1) { $ssh_limit -= 1; } + } + return $ssh_limit; +} + +sub simultaneous_sshlogin($) { + # Using $sshlogin try to see if we can do $wanted_processes + # simultaneous logins + # (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: + # $ssh_limit = Number of succesful parallel logins + local $/ = "\n"; + my $self = shift; + my $wanted_processes = shift; + my $sshdelay = $opt::sshdelay ? "sleep $opt::sshdelay;" : ""; + # TODO sh -c wrapper to work for csh + my $cmd = ($sshdelay.$self->wrap("echo simultaneouslogin"). + "&1 &")x$wanted_processes; + ::debug("init","Trying $wanted_processes logins at ".$self->string()."\n"); + open (my $simul_fh, "-|", "($cmd)|grep simultaneouslogin | wc -l") or + ::die_bug("simultaneouslogin"); + my $ssh_limit = <$simul_fh>; + close $simul_fh; + chomp $ssh_limit; + return $ssh_limit; +} + +sub set_ncpus($$) { + my $self = shift; + $self->{'ncpus'} = shift; +} + +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: + # $processes = the number of processes to run on this sshlogin + my $self = shift; + my $opt_P = shift; + my $processes; + if(defined $opt_P) { + if (-f $opt_P) { + $Global::max_procs_file = $opt_P; + my $opt_P_file = ::slurp_or_exit($Global::max_procs_file); + if($opt_P_file !~ /\S/) { + ::warning_once("$Global::max_procs_file is empty. ". + "Treated as 100%"); + $opt_P_file = "100%"; + } + $processes = $self->user_requested_processes($opt_P_file); + } else { + if($opt_P eq "0") { + # -P 0 = infinity (or at least close) + $processes = $Global::infinity; + } else { + # -P +3 and -P -1 + $opt_P =~ s/^([-+])/\$self->ncpus()$1/; + # -P 40% + $opt_P =~ s:%$:*\$self->ncpus()/100:; + $processes = eval $opt_P; + if($processes <= 0) { + # Do not go below 1 + $processes = 1; + } + } + } + $processes = ::ceil($processes); + } + return $processes; +} + +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'}) { + if($self->local()) { + 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'} = socket_core_thread()->{'threads'}; + } + } else { + my $ncpu; + $ENV{'SSHPASS'} = $self->{'password'}; + ::debug("init",("echo | ".$self->wrap("parallel --number-of-sockets"))); + if($opt::use_sockets_instead_of_threads + or + $opt::use_cpus_instead_of_cores) { + $ncpu = ::qqx("echo | ".$self->wrap("parallel --number-of-sockets")); + } elsif($opt::use_cores_instead_of_threads) { + $ncpu = ::qqx("echo | ".$self->wrap("parallel --number-of-cores")); + } else { + $ncpu = ::qqx("echo | ".$self->wrap("parallel --number-of-threads")); + } + chomp $ncpu; + if($ncpu =~ /^\s*[0-9]+\s*$/s) { + $self->{'ncpus'} = $ncpu; + } else { + ::warning("Could not figure out ". + "number of cpus on ".$self->string." ($ncpu). Using 1."); + $self->{'ncpus'} = 1; + } + } + } + return $self->{'ncpus'}; +} + + +sub nproc() { + # Returns: + # 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') { + $cpu = sct_gnu_linux($cpu); + } elsif ($^O eq 'android') { + $cpu = sct_android($cpu); + } elsif ($^O eq 'freebsd') { + $cpu = sct_freebsd($cpu); + } elsif ($^O eq 'netbsd') { + $cpu = sct_netbsd($cpu); + } elsif ($^O eq 'openbsd') { + $cpu = sct_openbsd($cpu); + } elsif ($^O eq 'gnu') { + $cpu = sct_hurd($cpu); + } elsif ($^O eq 'darwin') { + $cpu = sct_darwin($cpu); + } elsif ($^O eq 'solaris') { + $cpu = sct_solaris($cpu); + } elsif ($^O eq 'aix') { + $cpu = sct_aix($cpu); + } elsif ($^O eq 'hpux') { + $cpu = sct_hpux($cpu); + } elsif ($^O eq 'nto') { + $cpu = sct_qnx($cpu); + } elsif ($^O eq 'svr5') { + $cpu = sct_openserver($cpu); + } elsif ($^O eq 'irix') { + $cpu = sct_irix($cpu); + } elsif ($^O eq 'dec_osf') { + $cpu = sct_tru64($cpu); + } else { + # Try all methods until we find something that works + $cpu = (sct_gnu_linux($cpu) + || sct_android($cpu) + || sct_freebsd($cpu) + || sct_netbsd($cpu) + || sct_openbsd($cpu) + || sct_hurd($cpu) + || sct_darwin($cpu) + || sct_solaris($cpu) + || sct_aix($cpu) + || sct_hpux($cpu) + || sct_qnx($cpu) + || sct_openserver($cpu) + || sct_irix($cpu) + || sct_tru64($cpu) + ); + } + if(not $cpu) { + # Fall back: Set all to nproc + my $nproc = nproc(); + if($nproc) { + $cpu->{'sockets'} = + $cpu->{'cores'} = + $cpu->{'threads'} = + $cpu->{'active'} = + $nproc; + } + } + if(not $cpu) { + ::warning("Cannot figure out number of cpus. Using 1."); + $cpu->{'sockets'} = + $cpu->{'cores'} = + $cpu->{'threads'} = + $cpu->{'active'} = + 1 + } + $cpu->{'sockets'} ||= 1; + $cpu->{'threads'} ||= $cpu->{'cores'}; + $cpu->{'active'} ||= $cpu->{'threads'}; + chomp($cpu->{'sockets'}, + $cpu->{'cores'}, + $cpu->{'threads'}, + $cpu->{'active'}); + # 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 = shift; + + sub read_topology($) { + my $prefix = shift; + my %sibiling; + my %socket; + my $thread; + for($thread = 0; + -r "$prefix/cpu$thread/topology/physical_package_id"; + $thread++) { + $socket{::slurp_or_exit( + "$prefix/cpu$thread/topology/physical_package_id")}++; + } + for($thread = 0; + -r "$prefix/cpu$thread/topology/thread_siblings"; + $thread++) { + $sibiling{::slurp_or_exit( + "$prefix/cpu$thread/topology/thread_siblings")}++; + } + $cpu->{'sockets'} = keys %socket; + $cpu->{'cores'} = keys %sibiling; + $cpu->{'threads'} = $thread; + } + + sub read_cpuinfo(@) { + my @cpuinfo = @_; + $cpu->{'sockets'} = 0; + $cpu->{'cores'} = 0; + $cpu->{'threads'} = 0; + my %seen; + my %phy_seen; + my $physicalid; + for(@cpuinfo) { + # physical id : 0 + if(/^physical id.*[:](.*)/) { + $physicalid = $1; + if(not $phy_seen{$1}++) { + $cpu->{'sockets'}++; + } + } + # core id : 3 + if(/^core id.*[:](.*)/ and not $seen{$physicalid,$1}++) { + $cpu->{'cores'}++; + } + # processor : 2 + /^processor.*[:]\s*\d/i and $cpu->{'threads'}++; + } + $cpu->{'cores'} ||= $cpu->{'threads'}; + $cpu->{'cpus'} ||= $cpu->{'threads'}; + $cpu->{'sockets'} ||= 1; + } + + sub read_lscpu(@) { + my @lscpu = @_; + my $threads_per_core; + my $cores_per_socket; + for(@lscpu) { + /^CPU.s.:\s*(\d+)/ and $cpu->{'threads'} = $1; + /^Thread.s. per core:\s*(\d+)/ and $threads_per_core = $1; + /^Core.s. per socket:\s*(\d+)/ and $cores_per_socket = $1; + /^(CPU )?Socket.s.:\s*(\d+)/i and $cpu->{'sockets'} = $2; + } + if($cores_per_socket and $cpu->{'sockets'}) { + $cpu->{'cores'} = $cores_per_socket * $cpu->{'sockets'}; + } + if($threads_per_core and $cpu->{'cores'}) { + $cpu->{'threads'} = $threads_per_core * $cpu->{'cores'}; + } + if($threads_per_core and $cpu->{'threads'}) { + $cpu->{'cores'} = $cpu->{'threads'} / $threads_per_core; + } + $cpu->{'cpus'} ||= $cpu->{'threads'}; + } + + local $/ = "\n"; # If delimiter is set, then $/ will be wrong + my @cpuinfo; + my @lscpu; + if($ENV{'PARALLEL_CPUINFO'}) { + # Use CPUINFO from environment - used for testing only + read_cpuinfo(split/(?<=\n)/,$ENV{'PARALLEL_CPUINFO'}); + } elsif($ENV{'PARALLEL_LSCPU'}) { + # Use LSCPU from environment - used for testing only + read_lscpu(split/(?<=\n)/,$ENV{'PARALLEL_LSCPU'}); + } elsif(-r "$ENV{'PARALLEL_CPUPREFIX'}/cpu0/topology/thread_siblings") { + # Use CPUPREFIX from environment - used for testing only + read_topology($ENV{'PARALLEL_CPUPREFIX'}); + } elsif($cpu->{'sockets'} and $cpu->{'cores'} and $cpu->{'threads'}) { + # Skip /proc/cpuinfo - already set + } else { + # Not debugging: Look at this computer + if(!($cpu->{'sockets'} and $cpu->{'cores'} and $cpu->{'threads'}) + and + open(my $in_fh, "-|", "lscpu")) { + # Parse output from lscpu + read_lscpu(<$in_fh>); + close $in_fh; + } + if(!($cpu->{'sockets'} and $cpu->{'cores'} and $cpu->{'threads'}) + and + -r "/sys/devices/system/cpu/cpu0/topology/thread_siblings") { + read_topology("/sys/devices/system/cpu"); + } + if(!($cpu->{'sockets'} and $cpu->{'cores'} and $cpu->{'threads'}) + and + open(my $in_fh, "<", "/proc/cpuinfo")) { + # Read /proc/cpuinfo + read_cpuinfo(<$in_fh>); + close $in_fh; + } + } + if(-e "/proc/self/status" + and not $ENV{'PARALLEL_CPUINFO'} + and not $ENV{'PARALLEL_LSCPU'}) { + # 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; + $cpu->{'active'} = unpack ("%32b*", pack ("H*",$a)); + } + } + close $in_fh; + } + } + return $cpu; +} + +sub sct_android($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + # Use GNU/Linux + return sct_gnu_linux($_[0]); +} + +sub sct_freebsd($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $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 }' })); + $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 }' })); + return $cpu; +} + +sub sct_netbsd($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= ::qqx("sysctl -n hw.ncpu"); + return $cpu; +} + +sub sct_openbsd($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= ::qqx('sysctl -n hw.ncpu'); + return $cpu; +} + +sub sct_hurd($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= ::qqx("nproc"); + return $cpu; +} + +sub sct_darwin($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= + (::qqx('sysctl -n hw.physicalcpu') + or + ::qqx(qq{ sysctl -a hw | grep [^a-z]physicalcpu[^a-z] | awk '{ print \$2 }' })); + $cpu->{'threads'} ||= + (::qqx('sysctl -n hw.logicalcpu') + or + ::qqx(qq{ sysctl -a hw | grep [^a-z]logicalcpu[^a-z] | awk '{ print \$2 }' })); + return $cpu; +} + +sub sct_solaris($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + if(not $cpu->{'cores'}) { + if(-x "/usr/bin/kstat") { + my @chip_id = ::qqx("/usr/bin/kstat cpu_info|grep chip_id"); + if($#chip_id >= 0) { + $cpu->{'sockets'} ||= $#chip_id +1; + } + my @core_id = ::qqx("/usr/bin/kstat -m cpu_info|grep -w core_id|uniq"); + if($#core_id >= 0) { + $cpu->{'cores'} ||= $#core_id +1; + } + } + if(-x "/usr/sbin/psrinfo") { + my @psrinfo = ::qqx("/usr/sbin/psrinfo -p"); + if($#psrinfo >= 0) { + $cpu->{'sockets'} ||= $psrinfo[0]; + } + } + if(-x "/usr/sbin/prtconf") { + my @prtconf = ::qqx("/usr/sbin/prtconf | grep cpu..instance"); + if($#prtconf >= 0) { + $cpu->{'cores'} ||= $#prtconf +1; + } + } + } + return $cpu; +} + +sub sct_aix($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + if(not $cpu->{'cores'}) { + if(-x "/usr/sbin/lscfg") { + if(open(my $in_fh, "-|", + "/usr/sbin/lscfg -vs |grep proc | wc -l|tr -d ' '")) { + $cpu->{'cores'} = <$in_fh>; + close $in_fh; + } + } + } + if(not $cpu->{'threads'}) { + 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; + } + } + } + return $cpu; +} + +sub sct_hpux($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= + ::qqx(qq{ /usr/bin/mpsched -s 2>&1 | grep 'Locality Domain Count' | awk '{ print \$4 }'}); + $cpu->{'threads'} ||= + ::qqx(qq{ /usr/bin/mpsched -s 2>&1 | perl -ne '/Processor Count\\D+(\\d+)/ and print "\$1"'}); + return $cpu; +} + +sub sct_qnx($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + # BUG: It is not known how to calculate this. + + return $cpu; +} + +sub sct_openserver($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + if(not $cpu->{'cores'}) { + if(-x "/usr/sbin/psrinfo") { + my @psrinfo = ::qqx("/usr/sbin/psrinfo"); + if($#psrinfo >= 0) { + $cpu->{'cores'} = $#psrinfo +1; + } + } + } + $cpu->{'sockets'} ||= $cpu->{'cores'}; + return $cpu; +} + +sub sct_irix($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= + ::qqx(qq{ hinv | grep HZ | grep Processor | awk '{print \$1}' }); + return $cpu; +} + +sub sct_tru64($) { + # Returns: + # { 'sockets' => #sockets + # 'cores' => #cores + # 'threads' => #threads + # 'active' => #taskset_threads } + local $/ = "\n"; + my $cpu = shift; + $cpu->{'cores'} ||= ::qqx("sizer -pr"); + $cpu->{'sockets'} ||= $cpu->{'cores'}; + $cpu->{'threads'} ||= $cpu->{'cores'}; + + return $cpu; +} + +sub sshcommand($) { + # Returns: + # $sshcommand = the command (incl options) to run when using ssh + my $self = shift; + if (not defined $self->{'sshcommand'}) { + ::die_bug("sshcommand not set"); + } + return $self->{'sshcommand'}; +} + +sub local($) { + my $self = shift; + return $self->{'local'}; +} + +sub control_path_dir($) { + # Returns: + # $control_path_dir = dir of control path (for -M) + my $self = shift; + if(not defined $self->{'control_path_dir'}) { + $self->{'control_path_dir'} = + # Use $ENV{'TMPDIR'} as that is typically not + # NFS mounted. + # The file system must support UNIX domain sockets + File::Temp::tempdir($ENV{'TMPDIR'} + . "/ctrlpath-XXXX", + CLEANUP => 1); + } + return $self->{'control_path_dir'}; +} + +sub rsync_transfer_cmd($) { + # Command to run to transfer a file + # Input: + # $file = filename of file to transfer + # $workdir = destination dir + # Returns: + # $cmd = rsync command to run to transfer $file ("" if unreadable) + my $self = shift; + my $file = shift; + my $workdir = shift; + if(not -r $file) { + ::warning($file. " is not readable and will not be transferred."); + return "true"; + } + my $rsync_destdir; + my $relpath = ($file !~ m:^/:) || ($file =~ m:/\./:); # Is the path relative or /./? + if($relpath) { + $rsync_destdir = ::shell_quote_file($workdir); + } else { + # rsync /foo/bar / + $rsync_destdir = "/"; + } + $file = ::shell_quote_file($file); + # Make dir if it does not exist + return($self->wrap("mkdir -p $rsync_destdir") . " && " . + $self->rsync()." $file ".$self->{'host'}.":$rsync_destdir"); +} + +{ + my $rsync_fix; + my $rsync_version; + + 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 + # rsync 3.2.4 introduces a quoting bug: Add --old-args for that + # Returns: + # $rsync = "rsync" or "rsync --protocol 30 --old-args" + sub rsync_version { + if(not $rsync_version) { + my @out = `rsync --version`; + if(not @out) { + if(::which("rsync")) { + ::die_bug("'rsync --version' gave no output."); + } else { + ::error(255,"'rsync' is not in \$PATH."); + } + } + for (@out) { + # rsync version 3.1.3 protocol version 31 + # rsync version v3.2.3 protocol version 31 + if(/version v?(\d+)\.(\d+)(\.(\d+))?/) { + # 3.2.27 => 03.0227 + $rsync_version = sprintf "%02d.%02d%02d",$1,$2,$4; + } + } + $rsync_version or + ::die_bug("Cannot figure out version of rsync: @out"); + } + } + + sub rsync_fixup { + # 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_fix) { + rsync_version(); + if($rsync_version >= 3.01) { + # Version 3.1.0 or later: Downgrade to protocol 30 + $rsync_fix .= " --protocol 30"; + } + if($rsync_version >= 3.0204) { + # Version 3.2.4 .. 3.2.8: --old-args + $rsync_fix .= " --old-args"; + } + } + return $rsync_fix; + } + my $self = shift; + + return "rsync".rsync_fixup()." ".$ENV{'PARALLEL_RSYNC_OPTS'}. + " -e".::Q($self->sshcmd()); + } +} + +sub cleanup_cmd($$$) { + # Command to run to remove the remote file + # Input: + # $file = filename to remove + # $workdir = destination dir + # Returns: + # $cmd = ssh command to run to remove $file and empty parent dirs + my $self = shift; + my $file = shift; + my $workdir = shift; + my $f = $file; + if($f =~ m:/\./:) { + # foo/bar/./baz/quux => workdir/baz/quux + # /foo/bar/./baz/quux => workdir/baz/quux + $f =~ s:.*/\./:$workdir/:; + } elsif($f =~ m:^[^/]:) { + # foo/bar => workdir/foo/bar + $f = $workdir."/".$f; + } + my @subdirs = split m:/:, ::dirname($f); + my @rmdir; + my $dir = ""; + for(@subdirs) { + $dir .= $_."/"; + unshift @rmdir, ::shell_quote_file($dir); + } + my $rmdir = @rmdir ? "rmdir @rmdir 2>/dev/null;" : ""; + if(defined $opt::workdir and $opt::workdir eq "...") { + $rmdir .= "rm -rf " . ::shell_quote_file($workdir).';'; + } + my $rmf = "sh -c ". + ::Q("rm -f ".::shell_quote_file($f)." 2>/dev/null;".$rmdir); + return $self->wrap(::Q($rmf)); +} + +package JobQueue; + +sub new($) { + my $class = shift; + my $commandref = shift; + my $read_from = shift; + my $context_replace = shift; + my $max_number_of_args = shift; + my $transfer_files = shift; + my $return_files = shift; + my $template_names = shift; + my $template_contents = shift; + my $commandlinequeue = CommandLineQueue->new + ($commandref, $read_from, $context_replace, $max_number_of_args, + $transfer_files, $return_files, $template_names, $template_contents); + my @unget = (); + return bless { + 'unget' => \@unget, + 'commandlinequeue' => $commandlinequeue, + 'this_job_no' => 0, + 'total_jobs' => undef, + }, ref($class) || $class; +} + +sub get($) { + my $self = shift; + + $self->{'this_job_no'}++; + if(@{$self->{'unget'}}) { + my $job = shift @{$self->{'unget'}}; + # {%} may have changed, so flush computed values + $job && $job->flush_cache(); + return $job; + } else { + my $commandline = $self->{'commandlinequeue'}->get(); + if(defined $commandline) { + return Job->new($commandline); + } else { + $self->{'this_job_no'}--; + return undef; + } + } +} + +sub unget($) { + my $self = shift; + unshift @{$self->{'unget'}}, @_; + $self->{'this_job_no'} -= @_; +} + +sub empty($) { + my $self = shift; + my $empty = (not @{$self->{'unget'}}) && + $self->{'commandlinequeue'}->empty(); + ::debug("run", "JobQueue->empty $empty "); + return $empty; +} + +sub total_jobs($) { + my $self = shift; + if(not defined $self->{'total_jobs'}) { + if($opt::pipe and not $opt::tee) { + ::error(255,"--pipe is incompatible with --eta/--bar/--shuf"); + } + if($opt::totaljobs) { + $self->{'total_jobs'} = $opt::totaljobs; + } elsif($opt::sqlworker) { + $self->{'total_jobs'} = $Global::sql->total_jobs(); + } else { + my $record; + my @arg_records; + my $record_queue = $self->{'commandlinequeue'}{'arg_queue'}; + my $start = time; + while($record = $record_queue->get()) { + push @arg_records, $record; + if(time - $start > 10) { + ::warning("Reading ".scalar(@arg_records). + " arguments took longer than 10 seconds."); + $opt::eta && ::warning("Consider removing --eta."); + $opt::bar && ::warning("Consider removing --bar."); + $opt::shuf && ::warning("Consider removing --shuf."); + last; + } + } + while($record = $record_queue->get()) { + push @arg_records, $record; + } + if($opt::shuf and @arg_records) { + my $i = @arg_records; + while (--$i) { + my $j = int rand($i+1); + @arg_records[$i,$j] = @arg_records[$j,$i]; + } + } + $record_queue->unget(@arg_records); + # $#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'}. + " ($num_args/$max_args + $started_jobs)\n"); + } + } + return $self->{'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($) { + my $self = shift; + + return $self->{'commandlinequeue'}->seq(); +} + +sub quote_args($) { + my $self = shift; + return $self->{'commandlinequeue'}->quote_args(); +} + + +package Job; + +sub new($) { + my $class = shift; + my $commandlineref = shift; + return bless { + 'commandline' => $commandlineref, # CommandLine object + 'workdir' => undef, # --workdir + # filehandle for stdin (used for --pipe) + # filename for writing stdout to (used for --files) + # remaining data not sent to stdin (used for --pipe) + # tmpfiles to cleanup when job is done + 'unlink' => [], + # amount of data sent via stdin (used for --pipe) + 'transfersize' => 0, # size of files using --transfer + 'returnsize' => 0, # size of files using --return + 'pid' => undef, + # hash of { SSHLogins => number of times the command failed there } + 'failed' => undef, + 'sshlogin' => undef, + # The commandline wrapped with rsync and ssh + 'sshlogin_wrap' => undef, + 'exitstatus' => undef, + 'exitsignal' => undef, + # Timestamp for timeout if any + 'timeout' => undef, + 'virgin' => 1, + # Output used for SQL and CSV-output + 'output' => { 1 => [], 2 => [] }, + 'halfline' => { 1 => [], 2 => [] }, + }, ref($class) || $class; +} + +sub flush_cache($) { + my $self = shift; + $self->{'commandline'}->flush_cache(); +} + +sub replaced($) { + my $self = shift; + $self->{'commandline'} or ::die_bug("commandline empty"); + return $self->{'commandline'}->replaced(); +} + +{ + my $next_available_row; + + sub row($) { + my $self = shift; + if(not defined $self->{'row'}) { + if($opt::keeporder) { + $self->{'row'} = $self->seq(); + } else { + $self->{'row'} = ++$next_available_row; + } + } + return $self->{'row'}; + } +} + +sub seq($) { + my $self = shift; + return $self->{'commandline'}->seq(); +} + +sub set_seq($$) { + my $self = shift; + return $self->{'commandline'}->set_seq(shift); +} + +sub slot($) { + my $self = shift; + return $self->{'commandline'}->slot(); +} + +sub free_slot($) { + my $self = shift; + push @Global::slots, $self->slot(); +} + +{ + my($cattail); + + sub cattail() { + # Returns: + # $cattail = perl program for: + # cattail "decomp-prg" wpid [file_stdin] [file_to_unlink] + # decomp-prg = decompress program + # wpid = pid of writer program + # file_stdin = file_to_decompress + # file_to_unlink = unlink this file + if(not $cattail) { + $cattail = q{ + # cat followed by tail (possibly with rm as soon at the file is opened) + # If $writerpid dead: finish after this round + use Fcntl; + $|=1; + + my ($comfile, $cmd, $writerpid, $read_file, $unlink_file) = @ARGV; + if($read_file) { + open(IN,"<",$read_file) || die("cattail: Cannot open $read_file"); + } else { + *IN = *STDIN; + } + while(! -s $comfile) { + # Writer has not opened the buffer file, so we cannot remove it yet + $sleep = ($sleep < 30) ? ($sleep * 1.001 + 0.01) : ($sleep); + usleep($sleep); + } + # The writer and we have both opened the file, so it is safe to unlink it + unlink $unlink_file; + unlink $comfile; + + my $first_round = 1; + my $flags; + fcntl(IN, F_GETFL, $flags) || die $!; # Get the current flags on the filehandle + $flags |= O_NONBLOCK; # Add non-blocking to the flags + fcntl(IN, F_SETFL, $flags) || die $!; # Set the flags on the filehandle + + while(1) { + # clear EOF + seek(IN,0,1); + my $writer_running = kill 0, $writerpid; + $read = sysread(IN,$buf,131072); + if($read) { + if($first_round) { + # Only start the command if there any input to process + $first_round = 0; + open(OUT,"|-",$cmd) || die("cattail: Cannot run $cmd"); + } + + # Blocking print + while($buf) { + my $bytes_written = syswrite(OUT,$buf); + # syswrite may be interrupted by SIGHUP + substr($buf,0,$bytes_written) = ""; + } + # Something printed: Wait less next time + $sleep /= 2; + } else { + if(eof(IN) and not $writer_running) { + # Writer dead: There will never be sent more to the decompressor + close OUT; + exit; + } + # TODO This could probably be done more efficiently using select(2) + # Nothing read: Wait longer before next read + # Up to 100 milliseconds + $sleep = ($sleep < 100) ? ($sleep * 1.001 + 0.01) : ($sleep); + usleep($sleep); + } + } + + sub usleep { + # Sleep this many milliseconds. + my $secs = shift; + select(undef, undef, undef, $secs/1000); + } + }; + $cattail =~ s/#.*//mg; + $cattail =~ s/\s+/ /g; + } + return $cattail; + } +} + +sub openoutputfiles($) { + # Open files for STDOUT and STDERR + # Set file handles in $self->fh + my $self = shift; + my ($outfhw, $errfhw, $outname, $errname); + + if($opt::latestline) { + # Do not save to files: Use non-blocking pipe + my ($outfhr, $errfhr); + pipe($outfhr, $outfhw) || die; + $self->set_fh(1,'w',$outfhw); + $self->set_fh(2,'w',$outfhw); + $self->set_fh(1,'r',$outfhr); + $self->set_fh(2,'r',$outfhr); + # Make it possible to read non-blocking from the pipe + for my $fdno (1,2) { + ::set_fh_non_blocking($self->fh($fdno,'r')); + } + # Return immediately because we do not need setting filenames + return; + } elsif($Global::linebuffer and not + ($opt::keeporder or $Global::files or $opt::results or + $opt::compress or $opt::compress_program or + $opt::decompress_program)) { + # Do not save to files: Use non-blocking pipe + my ($outfhr, $errfhr); + pipe($outfhr, $outfhw) || die; + pipe($errfhr, $errfhw) || die; + $self->set_fh(1,'w',$outfhw); + $self->set_fh(2,'w',$errfhw); + $self->set_fh(1,'r',$outfhr); + $self->set_fh(2,'r',$errfhr); + # Make it possible to read non-blocking from the pipe + for my $fdno (1,2) { + ::set_fh_non_blocking($self->fh($fdno,'r')); + } + # Return immediately because we do not need setting filenames + return; + } elsif($opt::results and not $Global::csvsep and not $Global::jsonout) { + # If --results, but not --results *.csv/*.tsv + my $out = $self->{'commandline'}->results_out(); + my $seqname; + if($out eq $opt::results or $out =~ m:/$:) { + # $opt::results = simple string or ending in / + # => $out is a dir/ + # prefix/name1/val1/name2/val2/seq + $seqname = $out."seq"; + # prefix/name1/val1/name2/val2/stdout + $outname = $out."stdout"; + # prefix/name1/val1/name2/val2/stderr + $errname = $out."stderr"; + } else { + # $opt::results = replacement string not ending in / + # => $out is a file + $outname = $out; + $errname = "$out.err"; + $seqname = "$out.seq"; + } + ::write_or_exit($seqname, $self->seq()); + $outfhw = ::open_or_exit("+>", $outname); + $errfhw = ::open_or_exit("+>", $errname); + $self->set_fh(1,"unlink",""); + $self->set_fh(2,"unlink",""); + if($opt::sqlworker) { + # Save the filenames in SQL table + $Global::sql->update("SET Stdout = ?, Stderr = ? ". + "WHERE Seq = ". $self->seq(), + $outname, $errname); + } + } elsif(not $opt::ungroup) { + # To group we create temporary files for STDOUT and STDERR + # To avoid the cleanup unlink the files immediately (but keep them open) + if($Global::files) { + ($outfhw, $outname) = ::tmpfile(SUFFIX => ".par"); + ($errfhw, $errname) = ::tmpfile(SUFFIX => ".par"); + # --files => only remove stderr + $self->set_fh(1,"unlink",""); + $self->set_fh(2,"unlink",$errname); + } else { + ($outfhw, $outname) = ::tmpfile(SUFFIX => ".par"); + ($errfhw, $errname) = ::tmpfile(SUFFIX => ".par"); + $self->set_fh(1,"unlink",$outname); + $self->set_fh(2,"unlink",$errname); + } + } else { + # --ungroup + open($outfhw,">&",$Global::fh{1}) || die; + open($errfhw,">&",$Global::fh{2}) || die; + # File name must be empty as it will otherwise be printed + $outname = ""; + $errname = ""; + $self->set_fh(1,"unlink",$outname); + $self->set_fh(2,"unlink",$errname); + } + # Set writing FD + $self->set_fh(1,'w',$outfhw); + $self->set_fh(2,'w',$errfhw); + $self->set_fh(1,'name',$outname); + $self->set_fh(2,'name',$errname); + if($opt::compress) { + $self->filter_through_compress(); + } elsif(not $opt::ungroup) { + $self->grouped(); + } + if($Global::linebuffer) { + # Make it possible to read non-blocking from + # the buffer files + # Used for --linebuffer with -k, --files, --res, --compress* + for my $fdno (1,2) { + ::set_fh_non_blocking($self->fh($fdno,'r')); + } + } +} + +sub print_verbose_dryrun($) { + # If -v set: print command to stdout (possibly buffered) + # This must be done before starting the command + my $self = shift; + if($Global::verbose or $opt::dryrun) { + my $fh = $self->fh(1,"w"); + if($Global::verbose <= 1) { + print $fh $self->replaced(),"\n"; + } else { + # Verbose level > 1: Print the rsync and stuff + print $fh $self->wrapped(),"\n"; + } + } + if($opt::sqlworker) { + $Global::sql->update("SET Command = ? WHERE Seq = ".$self->seq(), + $self->replaced()); + } +} + +sub add_rm($) { + # Files to remove when job is done + my $self = shift; + push @{$self->{'unlink'}}, @_; +} + +sub get_rm($) { + # Files to remove when job is done + my $self = shift; + return @{$self->{'unlink'}}; +} + +sub cleanup($) { + # Remove files when job is done + my $self = shift; + unlink $self->get_rm(); + delete @Global::unlink{$self->get_rm()}; +} + +sub grouped($) { + my $self = shift; + # Set reading FD if using --group (--ungroup does not need) + for my $fdno (1,2) { + # Re-open the file for reading + # so fdw can be closed seperately + # and fdr can be seeked seperately (for --line-buffer) + my $fdr = ::open_or_exit("<", $self->fh($fdno,'name')); + $self->set_fh($fdno,'r',$fdr); + # Unlink if not debugging + $Global::debug or ::rm($self->fh($fdno,"unlink")); + } +} + +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. + # Input: + # $command = command to pipe data to + # Returns: + # $wrapped_command = the wrapped command + my $command = shift; + # The optimal block size differs + # It has been measured on: + # AMD 6376: 59000 + # /dev/null'; + my $script = + ::spacefree(0,q{ + if(sysread(STDIN, $buf, 1)) { + open($fh, "|-", @ARGV) || die; + syswrite($fh, $buf); + while($read = sysread(STDIN, $buf, 59000)) { + syswrite($fh, $buf); + } + close $fh; + exit ($?&127 ? 128+($?&127) : 1+$?>>8) + } + }); + ::debug("run",'Empty wrap: perl -e '.::Q($script)."\n"); + if($Global::cshell + and + length $command > 499) { + # csh does not like words longer than 1000 (499 quoted) + # $command = "perl -e '".base64_zip_eval()."' ". + # join" ",string_zip_base64( + # 'exec "'.::perl_quote_scalar($command).'"'); + return 'perl -e '.::Q($script)." ". + base64_wrap("exec \"$Global::shell\",'-c',\"". + ::perl_quote_scalar($command).'"'); + } else { + return 'perl -e '.::Q($script)." ". + $Global::shell." -c ".::Q($command); + } +} + +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) + # cattail get pid: $pid = $self->fh($fdno,'rpid'); + my $cattail = cattail(); + + for my $fdno (1,2) { + # Make a communication file. + my ($fh, $comfile) = ::tmpfile(SUFFIX => ".pac"); + close $fh; + # Compressor: (echo > $comfile; compress pipe) > output + # When the echo is written to $comfile, + # it is known that output file is opened, + # thus output file can then be removed by the decompressor. + # empty_input_wrapper is needed for plzip + my $qcom = ::Q($comfile); + my $wpid = open(my $fdw,"|-", "(echo > $qcom; ". + empty_input_wrapper($opt::compress_program).") >". + ::Q($self->fh($fdno,'name'))) || die $?; + $self->set_fh($fdno,'w',$fdw); + $self->set_fh($fdno,'wpid',$wpid); + # Decompressor: open output; -s $comfile > 0: rm $comfile output; + # decompress output > stdout + my $rpid = open(my $fdr, "-|", "perl", "-e", $cattail, $comfile, + $opt::decompress_program, $wpid, + $self->fh($fdno,'name'),$self->fh($fdno,'unlink')) + || die $?; + $self->set_fh($fdno,'r',$fdr); + $self->set_fh($fdno,'rpid',$rpid); + } +} + +sub set_fh($$$$) { + # Set file handle + my ($self, $fd_no, $key, $fh) = @_; + $self->{'fd'}{$fd_no,$key} = $fh; +} + +sub fh($) { + # Get file handle + my ($self, $fd_no, $key) = @_; + return $self->{'fd'}{$fd_no,$key}; +} + +sub write_block($) { + my $self = shift; + my $stdin_fh = $self->fh(0,"w"); + if(fork()) { + # Close in parent + close $stdin_fh; + } else { + # If writing is to a closed pipe: + # Do not call signal handler, but let nothing be written + local $SIG{PIPE} = undef; + + for my $part ( + grep { defined $_ } + $self->{'header'},$self->{'block'}) { + # syswrite may not write all in one go, + # so make sure everything is written. + my $written; + while($written = syswrite($stdin_fh,$$part)) { + substr($$part,0,$written) = ""; + } + } + close $stdin_fh; + exit(0); + } +} + +sub write($) { + my $self = shift; + my $remaining_ref = shift; + my $stdin_fh = $self->fh(0,"w"); + + my $len = length $$remaining_ref; + # syswrite may not write all in one go, + # so make sure everything is written. + my $written; + + # If writing is to a closed pipe: + # Do not call signal handler, but let nothing be written + local $SIG{PIPE} = undef; + while($written = syswrite($stdin_fh,$$remaining_ref)){ + substr($$remaining_ref,0,$written) = ""; + } +} + +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 + # Input: + # $header_ref = ref to $header to prepend + # $buffer_ref = ref to $buffer containing the block + # $endpos = length of $block to pass on + # $recstart = --recstart regexp + # $recend = --recend regexp + # Returns: + # N/A + my $self = shift; + my ($header_ref,$buffer_ref,$endpos,$recstart,$recend) = @_; + $self->{'header'} = $header_ref; + if($opt::roundrobin or $opt::remove_rec_sep or defined $opt::retries) { + my $a = ""; + if(($opt::roundrobin or defined $opt::retries) and $self->virgin()) { + $a .= $$header_ref; + } + # Job is no longer virgin + $self->set_virgin(0); + # Make a full copy because $buffer will change + $a .= substr($$buffer_ref,0,$endpos); + $self->{'block'} = \$a; + if($opt::remove_rec_sep) { + remove_rec_sep($self->{'block'},$recstart,$recend); + } + $self->{'block_length'} = length ${$self->{'block'}}; + } else { + $self->set_virgin(0); + for(substr($$buffer_ref,0,$endpos)) { + $self->{'block'} = \$_; + } + $self->{'block_length'} = $endpos + length ${$self->{'header'}}; + } + $self->{'block_pos'} = 0; + $self->add_transfersize($self->{'block_length'}); +} + +sub block_ref($) { + my $self = shift; + return $self->{'block'}; +} + +sub block_length($) { + my $self = shift; + return $self->{'block_length'}; +} + +sub remove_rec_sep($) { + # Remove --recstart and --recend from $block + # Input: + # $block_ref = reference to $block to be modified + # $recstart = --recstart + # $recend = --recend + # Uses: + # $opt::regexp = Are --recstart/--recend regexp? + # Returns: + # N/A + my ($block_ref,$recstart,$recend) = @_; + # Remove record separator + if($opt::regexp) { + $$block_ref =~ s/$recend$recstart//gom; + $$block_ref =~ s/^$recstart//os; + $$block_ref =~ s/$recend$//os; + } else { + $$block_ref =~ s/\Q$recend$recstart\E//gom; + $$block_ref =~ s/^\Q$recstart\E//os; + $$block_ref =~ s/\Q$recend\E$//os; + } +} + +sub non_blocking_write($) { + my $self = shift; + my $something_written = 0; + + my $in = $self->fh(0,"w"); + my $rv = syswrite($in, + substr(${$self->{'block'}},$self->{'block_pos'})); + if (!defined($rv) && $! == ::EAGAIN()) { + # would block - but would have written + $something_written = 0; + # avoid triggering auto expanding block size + $Global::no_autoexpand_block ||= 1; + } elsif ($self->{'block_pos'}+$rv != $self->{'block_length'}) { + # incomplete write + # Remove the written part + $self->{'block_pos'} += $rv; + $something_written = $rv; + } else { + # successfully wrote everything + # Empty block to free memory + my $a = ""; + $self->set_block(\$a,\$a,0,"",""); + $something_written = $rv; + } + ::debug("pipe", "Non-block: ", $something_written); + return $something_written; +} + + +sub virgin($) { + my $self = shift; + return $self->{'virgin'}; +} + +sub set_virgin($$) { + my $self = shift; + $self->{'virgin'} = shift; +} + +sub pid($) { + my $self = shift; + return $self->{'pid'}; +} + +sub set_pid($$) { + my $self = shift; + $self->{'pid'} = shift; +} + +sub starttime($) { + # Returns: + # UNIX-timestamp this job started + my $self = shift; + return sprintf("%.3f",$self->{'starttime'}); +} + +sub set_starttime($@) { + my $self = shift; + my $starttime = shift || ::now(); + $self->{'starttime'} = $starttime; + $opt::sqlworker and + $Global::sql->update("SET Starttime = ? WHERE Seq = ".$self->seq(), + $starttime); +} + +sub runtime($) { + # Returns: + # Run time in seconds with 3 decimals + my $self = shift; + return sprintf("%.3f", + int(($self->endtime() - $self->starttime())*1000)/1000); +} + +sub endtime($) { + # Returns: + # UNIX-timestamp this job ended + # 0 if not ended yet + my $self = shift; + return ($self->{'endtime'} || 0); +} + +sub set_endtime($$) { + my $self = shift; + my $endtime = shift; + $self->{'endtime'} = $endtime; + $opt::sqlworker and + $Global::sql->update("SET JobRuntime = ? WHERE Seq = ".$self->seq(), + $self->runtime()); +} + +sub is_timedout($) { + # Is the job timedout? + # Input: + # $delta_time = time that the job may run + # Returns: + # True or false + my $self = shift; + my $delta_time = shift; + return time > $self->{'starttime'} + $delta_time; +} + +sub kill($) { + my $self = shift; + $self->set_exitstatus(-1); + ::kill_sleep_seq($self->pid()); +} + +sub suspend($) { + my $self = shift; + my @pgrps = map { -$_ } $self->pid(); + kill "STOP", @pgrps; + $self->set_suspended(1); +} + +sub set_suspended($$) { + my $self = shift; + $self->{'suspended'} = shift; +} + +sub suspended($) { + my $self = shift; + return $self->{'suspended'}; +} + +sub resume($) { + my $self = shift; + my @pgrps = map { -$_ } $self->pid(); + kill "CONT", @pgrps; + $self->set_suspended(0); +} + +sub failed($) { + # return number of times failed for this $sshlogin + # Input: + # $sshlogin + # Returns: + # Number of times failed for $sshlogin + my $self = shift; + my $sshlogin = shift; + return $self->{'failed'}{$sshlogin}; +} + +sub failed_here($) { + # return number of times failed for the current $sshlogin + # Returns: + # Number of times failed for this sshlogin + my $self = shift; + return $self->{'failed'}{$self->sshlogin()}; +} + +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($) { + # increase the number of times failed for the current $sshlogin + my $self = shift; + $self->{'failed'}{$self->sshlogin()}++; +} + +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($) { + # increase the number of times failed for this $sshlogin + my $self = shift; + delete $self->{'failed'}{$self->sshlogin()}; +} + +sub min_failed($) { + # Returns: + # the number of sshlogins this command has failed on + # the minimal number of times this command has failed + my $self = shift; + my $min_failures = + ::min(map { $self->{'failed'}{$_} } keys %{$self->{'failed'}}); + my $number_of_sshlogins_failed_on = scalar keys %{$self->{'failed'}}; + return ($number_of_sshlogins_failed_on,$min_failures); +} + +sub total_failed($) { + # Returns: + # $total_failures = the number of times this command has failed + my $self = shift; + my $total_failures = 0; + for (values %{$self->{'failed'}}) { + $total_failures += $_; + } + return $total_failures; +} + +{ + my $script; + + sub postpone_exit_and_cleanup { + # Command to remove files and dirs (given as args) without + # affecting the exit value in $?/$status. + if(not $script) { + $script = "perl -e '". + ::spacefree(0,q{ + $bash=shift; + $csh=shift; + for(@ARGV){ + unlink; + rmdir; + } + if($bash=~s/(\d+)h/$1/) { + exit $bash; + } + exit $csh; + }). + # `echo \$?h` is needed to make fish not complain + "' ".'"`echo \\\\\\\\\$?h`" "$status" '; + } + return $script + } +} + +{ + my $script; + + 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. + if(not $script) { + # {} == $PARALLEL_TMP for --fifo + # To make it csh compatible a wrapper needs to: + # * mkfifo + # * spawn $command & + # * cat > fifo + # * waitpid to get the exit code from $command + # * be less than 1000 chars long + + # The optimal block size differs + # It has been measured on: + # AMD 6376: 4095 + # ppar -a big --pipepart --block -1 --test $1 --fifo 'cat {} >/dev/null'; + $script = "perl -e '". + (::spacefree + (0, q{ + ($s,$c,$f) = @ARGV; + # mkfifo $PARALLEL_TMP + system "mkfifo", $f; + # spawn $shell -c $command & + $pid = fork || exec $s, "-c", $c; + open($o,">",$f) || die $!; + # cat > $PARALLEL_TMP + while(sysread(STDIN,$buf,4095)){ + syswrite $o, $buf; + } + close $o; + # waitpid to get the exit code from $command + waitpid $pid,0; + # Cleanup + unlink $f; + exit $?/256; + }))."'"; + } + return $script; + } +} + +sub wrapped($) { + # Wrap command with: + # * --shellquote + # * --nice + # * --cat + # * --fifo + # * --sshlogin + # * --pipepart (@Global::cat_prepends) + # * --tee (@Global::cat_prepends) + # * --pipe + # * --tmux + # The ordering of the wrapping is important: + # * --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::nice + # $Global::shell + # $opt::cat + # $opt::fifo + # @Global::cat_prepends + # $opt::pipe + # $opt::tmux + # Returns: + # $self->{'wrapped'} = the command wrapped with the above + my $self = shift; + if(not defined $self->{'wrapped'}) { + my $command = $self->replaced(); + # Bug in Bash and Ksh when running multiline aliases + # This will force them to run correctly, but will fail in + # tcsh so we do not do it. + # $command .= "\n\n"; + 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.* + if($Global::shell =~ /zsh/) { + # The extra 'eval' will make aliases work, too + $command = $Global::parallel_env."\n". + "eval ".::Q($command); + } else { + $command = $Global::parallel_env."\n".$command; + } + } + if($opt::cat) { + # In '--cat' and '--fifo' {} == $PARALLEL_TMP. + # This is to make it possible to compute $PARALLEL_TMP on + # the fly when running remotely. + # $ENV{PARALLEL_TMP} is set in the remote wrapper before + # the command is run. + # + # Prepend 'cat > $PARALLEL_TMP;' + # Append 'unlink $PARALLEL_TMP without affecting $?' + $command = + 'cat > "$PARALLEL_TMP";'. + $command.";". postpone_exit_and_cleanup(). + '"$PARALLEL_TMP"'; + } elsif($opt::fifo) { + # Prepend fifo-wrapper. In essence: + # mkfifo {} + # ( $command ) & + # # $command must read {}, otherwise this 'cat' will block + # cat > {}; + # wait; rm {} + # without affecting $? + $command = fifo_wrap(). " ". + $Global::shell. " ". ::Q($command). ' "$PARALLEL_TMP"'. ';'; + } + # Wrap with ssh + tranferring of files + $command = $self->sshlogin_wrap($command); + if(@Global::cat_prepends) { + # --pipepart: prepend: + # < /tmp/foo perl -e 'while(@ARGV) { + # sysseek(STDIN,shift,0) || die; $left = shift; + # while($read = sysread(STDIN,$buf, ($left > 60800 ? 60800 : $left))){ + # $left -= $read; syswrite(STDOUT,$buf); + # } + # }' 0 0 0 11 | + # + # --pipepart --tee: prepend: + # < dash-a-file + # + # --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 and not $opt::roundrobin) { + # Wrap with EOF-detector to avoid starting $command if EOF. + $command = empty_input_wrapper($command); + } + if($opt::tmux) { + # Wrap command with 'tmux' + $command = $self->tmux_wrap($command); + } + if($Global::cshell + and + length $command > 499) { + # csh does not like words longer than 1000 (499 quoted) + # $command = "perl -e '".base64_zip_eval()."' ". + # join" ",string_zip_base64( + # 'exec "'.::perl_quote_scalar($command).'"'); + $command = base64_wrap("exec \"$Global::shell\",'-c',\"". + ::perl_quote_scalar($command).'"'); + } + $self->{'wrapped'} = $command; + } + return $self->{'wrapped'}; +} + +sub set_sshlogin($$) { + my $self = shift; + my $sshlogin = shift; + $self->{'sshlogin'} = $sshlogin; + delete $self->{'sshlogin_wrap'}; # If sshlogin is changed the wrap is wrong + delete $self->{'wrapped'}; + + if($opt::sqlworker) { + # Identify worker as --sqlworker often runs on different machines + # If local: Use hostname + my $host = $sshlogin->local() ? ::hostname() : $sshlogin->host(); + $Global::sql->update("SET Host = ? WHERE Seq = ".$self->seq(), $host); + } +} + +sub sshlogin($) { + my $self = shift; + return $self->{'sshlogin'}; +} + +sub string_base64($) { + # Base64 encode strings into 1000 byte blocks. + # 1000 bytes is the largest word size csh supports + # Input: + # @strings = to be encoded + # Returns: + # @base64 = 1000 byte block + $Global::use{"MIME::Base64"} ||= eval "use MIME::Base64; 1;"; + my @base64 = unpack("(A1000)*",encode_base64((join"",@_),"")); + return @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 + # Zipping will make exporting big environments work, too + # Input: + # @strings = to be encoded + # Returns: + # @base64 = 1000 byte block + my($zipin_fh, $zipout_fh,@base64); + ::open3($zipin_fh,$zipout_fh,">&STDERR","bzip2 -9"); + if(fork) { + close $zipin_fh; + $Global::use{"MIME::Base64"} ||= eval "use MIME::Base64; 1;"; + # Split base64 encoded into 1000 byte blocks + @base64 = unpack("(A1000)*",encode_base64((join"",<$zipout_fh>),"")); + close $zipout_fh; + } else { + close $zipout_fh; + print $zipin_fh @_; + close $zipin_fh; + exit; + } + ::debug("base64","Orig:@_\nAs bzip2 base64:@base64\n"); + return @base64; +} + +sub base64_zip_eval() { + # Script that: + # * reads base64 strings from @ARGV + # * decodes them + # * pipes through 'bzip2 -dc' + # * evals the result + # Reverse of string_zip_base64 + eval + # Will be wrapped in ' so single quote is forbidden + # Returns: + # $script = 1-liner for perl -e + my $script = ::spacefree(0,q{ + @GNU_Parallel = split /_/, "use_IPC::Open3;_use_MIME::Base64"; + eval"@GNU_Parallel"; + $chld = $SIG{CHLD}; + $SIG{CHLD} = "IGNORE"; + # Search for bzip2. Not found => use default path + my $zip = (grep { -x $_ } "/usr/local/bin/bzip2")[0] || "bzip2"; + # $in = stdin on $zip, $out = stdout from $zip + # Forget my() to save chars for csh + # my($in, $out,$eval); + open3($in,$out,">&STDERR",$zip,"-dc"); + if(my $perlpid = fork) { + close $in; + $eval = join "", <$out>; + close $out; + } else { + close $out; + # Pipe decoded base64 into 'bzip2 -dc' + print $in (decode_base64(join"",@ARGV)); + close $in; + exit; + } + wait; + $SIG{CHLD} = $chld; + eval $eval; + }); + ::debug("base64",$script,"\n"); + return $script; +} + +sub base64_wrap($) { + # base64 encode Perl code + # Split it into chunks of < 1000 bytes + # Prepend it with a decoder that eval's it + # Input: + # $eval_string = Perl code to run + # Returns: + # $shell_command = shell command that runs $eval_string + my $eval_string = shift; + return + "perl -e ". + ::Q(base64_zip_eval())." ". + join" ",::shell_quote(string_zip_base64($eval_string)); +} + +sub base64_eval($) { + # Script that: + # * reads base64 strings from @ARGV + # * decodes them + # * evals the result + # Reverse of string_base64 + eval + # Will be wrapped in ' so single quote is forbidden. + # Spaces are stripped so spaces cannot be significant. + # The funny 'use IPC::Open3'-syntax is to avoid spaces and + # to make it clear that this is a GNU Parallel command + # when looking at the process table. + # Returns: + # $script = 1-liner for perl -e + my $script = ::spacefree(0,q{ + @GNU_Parallel=("use","IPC::Open3;","use","MIME::Base64"); + eval "@GNU_Parallel"; + my $eval = decode_base64(join"",@ARGV); + eval $eval; + }); + ::debug("base64",$script,"\n"); + return $script; +} + +sub sshlogin_wrap($) { + # Wrap the command with the commands needed to run remotely + # Input: + # $command = command to run + # Returns: + # $self->{'sshlogin_wrap'} = command wrapped with ssh+transfer commands + sub monitor_parent_sshd_script { + # This script is to solve the problem of + # * not mixing STDERR and STDOUT + # * terminating with ctrl-c + # If its parent is ssh: all good + # If its parent is init(1): ssh died, so kill children + my $monitor_parent_sshd_script; + + if(not $monitor_parent_sshd_script) { + $monitor_parent_sshd_script = + # This will be packed in ', so only use " + ::spacefree + (0,'$shell = "'.($ENV{'PARALLEL_SHELL'} || '$ENV{SHELL}').'";'. + '$tmpdir = $ENV{"TMPDIR"} || "'. + ::perl_quote_scalar($ENV{'PARALLEL_REMOTE_TMPDIR'}).'";'. + '$nice = '.$opt::nice.';'. + '$termseq = "'.$opt::termseq.'";'. + # } + q{ + # Check that $tmpdir is writable + -w $tmpdir || + die("$tmpdir\040is\040not\040writable.". + "\040Set\040PARALLEL_REMOTE_TMPDIR"); + # Set $PARALLEL_TMP to a non-existent file name in $TMPDIR + do { + $ENV{PARALLEL_TMP} = $tmpdir."/par". + join"", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..5); + } while(-e $ENV{PARALLEL_TMP}); + # Set $script to a non-existent file name in $TMPDIR + do { + $script = $tmpdir."/parallel\043$ENV{PARALLEL_SEQ}_". + join"", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..5); + } while(-e $script); + # Create a script from the hex code + # that removes itself and runs the commands + open($fh,">",$script) || die; + # \040 = space - but we remove spaces in the script + # ' needed due to rc-shell + print($fh("rm\040\'$script\'\n",$bashfunc.$cmd)); + close $fh; + my $parent = getppid; + my $done = 0; + $SIG{CHLD} = sub { $done = 1; }; + $pid = fork; + unless($pid) { + # Make own process group to be able to kill HUP it later + eval { setpgrp }; + # Set nice value + eval { setpriority(0,0,$nice) }; + # Run the script + exec($shell,$script); + die("exec\040failed: $!"); + } + while((not $done) and (getppid == $parent)) { + # Parent pid is not changed, so sshd is alive + # Exponential sleep up to 1 sec + $s = $s < 1 ? 0.001 + $s * 1.03 : $s; + select(undef, undef, undef, $s); + } + if(not $done) { + # sshd is dead: User pressed Ctrl-C + # Kill as per --termseq + my @term_seq = split/,/,$termseq; + if(not @term_seq) { + @term_seq = ("TERM",200,"TERM",100,"TERM",50,"KILL",25); + } + while(@term_seq && kill(0,-$pid)) { + kill(shift @term_seq, -$pid); + select(undef, undef, undef, (shift @term_seq)/1000); + } + } + wait; + exit ($?&127 ? 128+($?&127) : 1+$?>>8) + }); + } + return $monitor_parent_sshd_script; + } + + sub vars_to_export { + # Uses: + # @opt::env + my @vars = ("parallel_bash_environment"); + for my $varstring (@opt::env) { + # Split up --env VAR1,VAR2 + push @vars, split /,/, $varstring; + } + for (@vars) { + if(-r $_ and not -d) { + # Read as environment definition bug #44041 + # TODO parse this + $Global::envdef = ::slurp_or_exit($_); + } + } + if(grep { /^_$/ } @vars) { + local $/ = "\n"; + # --env _ + # Include all vars that are not in a clean environment + if(open(my $vars_fh, "<", $Global::config_dir . "/ignored_vars")) { + my @ignore = <$vars_fh>; + chomp @ignore; + my %ignore; + @ignore{@ignore} = @ignore; + close $vars_fh; + push @vars, grep { not defined $ignore{$_} } keys %ENV; + @vars = grep { not /^_$/ } @vars; + } else { + ::error(255,"Run '$Global::progname --record-env' ". + "in a clean environment first."); + } + } + # Duplicate vars as BASH functions to include post-shellshock functions (v1+v2) + # So --env myfunc should look for BASH_FUNC_myfunc() and BASH_FUNC_myfunc%% + + push(@vars, "PARALLEL_PID", "PARALLEL_SEQ", + "PARALLEL_SSHLOGIN", "PARALLEL_SSHHOST", + "PARALLEL_HOSTGROUPS", "PARALLEL_ARGHOSTGROUPS", + "PARALLEL_JOBSLOT", $opt::process_slot_var, + map { ("BASH_FUNC_$_()", "BASH_FUNC_$_%%") } @vars); + # Keep only defined variables + return grep { defined($ENV{$_}) } @vars; + } + + sub env_as_eval { + # Returns: + # $eval = '$ENV{"..."}=...; ...' + my @vars = vars_to_export(); + my $csh_friendly = not grep { /\n/ } @ENV{@vars}; + my @bash_functions = grep { substr($ENV{$_},0,4) eq "() {" } @vars; + my @non_functions = (grep { !/PARALLEL_ENV/ } + grep { substr($ENV{$_},0,4) ne "() {" } @vars); + + # eval of @envset will set %ENV + my $envset = join"", map { + '$ENV{"'.::perl_quote_scalar($_).'"}="'. + ::perl_quote_scalar($ENV{$_}).'";'; } @non_functions; + + # running @bashfunc on the command line, will set the functions + my @bashfunc = map { + my $v=$_; + s/BASH_FUNC_(.*)(\(\)|%%)/$1/; + "$_$ENV{$v};\nexport -f $_ 2> /dev/null;\n" } @bash_functions; + # eval $bashfuncset will set $bashfunc + my $bashfuncset; + if(@bashfunc) { + # Functions are not supported for all shells + if($Global::shell !~ m:(^|/)(ash|bash|rbash|zsh|rzsh|dash|ksh):) { + ::warning("Shell functions may not be supported in $Global::shell."); + } + $bashfuncset = + '@bash_functions=qw('."@bash_functions".");". + ::spacefree(1,'$shell="'.($ENV{'PARALLEL_SHELL'} || '$ENV{SHELL}').'";'.q{ + if($shell=~/csh/) { + print STDERR "CSH/TCSH DO NOT SUPPORT newlines IN VARIABLES/FUNCTIONS. Unset @bash_functions\n"; + exec "false"; + } + }). + "\n".'$bashfunc = "'.::perl_quote_scalar("@bashfunc").'";'; + } else { + $bashfuncset = '$bashfunc = "";' + } + if($ENV{'parallel_bash_environment'}) { + $bashfuncset .= '$bashfunc .= "eval\ \"\$parallel_bash_environment\"\;";'; + } + ::debug("base64",$envset,$bashfuncset,"\n"); + return $csh_friendly,$envset,$bashfuncset; + } + + my $self = shift; + my $command = shift; + # TODO test that *sh -c 'parallel --env' use *sh + if(not defined $self->{'sshlogin_wrap'}{$command}) { + my $sshlogin = $self->sshlogin(); + $ENV{'PARALLEL_SEQ'} = $self->seq(); + $ENV{$opt::process_slot_var} = -1 + + ($ENV{'PARALLEL_JOBSLOT'} = $self->slot()); + $ENV{'PARALLEL_SSHLOGIN'} = $sshlogin->string(); + $ENV{'PARALLEL_SSHHOST'} = $sshlogin->host(); + if ($opt::hostgroups) { + $ENV{'PARALLEL_HOSTGROUPS'} = join '+', $sshlogin->hostgroups(); + $ENV{'PARALLEL_ARGHOSTGROUPS'} = join '+', $self->hostgroups(); + } + $ENV{'PARALLEL_PID'} = $$; + if($sshlogin->local()) { + if($opt::workdir) { + # Create workdir if needed. Then cd to it. + 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); + 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 + my ($csh_friendly,$envset,$bashfuncset) = env_as_eval(); + my $perl_code = $envset.$bashfuncset. + '@ARGV="'.::perl_quote_scalar($command).'";'. + "exec\"$Global::shell\",\"-c\",\(\$bashfunc.\"\@ARGV\"\)\;die\"exec:\$\!\\n\"\;"; + if(length $perl_code > 999 + or + not $csh_friendly + or + $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'}{$command} = base64_wrap($perl_code); + } else { + $self->{'sshlogin_wrap'}{$command} = "perl -e ".::Q($perl_code); + } + } else { + $self->{'sshlogin_wrap'}{$command} = $command; + } + } else { + my $pwd = ""; + if($opt::workdir) { + # Create remote workdir if needed. Then cd to it. + my $wd = ::pQ($self->workdir()); + $pwd = qq{system("mkdir","-p","--","$wd"); chdir "$wd" ||}. + qq{print(STDERR "parallel: Cannot chdir to $wd\\n") &&}. + qq{exit 255;}; + } + my ($csh_friendly,$envset,$bashfuncset) = env_as_eval(); + my $cmd = $command; + # q// does not quote \, so we must do that + $cmd =~ s/\\/\\\\/g; + + my $remote_command = $sshlogin->hexwrap + ($pwd.$envset.$bashfuncset.'$cmd='."q\0".$cmd."\0;". + monitor_parent_sshd_script()); + my ($pre,$post,$cleanup)=("","",""); + # --transfer + $pre .= $self->sshtransfer(); + # --return + $post .= $self->sshreturn(); + # --cleanup + $post .= $self->sshcleanup(); + if($post) { + # We need to save the exit status of the job + $post = exitstatuswrapper($post); + } + $self->{'sshlogin_wrap'}{$command} = + ($pre + . $sshlogin->wrap($remote_command) + . ";" + . $post); + } + } + return $self->{'sshlogin_wrap'}{$command}; +} + +sub fill_templates($) { + # Replace replacement strings in template(s) + # Returns: + # @templates - File names of replaced templates + my $self = shift; + + if(%opt::template) { + my @template_name = + map { $self->{'commandline'}->replace_placeholders([$_],0,0) } + @{$self->{'commandline'}{'template_names'}}; + ::debug("tmpl","Names: @template_name\n"); + for(my $i = 0; $i <= $#template_name; $i++) { + ::write_or_exit + ($template_name[$i], + $self->{'commandline'}-> + replace_placeholders([$self->{'commandline'} + {'template_contents'}[$i]],0,0)); + } + if($opt::cleanup) { + $self->add_rm(@template_name); + } + } +} + +sub filter($) { + # Replace replacement strings in filter(s) and evaluate them + # Returns: + # $run - 1=yes, undef=no + my $self = shift; + my $run = 1; + if(@opt::filter) { + for my $eval ($self->{'commandline'}-> + replace_placeholders(\@opt::filter,0,0)) { + $run &&= eval $eval; + } + $self->{'commandline'}{'skip'} ||= not $run; + } + return $run; +} + +sub transfer($) { + # Files to transfer + # Non-quoted and with {...} substituted + # Returns: + # @transfer - File names of files to transfer + my $self = shift; + + my $transfersize = 0; + my @transfer = $self->{'commandline'}-> + replace_placeholders($self->{'commandline'}{'transfer_files'},0,0); + for(@transfer) { + # filesize + if(-e $_) { + $transfersize += (stat($_))[7]; + } + } + $self->add_transfersize($transfersize); + return @transfer; +} + +sub transfersize($) { + my $self = shift; + return $self->{'transfersize'}; +} + +sub add_transfersize($) { + my $self = shift; + my $transfersize = shift; + $self->{'transfersize'} += $transfersize; + $opt::sqlworker and + $Global::sql->update("SET Send = ? WHERE Seq = ".$self->seq(), + $self->{'transfersize'}); +} + +sub sshtransfer($) { + # Returns for each transfer file: + # rsync $file remote:$workdir + my $self = shift; + my @pre; + my $sshlogin = $self->sshlogin(); + my $workdir = $self->workdir(); + for my $file ($self->transfer()) { + push @pre, $sshlogin->rsync_transfer_cmd($file,$workdir).";"; + } + return join("",@pre); +} + +sub return($) { + # Files to return + # Non-quoted and with {...} substituted + # Returns: + # @non_quoted_filenames + my $self = shift; + return $self->{'commandline'}-> + replace_placeholders($self->{'commandline'}{'return_files'},0,0); +} + +sub returnsize($) { + # This is called after the job has finished + # Returns: + # $number_of_bytes transferred in return + my $self = shift; + for my $file ($self->return()) { + if(-e $file) { + $self->{'returnsize'} += (stat($file))[7]; + } + } + return $self->{'returnsize'}; +} + +sub add_returnsize($) { + my $self = shift; + my $returnsize = shift; + $self->{'returnsize'} += $returnsize; + $opt::sqlworker and + $Global::sql->update("SET Receive = ? WHERE Seq = ".$self->seq(), + $self->{'returnsize'}); +} + +sub sshreturn($) { + # Returns for each return-file: + # rsync remote:$workdir/$file . + my $self = shift; + my $sshlogin = $self->sshlogin(); + my $pre = ""; + for my $file ($self->return()) { + $file =~ s:^\./::g; # Remove ./ if any + my $relpath = ($file !~ m:^/:) || + ($file =~ m:/\./:); # Is the path relative or /./? + my $cd = ""; + my $wd = ""; + if($relpath) { + # rsync -avR /foo/./bar/baz.c remote:/tmp/ + # == (on old systems) + # rsync -avR --rsync-path="cd /foo; rsync" remote:bar/baz.c /tmp/ + $wd = ::shell_quote_file($self->workdir()."/"); + } + # Only load File::Basename if actually needed + $Global::use{"File::Basename"} ||= eval "use File::Basename; 1;"; + # dir/./file means relative to dir, so remove dir on remote + $file =~ m:(.*)/\./:; + my $basedir = $1 ? ::shell_quote_file($1."/") : ""; + my $nobasedir = $file; + $nobasedir =~ s:.*/\./::; + $cd = ::shell_quote_file(::dirname($nobasedir)); + 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 + # --rsync-path="cd /home/tange/dir/subdir/; rsync" + # server:file.gz /home/tange/dir/subdir/ + $pre .= "mkdir -p $basedir$cd" . " && " . + $sshlogin->rsync(). " $rsync_cd -- ".$sshlogin->host().':'. + $basename . " ".$basedir.$cd.";"; + } + return $pre; +} + +sub sshcleanup($) { + # Return the sshcommand needed to remove the file + # Returns: + # ssh command needed to remove files from sshlogin + my $self = shift; + my $sshlogin = $self->sshlogin(); + my $workdir = $self->workdir(); + my $cleancmd = ""; + + for my $file ($self->remote_cleanup()) { + my @subworkdirs = parentdirs_of($file); + $cleancmd .= $sshlogin->cleanup_cmd($file,$workdir).";"; + } + if(defined $opt::workdir and $opt::workdir eq "...") { + $cleancmd .= $sshlogin->wrap("rm -rf " . ::Q($workdir).';'); + } + return $cleancmd; +} + +sub remote_cleanup($) { + # Returns: + # Files to remove at cleanup + my $self = shift; + if($opt::cleanup) { + my @transfer = $self->transfer(); + my @return = $self->return(); + return (@transfer,@return); + } else { + return (); + } +} + +sub exitstatuswrapper(@) { + # Input: + # @shellcode = shell code to execute + # Returns: + # shell script that returns current status after executing @shellcode + if($Global::cshell) { + return ('set _EXIT_status=$status; ' . + join(" ",@_). + 'exit $_EXIT_status;'); + } elsif($Global::fish) { + return ('export _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; + if(not defined $self->{'workdir'}) { + my $workdir; + if(defined $opt::workdir) { + if($opt::workdir eq ".") { + # . means current dir + my $home = $ENV{'HOME'}; + eval 'use Cwd'; + my $cwd = cwd(); + $workdir = $cwd; + if($home) { + # If homedir exists: remove the homedir from + # workdir if cwd starts with homedir + # E.g. /home/foo/my/dir => my/dir + # E.g. /tmp/my/dir => /tmp/my/dir + my ($home_dev, $home_ino) = (stat($home))[0,1]; + my $parent = ""; + my @dir_parts = split(m:/:,$cwd); + my $part; + while(defined ($part = shift @dir_parts)) { + $part eq "" and next; + $parent .= "/".$part; + my ($parent_dev, $parent_ino) = (stat($parent))[0,1]; + if($parent_dev == $home_dev and $parent_ino == $home_ino) { + # dev and ino is the same: We found the homedir. + $workdir = join("/",@dir_parts); + last; + } + } + } + if($workdir eq "") { + $workdir = "."; + } + } elsif($opt::workdir eq "...") { + $workdir = ".parallel/tmp/" . ::hostname() . "-" . $$ + . "-" . $self->seq(); + } else { + $workdir = $self->{'commandline'}-> + replace_placeholders([$opt::workdir],0,0); + #$workdir = $opt::workdir; + # Rsync treats /./ special. We dont want that + $workdir =~ s:/\./:/:g; # Remove /./ + $workdir =~ s:(.)/+$:$1:; # Remove ending / if any + $workdir =~ s:^\./::g; # Remove starting ./ if any + } + } else { + $workdir = "."; + } + $self->{'workdir'} = $workdir; + } + return $self->{'workdir'}; +} + +sub parentdirs_of($) { + # Return: + # all parentdirs except . of this dir or file - sorted desc by length + my $d = shift; + my @parents = (); + while($d =~ s:/[^/]+$::) { + if($d ne ".") { + push @parents, $d; + } + } + return @parents; +} + +sub start($) { + # Setup STDOUT and STDERR for a job and start it. + # Returns: + # job-object or undef if job not to run + + sub open3_setpgrp_internal { + # Run open3+setpgrp followed by the command + # Input: + # $stdin_fh = Filehandle to use as STDIN + # $stdout_fh = Filehandle to use as STDOUT + # $stderr_fh = Filehandle to use as STDERR + # $command = Command to run + # Returns: + # $pid = Process group of job started + my ($stdin_fh,$stdout_fh,$stderr_fh,$command) = @_; + my $pid; + local (*OUT,*ERR); + open OUT, '>&', $stdout_fh or ::die_bug("Can't dup STDOUT: $!"); + open ERR, '>&', $stderr_fh or ::die_bug("Can't dup STDERR: $!"); + # The eval is needed to catch exception from open3 + eval { + if(not $pid = ::open3($stdin_fh, ">&OUT", ">&ERR", "-")) { + # Each child gets its own process group to make it safe to killall + eval{ setpgrp(0,0) }; + eval{ setpriority(0,0,$opt::nice) }; + exec($Global::shell,"-c",$command) + || ::die_bug("open3-$stdin_fh ".substr($command,0,200)); + } + }; + return $pid; + } + + sub open3_setpgrp_external { + # Run open3 on $command wrapped with a perl script doing setpgrp + # Works on systems that do not support open3(,,,"-") + # Input: + # $stdin_fh = Filehandle to use as STDIN + # $stdout_fh = Filehandle to use as STDOUT + # $stderr_fh = Filehandle to use as STDERR + # $command = Command to run + # Returns: + # $pid = Process group of job started + my ($stdin_fh,$stdout_fh,$stderr_fh,$command) = @_; + local (*OUT,*ERR); + open OUT, '>&', $stdout_fh or ::die_bug("Can't dup STDOUT: $!"); + open ERR, '>&', $stderr_fh or ::die_bug("Can't dup STDERR: $!"); + + my $pid; + my @setpgrp_wrap = + ('perl','-e', + "eval\{setpgrp\}\;eval\{setpriority\(0,0,$opt::nice\)\}\;". + "exec '$Global::shell', '-c', \@ARGV"); + # The eval is needed to catch exception from open3 + eval { + $pid = ::open3($stdin_fh, ">&OUT", ">&ERR", @setpgrp_wrap, $command) + || ::die_bug("open3-$stdin_fh"); + 1; + }; + return $pid; + } + + sub redefine_open3_setpgrp { + my $setgprp_cache = shift; + # Select and run open3_setpgrp_internal/open3_setpgrp_external + no warnings 'redefine'; + my ($outfh,$name) = ::tmpfile(SUFFIX => ".tst"); + # Test to see if open3(x,x,x,"-") is fully supported + # Can an exported bash function be called via open3? + my $script = 'if($pid=::open3($i,$o,$e,"-")) { wait; } '. + 'else { exec("bash","-c","testfun && true"); }'; + my $bash = + ::shell_quote_scalar_default( + "testfun() { rm $name; }; export -f testfun; ". + "perl -MIPC::Open3 -e ". + ::Q(::Q($script)) + ); + my $redefine_eval; + # Redirect STDERR temporarily, + # so errors on MacOS X are ignored. + open my $saveerr, ">&STDERR"; + open STDERR, '>', "/dev/null"; + # Run the test + ::debug("init",qq{bash -c $bash 2>/dev/null}); + qx{ bash -c $bash 2>/dev/null }; + open STDERR, ">&", $saveerr; + + if(-e $name) { + # Does not support open3(x,x,x,"-") + # or does not have bash: + # Use (slow) external version + unlink($name); + $redefine_eval = '*open3_setpgrp = \&open3_setpgrp_external'; + ::debug("init","open3_setpgrp_external chosen\n"); + } else { + # Supports open3(x,x,x,"-") + # This is 0.5 ms faster to run + $redefine_eval = '*open3_setpgrp = \&open3_setpgrp_internal'; + ::debug("init","open3_setpgrp_internal chosen\n"); + } + if(open(my $fh, ">", $setgprp_cache)) { + print $fh $redefine_eval; + close $fh; + } else { + ::debug("init","Cannot write to $setgprp_cache"); + } + eval $redefine_eval; + } + + sub open3_setpgrp { + my $setgprp_cache = $Global::cache_dir . "/tmp/sshlogin/" . + ::hostname() . "/setpgrp_func"; + sub read_cache() { + -e $setgprp_cache || return 0; + local $/ = undef; + open(my $fh, "<", $setgprp_cache) || return 0; + eval <$fh> || return 0; + close $fh; + return 1; + } + if(not read_cache()) { + redefine_open3_setpgrp($setgprp_cache); + } + # The sub is now redefined. Call it + return open3_setpgrp(@_); + } + + my $job = shift; + # Get the shell command to be executed (possibly with ssh infront). + my $command = $job->wrapped(); + my $pid; + + if($Global::interactive or $Global::stderr_verbose) { + $job->interactive_start(); + } + # Must be run after $job->interactive_start(): + # $job->interactive_start() may call $job->skip() + if($job->{'commandline'}{'skip'} + or + not $job->filter()) { + # $job->skip() was called or job filtered + $command = "true"; + } + $job->openoutputfiles(); + $job->print_verbose_dryrun(); + my($stdout_fh,$stderr_fh) = ($job->fh(1,"w"),$job->fh(2,"w")); + if($opt::dryrun or $opt::sqlmaster) { $command = "true"; } + $ENV{'PARALLEL_SEQ'} = $job->seq(); + $ENV{'PARALLEL_PID'} = $$; + $ENV{$opt::process_slot_var} = -1 + + ($ENV{'PARALLEL_JOBSLOT'} = $job->slot()); + $ENV{'PARALLEL_TMP'} = ::tmpname("par"); + $job->add_rm($ENV{'PARALLEL_TMP'}); + $job->fill_templates(); + $ENV{'SSHPASS'} = $job->{'sshlogin'}->{'password'}; + ::debug("run", $Global::total_running, " processes . Starting (", + $job->seq(), "): $command\n"); + if($opt::pipe) { + my ($stdin_fh) = ::gensym(); + $pid = open3_setpgrp($stdin_fh,$stdout_fh,$stderr_fh,$command); + if($opt::roundrobin and not $opt::keeporder) { + # --keep-order will make sure the order will be reproducible + ::set_fh_non_blocking($stdin_fh); + } + $job->set_fh(0,"w",$stdin_fh); + if($opt::tee or $opt::shard or $opt::bin) { $job->set_virgin(0); } + } elsif(($opt::tty or $opt::open_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 + # The eval is needed to catch exception from open3 + local (*IN,*OUT,*ERR); + open OUT, '>&', $stdout_fh or ::die_bug("Can't dup STDOUT: $!"); + open ERR, '>&', $stderr_fh or ::die_bug("Can't dup STDERR: $!"); + *IN = $devtty_fh; + # The eval is needed to catch exception from open3 + my @wrap = ('perl','-e', + "eval\{setpriority\(0,0,$opt::nice\)\}\;". + "exec '$Global::shell', '-c', \@ARGV"); + eval { + $pid = ::open3("<&IN", ">&OUT", ">&ERR", @wrap, $command) + || ::die_bug("open3-/dev/tty"); + 1; + }; + close $devtty_fh; + $job->set_virgin(0); + } elsif($Global::semaphore) { + # Allow sem to read from stdin + $pid = open3_setpgrp("<&STDIN",$stdout_fh,$stderr_fh,$command); + $job->set_virgin(0); + } else { + $pid = open3_setpgrp(::gensym(),$stdout_fh,$stderr_fh,$command); + $job->set_virgin(0); + } + if($pid) { + # A job was started + $Global::total_running++; + $Global::total_started++; + $job->set_pid($pid); + $job->set_starttime(); + $Global::running{$job->pid()} = $job; + if($opt::timeout) { + $Global::timeoutq->insert($job); + } + $Global::newest_job = $job; + $Global::newest_starttime = ::now(); + return $job; + } else { + # No more processes + ::debug("run", "Cannot spawn more jobs.\n"); + return undef; + } +} + +sub interactive_start($) { + my $self = shift; + my $command = $self->wrapped(); + if($Global::interactive) { + my $answer; + ::status_no_nl("$command ?..."); + do{ + my $tty_fh = ::open_or_exit("<","/dev/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 { + print $Global::original_stderr "$command\n"; + } +} + +{ + my $tmuxsocket; + my $qsocket; + + sub tmux_wrap($) { + # Wrap command with tmux for session pPID + # Input: + # $actual_command = the actual command being run (incl ssh wrap) + my $self = shift; + my $actual_command = shift; + # Temporary file name. Used for fifo to communicate exit val + my $tmpfifo = ::tmpname("tmx"); + $self->add_rm($tmpfifo); + if(length($tmpfifo) >=100) { + ::error(255,"tmux does not support sockets with path > 100."); + } + if($opt::tmuxpane) { + # Move the command into a pane in window 0 + $actual_command = $ENV{'PARALLEL_TMUX'}.' joinp -t :0 ; '. + $ENV{'PARALLEL_TMUX'}.' select-layout -t :0 tiled ; '. + $actual_command; + } + my $visual_command = $self->replaced(); + my $title = $visual_command; + if($visual_command =~ /\0/) { + ::error(255,"Command line contains NUL. ". + "tmux is confused by NUL."); + } + # ; causes problems + # ascii 194-245 annoys tmux + $title =~ tr/[\011-\016;\302-\365]/ /s; + $title = ::Q($title); + + my $l_act = length($actual_command); + my $l_tit = length($title); + my $l_fifo = length($tmpfifo); + # 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 = ::Q(" ")x75; + while($l_tit < 1000 and + ( + (890 < $l_tot and $l_tot < 1350) + or + (9250 < $l_tot and $l_tot < 9800) + )) { + # tmux blocks for certain lengths: + # 900 < title + command < 1200 + # 9250 < title + command < 9800 + # but only if title < 1000, so expand the title with 75 spaces + # The measured lengths are: + # 996 < (title + whole command) < 1127 + # 9331 < (title + whole command) < 9636 + $title .= $quoted_space75; + $l_tit = length($title); + $l_tot = 2 * $l_tit + $l_act + $l_fifo; + } + + my $tmux; + $ENV{'PARALLEL_TMUX'} ||= "tmux"; + if(not $tmuxsocket) { + $tmuxsocket = ::tmpname("tms"); + $qsocket = ::Q($tmuxsocket); + ::debug("tmux", "Start: $ENV{'PARALLEL_TMUX'} -S $qsocket attach"); + if($opt::fg) { + if(not fork) { + # Run tmux in the foreground + # Wait for the socket to appear + while (not -e $tmuxsocket) { } + `$ENV{'PARALLEL_TMUX'} -S $qsocket attach`; + exit; + } + } + ::status("See output with: $ENV{'PARALLEL_TMUX'} -S $qsocket attach"); + } + $tmux = "sh -c ".::Q( + $ENV{'PARALLEL_TMUX'}. + " -S $qsocket new-session -s p$$ -d \"sleep .2\" >/dev/null 2>&1").";" . + $ENV{'PARALLEL_TMUX'}. + " -S $qsocket new-window -t p$$ -n $title"; + + ::debug("tmux", "title len:", $l_tit, " act ", $l_act, " max ", + $Limits::Command::line_max_len, " tot ", + $l_tot, "\n"); + return "mkfifo ".::Q($tmpfifo)." && $tmux ". + # Run in tmux + ::Q + ( + "(".$actual_command.');'. + # The triple print is needed - otherwise the testsuite fails + q[ perl -e 'while($t++<3){ print $ARGV[0],"\n" }' $?h/$status >> ]. + ::Q($tmpfifo)."&". + "echo $title; echo \007Job finished at: `date`;sleep 10" + ). + # Run outside tmux + # Read a / separated line: 0h/2 for csh, 2/0 for bash. + # If csh the first will be 0h, so use the second as exit value. + # Otherwise just use the first value as exit value. + q{; exec perl -e '$/="/";$_=<>;$c=<>;unlink $ARGV; }. + q{/(\d+)h/ and exit($1);exit$c' }.::Q($tmpfifo); + } +} + +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 + my $job = $_[0]; + if($Global::csvsep) { + if($opt::joblog) { + # OK: You can look for job run in joblog + return 0 + } else { + ::warning_once( + "--resume --results .csv/.tsv/.json is not supported yet\n"); + # TODO read and parse the file + return 0 + } + } + my $out = $job->{'commandline'}->results_out(); + ::debug("run", "Test ${out}stdout", -e "${out}stdout", "\n"); + return(-e $out."stdout" or -f $out); +} + +sub is_already_in_joblog($) { + my $job = shift; + return vec($Global::job_already_run,$job->seq(),1); +} + +sub set_job_in_joblog($) { + my $job = shift; + vec($Global::job_already_run,$job->seq(),1) = 1; +} + +sub should_be_retried($) { + # Should this job be retried? + # Returns + # 0 - do not retry + # 1 - job queued for retry + my $self = shift; + if (not defined $opt::retries) { return 0; } + if(not $self->exitstatus() and not $self->exitsignal()) { + # Completed with success. If there is a recorded failure: forget it + $self->reset_failed_here(); + return 0; + } else { + # The job failed. Should it be retried? + $self->add_failed_here(); + my $retries = $self->{'commandline'}-> + replace_placeholders([$opt::retries],0,0); + # 0 = Inf + if($retries == 0) { $retries = 2**31; } + # Ignore files already unlinked to avoid memory leak + $self->{'unlink'} = [ grep { -e $_ } @{$self->{'unlink'}} ]; + map { -e $_ or delete $Global::unlink{$_} } keys %Global::unlink; + if($self->total_failed() == $retries) { + # This has been retried enough + return 0; + } else { + # This command should be retried + $self->set_endtime(undef); + $self->reset_exitstatus(); + $Global::JobQueue->unget($self); + ::debug("run", "Retry ", $self->seq(), "\n"); + return 1; + } + } +} + +{ + my (%print_later,$job_seq_to_print); + + sub print_earlier_jobs($) { + # Print jobs whose output is postponed due to --keep-order + # Returns: N/A + my $job = shift; + $print_later{$job->seq()} = $job; + $job_seq_to_print ||= 1; + my $returnsize = 0; + ::debug("run", "Looking for: $job_seq_to_print ", + "This: ", $job->seq(), "\n"); + for(;vec($Global::job_already_run,$job_seq_to_print,1); + $job_seq_to_print++) {} + while(my $j = $print_later{$job_seq_to_print}) { + $returnsize += $j->print(); + if($j->endtime()) { + # Job finished - look at the next + delete $print_later{$job_seq_to_print}; + $job_seq_to_print++; + next; + } else { + # Job not finished yet - look at it again next round + last; + } + } + return $returnsize; + } +} + +sub print($) { + # Print the output of the jobs + # Returns: N/A + my $self = shift; + + ::debug("print", ">>joboutput ", $self->replaced(), "\n"); + if($opt::dryrun) { + # Nothing was printed to this job: + # cleanup tmp files if --files was set + ::rm($self->fh(1,"name")); + } + if($opt::pipe and $self->virgin() and not $opt::tee) { + # Skip --joblog, --dryrun, --verbose + } else { + if($opt::ungroup) { + # NULL returnsize = 0 returnsize + $self->returnsize() or $self->add_returnsize(0); + if($Global::joblog and defined $self->{'exitstatus'}) { + # Add to joblog when finished + $self->print_joblog(); + # Printing is only relevant for grouped/--line-buffer output. + $opt::ungroup and return; + } + } + # Check for disk full + ::exit_if_disk_full(); + } + + my $returnsize = $self->returnsize(); + my @fdno; + if($opt::latestline) { + @fdno = (1); + } else { + @fdno = (sort { $a <=> $b } keys %Global::fh); + } + for my $fdno (@fdno) { + # Sort by file descriptor numerically: 1,2,3,..,9,10,11 + $fdno == 0 and next; + my $out_fh = $Global::fh{$fdno}; + my $in_fh = $self->fh($fdno,"r"); + if(not $in_fh) { + if(not $Job::file_descriptor_warning_printed{$fdno}++) { + # ::warning("File descriptor $fdno not defined\n"); + } + next; + } + ::debug("print", "File descriptor $fdno (", $self->fh($fdno,"name"), "):\n"); + if($Global::linebuffer) { + # Line buffered print out + $self->print_linebuffer($fdno,$in_fh,$out_fh); + } elsif($Global::files) { + $self->print_files($fdno,$in_fh,$out_fh); + } elsif($opt::results) { + $self->print_results($fdno,$in_fh,$out_fh); + } else { + $self->print_normal($fdno,$in_fh,$out_fh); + } + flush $out_fh; + } + ::debug("print", "<{'exitstatus'} + and not ($self->virgin() and $opt::pipe)) { + if($Global::joblog and not $opt::sqlworker) { + # Add to joblog when finished + $self->print_joblog(); + } + if($opt::sqlworker and not $opt::results) { + $Global::sql->output($self); + } + if($Global::csvsep) { + # Add output to CSV when finished + $self->print_csv(); + } + if($Global::jsonout) { + $self->print_json(); + } + } + return $returnsize - $self->returnsize(); +} + +{ + my %jsonmap; + + sub print_json($) { + my $self = shift; + sub jsonquote($) { + my $a = shift; + if(not $jsonmap{"\001"}) { + map { $jsonmap{sprintf("%c",$_)} = + sprintf '\u%04x', $_ } 0..31; + } + $a =~ s/\\/\\\\/g; + $a =~ s/\"/\\"/g; + $a =~ s/([\000-\037])/$jsonmap{$1}/g; + return $a; + } + + my $cmd; + if($Global::verbose <= 1) { + $cmd = jsonquote($self->replaced()); + } else { + # Verbose level > 1: Print the rsync and stuff + $cmd = jsonquote(join " ", @{$self->{'commandline'}}); + } + my $record_ref = $self->{'commandline'}{'arg_list_flat_orig'}; + + # Memory optimization: Overwrite with the joined output + $self->{'output'}{1} = join("", @{$self->{'output'}{1}}); + $self->{'output'}{2} = join("", @{$self->{'output'}{2}}); + # { + # "Seq": 12, + # "Host": "/usr/bin/ssh foo@lo", + # "Starttime": 1608344711.743, + # "JobRuntime": 0.01, + # "Send": 0, + # "Receive": 10, + # "Exitval": 0, + # "Signal": 0, + # "Command": "echo 1", + # "V": [ + # "1" + # ], + # "Stdout": "1\n", + # "Stderr": "" + # } + # + printf($Global::csv_fh + q({ "Seq": %s, "Host": "%s", "Starttime": %s, "JobRuntime": %s, ). + q("Send": %s, "Receive": %s, "Exitval": %s, "Signal": %s, ). + q("Command": "%s", "V": [ %s ], "Stdout": "%s", "Stderr": "%s" }). + "\n", + $self->seq(), + jsonquote($self->sshlogin()->string()), + $self->starttime(), sprintf("%0.3f",$self->runtime()), + $self->transfersize(), $self->returnsize(), + $self->exitstatus(), $self->exitsignal(), $cmd, + (join ",", + map { '"'.jsonquote($_).'"' } @$record_ref[1..$#$record_ref], + ), + jsonquote($self->{'output'}{1}), + jsonquote($self->{'output'}{2}) + ); + } +} + +{ + my $header_printed; + + 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 = join " ", @{$self->{'commandline'}}; + } + my $record_ref = $self->{'commandline'}{'arg_list_flat_orig'}; + + if(not $header_printed) { + # Variable headers + # Normal => V1..Vn + # --header : => first value from column + my @V; + if($opt::header) { + my $i = 1; + @V = (map { $Global::input_source_header{$i++} } + @$record_ref[1..$#$record_ref]); + } else { + my $V = "V1"; + @V = (map { $V++ } @$record_ref[1..$#$record_ref]); + } + print $Global::csv_fh + (map { $$_ } + combine_ref("Seq", "Host", "Starttime", "JobRuntime", + "Send", "Receive", "Exitval", "Signal", "Command", + @V, + "Stdout","Stderr" + )),"\n"; + $header_printed++; + } + # Memory optimization: Overwrite with the joined output + $self->{'output'}{1} = join("", @{$self->{'output'}{1}}); + $self->{'output'}{2} = join("", @{$self->{'output'}{2}}); + print $Global::csv_fh + (map { $$_ } + combine_ref + ($self->seq(), + $self->sshlogin()->string(), + $self->starttime(), sprintf("%0.3f",$self->runtime()), + $self->transfersize(), $self->returnsize(), + $self->exitstatus(), $self->exitsignal(), \$cmd, + \@$record_ref[1..$#$record_ref], + \$self->{'output'}{1}, + \$self->{'output'}{2})),"\n"; + } +} + +sub combine_ref($) { + # Inspired by Text::CSV_PP::_combine (by Makamaka Hannyaharamitu) + my @part = @_; + my $sep = $Global::csvsep; + my $quot = '"'; + my @out = (); + + my $must_be_quoted; + for my $column (@part) { + # Memory optimization: Content transferred as reference + if(ref $column ne "SCALAR") { + # Convert all columns to scalar references + my $v = $column; + $column = \$v; + } + if(not defined $$column) { + $$column = ''; + next; + } + + $must_be_quoted = 0; + + if($$column =~ s/$quot/$quot$quot/go){ + # Replace " => "" + $must_be_quoted ||=1; + } + if($$column =~ /[\s\Q$sep\E]/o){ + # Put quotes around if the column contains , + $must_be_quoted ||=1; + } + + $Global::use{"bytes"} ||= eval "use bytes; 1;"; + if ($$column =~ /\0/) { + # Contains \0 => put quotes around + $must_be_quoted ||=1; + } + if($must_be_quoted){ + push @out, \$sep, \$quot, $column, \$quot; + } else { + push @out, \$sep, $column; + } + } + # Remove the first $sep: ,val,"val" => val,"val" + shift @out; + return @out; +} + +sub print_files($) { + # Print the name of the file containing stdout on stdout + # Uses: + # $opt::pipe + # $opt::group = Print when job is done + # $opt::linebuffer = Print ASAP + # Returns: N/A + my $self = shift; + my ($fdno,$in_fh,$out_fh) = @_; + + # If the job is dead: close printing fh. Needed for --compress + close $self->fh($fdno,"w"); + if($? and $opt::compress) { + ::error($opt::compress_program." failed."); + $self->set_exitstatus(255); + } + if($opt::compress) { + # Kill the decompressor which will not be needed + CORE::kill "TERM", $self->fh($fdno,"rpid"); + } + close $in_fh; + + if($opt::pipe and $self->virgin()) { + # Nothing was printed to this job: + # cleanup unused tmp files because --files was set + for my $fdno (1,2) { + ::rm($self->fh($fdno,"name")); + ::rm($self->fh($fdno,"unlink")); + } + } elsif($fdno == 1 and $self->fh($fdno,"name")) { + print $out_fh $self->tag(),$self->fh($fdno,"name"), $Global::files_sep; + if($Global::membuffer) { + push @{$self->{'output'}{$fdno}}, + $self->tag(), $self->fh($fdno,"name"); + } + $self->add_returnsize(-s $self->fh($fdno,"name")); + # Mark as printed - do not print again + $self->set_fh($fdno,"name",undef); + } +} + + +# Different print types +# (--ll | --ll --bar | --lb | --group | --parset | --sql-worker) +# (--files | --results (.json|.csv|.tsv) ) +# --color-failed +# --color +# --keep-order +# --tag +# --bar +{ + my ($up,$eol,$currow,$maxrow); + my ($minvisible,%print_later,%notvisible); + my (%binmodeset,%tab); + + sub latestline_init() { + # cursor_up cuu1 = up one line + $up = `sh -c "tput cuu1 /dev/null`; + chomp($up); + $eol = `sh -c "tput el /dev/null`; + chomp($eol); + if($eol eq "") { $eol = "\033[K"; } + $currow = 1; + $maxrow = 1; + $minvisible = 1; + for(0..8) { + $tab{$_} = " "x(8-($_%8)); + } + } + + sub mbtrunc($$) { + # Simple mbtrunc to avoid using Text::WideChar::Util + my $str = shift; + my $len = shift; + if(::mbswidth($str) == length($str)) { + $str = substr($str,0,$len); + } else { + # mb chars (ヌー平行) are wider than 1 char on screen + # We need at most $len chars - they may be wide + $str =~ s/(.{$len}).*/$1/; + my $rlen = int((::mbswidth($str) - $len)/2+0.5); + do { + $str =~ s/.{$rlen}$//; + $rlen = int((::mbswidth($str) - $len)/2+0.5); + } while($rlen >= 1); + } + return $str; + } + + sub print_latest_line($) { + my $self = shift; + my $out_fh = shift; + if(not defined $self->{$out_fh,'latestline'}) { return; } + my $row = $self->row(); + # Is row visible? + if(not ($minvisible <= $row + and + $row < $minvisible + ::terminal_rows() - 1)) { + return; + } + if(not $binmodeset{$out_fh}++) { + # Enable utf8 if possible + eval q{ binmode $out_fh, "encoding(utf8)"; }; + } + my ($color,$reset_color) = $self->color(); + my $termcol = ::terminal_columns(); + my $untabify_tag = ::decode_utf8($self->untabtag()); + my $untabify_str = + ::untabify(::decode_utf8($self->{$out_fh,'latestline'})); + # -1 to make space for $truncated_str + my $maxtaglen = $termcol - 1; + $untabify_tag = mbtrunc($untabify_tag,$maxtaglen); + my $taglen = ::mbswidth($untabify_tag); + my $maxstrlen = $termcol - $taglen - 1; + $untabify_str = mbtrunc($untabify_str,$maxstrlen); + my $strlen = ::mbswidth($untabify_str); + my $truncated_tag = ""; + my $truncated_str = ""; + if($termcol - $taglen < 2) { + $truncated_tag = ">"; + } else { + if($termcol - $taglen - $strlen <= 2) { + $truncated_str = ">"; + } + } + $maxrow = ($row > $maxrow) ? $row : $maxrow; + printf($out_fh + ("%s%s%s%s". # up down \r eol + "%s%s". # tag trunc_tag + "%s%s%s%s". # color line trunc reset_color + "%s" # down + ), + "$up"x($currow - $row), "\n"x($row - $currow), "\r", $eol, + $untabify_tag,$truncated_tag, + $color, $untabify_str, $truncated_str, $reset_color, + "\n"x($maxrow - $row + 1)); + $currow = $maxrow + 1; + } + + sub print_linebuffer($) { + my $self = shift; + my ($fdno,$in_fh,$out_fh) = @_; + if(defined $self->{'exitstatus'}) { + # If the job is dead: close printing fh. Needed for --compress + close $self->fh($fdno,"w"); + if($opt::compress) { + if($?) { + ::error($opt::compress_program." failed."); + $self->set_exitstatus(255); + } + # Blocked reading in final round + for my $fdno (1,2) { ::set_fh_blocking($self->fh($fdno,'r')); } + } + if($opt::latestline) { $print_later{$self->row()} = $self; } + } + if(not $self->virgin()) { + if($Global::files or ($opt::results and not $Global::csvsep)) { + # Print filename + if($fdno == 1 and not $self->fh($fdno,"printed")) { + print $out_fh $self->tag(),$self->fh($fdno,"name"),"\n"; + if($Global::membuffer) { + push(@{$self->{'output'}{$fdno}}, $self->tag(), + $self->fh($fdno,"name")); + } + $self->set_fh($fdno,"printed",1); + } + # No need for reading $in_fh, as it is from "cat >/dev/null" + } else { + # Read halflines and print full lines + my $outputlength = 0; + my $halfline_ref = $self->{'halfline'}{$fdno}; + my ($buf,$i,$rv); + # 1310720 gives 1.2 GB/s + # 131072 gives 0.9 GB/s + # The optimal block size differs + # It has been measured on: + # AMD 6376: 60800 (>70k is also reasonable) + # Intel i7-3632QM: 52-59k, 170-175k + # seq 64 | ppar --_test $1 --lb \ + # 'yes {} `seq 1000`|head -c 10000000' >/dev/null + while($rv = sysread($in_fh, $buf, 60800)) { + $outputlength += $rv; + # TODO --recend + # Treat both \n and \r as line end + # Only test for \r if there is no \n + # Test: + # perl -e '$a="x"x1000000; + # $b="$a\r$a\n$a\r$a\n"; + # map { print $b,$_ } 1..10' + $i = ((rindex($buf,"\n")+1) || (rindex($buf,"\r")+1)); + if($i) { + if($opt::latestline) { + # Keep the latest full line + my $l = join('', @$halfline_ref, + substr($buf,0,$i-1)); + # "ab\rb\n" = "bb", but we cannot process that correctly. + # Line may be: + # foo \r bar \n + # foo \r bar \r baz \r + # If so: Remove 'foo \r' + $l =~ s/.*\r//g; + my $j = ((rindex($l,"\n")+1) || + (rindex($l,"\r")+1)); + $self->{$out_fh,'latestline'} = substr($l,$j); + # Remove the processed part + # by keeping the unprocessed part + @$halfline_ref = (substr($buf,$i)); + } else { + # One or more complete lines were found + if($Global::color) { + my $print = join("",@$halfline_ref, + substr($buf,0,$i)); + chomp($print); + my ($color,$reset_color) = $self->color(); + my $colortag = $color.$self->tag(); + # \n => reset \n color tag + $print =~ s{([\n\r])(?=.|$)} + {$reset_color$1$colortag}gs; + print($out_fh $colortag, $print, + $reset_color, "\n"); + } elsif($opt::tag or defined $opt::tagstring) { + # Replace ^ with $tag within the full line + if($Global::cache_replacement_eval) { + # Replace with the same value for tag + my $tag = $self->tag(); + unshift @$halfline_ref, $tag; + # TODO --recend that can be partially in + # @$halfline_ref + substr($buf,0,$i-1) =~ + s/([\n\r])(?=.|$)/$1$tag/gs; + } else { + # Replace with freshly computed tag-value + unshift @$halfline_ref, $self->tag(); + substr($buf,0,$i-1) =~ + s/([\n\r])(?=.|$)/$1.$self->tag()/gse; + } + # The length changed, + # so find the new ending pos + $i = ::max((rindex($buf,"\n")+1), + (rindex($buf,"\r")+1)); + # Print the partial line (halfline) + # and the last half + print $out_fh @$halfline_ref, substr($buf,0,$i); + } else { + # Print the partial line (halfline) + # and the last half + print $out_fh @$halfline_ref, substr($buf,0,$i); + } + # Buffer in memory for SQL and CSV-output + if($Global::membuffer) { + push(@{$self->{'output'}{$fdno}}, + @$halfline_ref, substr($buf,0,$i)); + } + # Remove the printed part by keeping the unprinted + @$halfline_ref = (substr($buf,$i)); + } + } else { + # No newline, so append to the halfline + push @$halfline_ref, $buf; + } + } + $self->add_returnsize($outputlength); + if($opt::latestline) { $self->print_latest_line($out_fh); } + } + if(defined $self->{'exitstatus'}) { + if($Global::files or ($opt::results and not $Global::csvsep)) { + $self->add_returnsize(-s $self->fh($fdno,"name")); + } else { + if($opt::latestline) { + # Force re-computing color if --colorfailed + if($opt::colorfailed) { delete $self->{'color'}; } + if($self->{$out_fh,'latestline'} ne "") { + $self->print_latest_line($out_fh); + } + if(@{$self->{'halfline'}{$fdno}}) { + my $l = join('', @{$self->{'halfline'}{$fdno}}); + if($l ne "") { + $self->{$out_fh,'latestline'} = $l; + } + } else { + $self->{$out_fh,'latestline'} = undef; + } + # Print latest line from jobs that are already done + while($print_later{$minvisible}) { + $print_later{$minvisible}->print_latest_line($out_fh); + delete $print_later{$minvisible}; + $minvisible++; + } + # Print latest line from jobs that are on screen now + for(my $row = $minvisible; + $row < $minvisible -1 + ::terminal_rows(); + $row++) { + $print_later{$row} and + $print_later{$row}->print_latest_line($out_fh); + } + } else { + # If the job is dead: print the remaining partial line + # read remaining (already done for $opt::latestline) + my $halfline_ref = $self->{'halfline'}{$fdno}; + if(grep /./, @$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(); + } + # Print the partial line (halfline) + print $out_fh @{$self->{'halfline'}{$fdno}}; + # Buffer in memory for SQL and CSV-output + if($Global::membuffer) { + push(@{$self->{'output'}{$fdno}}, @$halfline_ref); + } + @$halfline_ref = (); + } + } + } + if($self->fh($fdno,"rpid") and + CORE::kill 0, $self->fh($fdno,"rpid")) { + # decompress still running + } else { + # decompress done: close fh + close $in_fh; + if($? and $opt::compress) { + ::error($opt::decompress_program." failed."); + $self->set_exitstatus(255); + } + } + } + } + } +} + +sub free_ressources() { + my $self = shift; + if(not $opt::ungroup) { + my $fh; + for my $fdno (sort { $a <=> $b } keys %Global::fh) { + $fh = $self->fh($fdno,"w"); + $fh and close $fh; + $fh = $self->fh($fdno,"r"); + $fh and close $fh; + } + } +} + +sub print_parset($) { + # Wrap output with shell script code to set as variables + my $self = shift; + my ($fdno,$in_fh,$out_fh) = @_; + my $outputlength = 0; + + ::debug("parset","print $Global::parset"); + if($Global::parset eq "assoc") { + # Start: (done in parse_parset()) + # eval "`echo 'declare -A myassoc; myassoc=( + # Each: (done here) + # [$'a\tb']=$'a\tb\tc ddd' + # End: (done in wait_and_exit()) + # )'`" + print '[',::Q($self->{'commandline'}-> + replace_placeholders(["\257<\257>"],0,0)),']='; + } elsif($Global::parset eq "array") { + # Start: (done in parse_parset()) + # eval "`echo 'myassoc=( + # Each: (done here) + # $'a\tb\tc ddd' + # End: (done in wait_and_exit()) + # )'`" + } elsif($Global::parset eq "var") { + # Start: (done in parse_parset()) + # + # Each: (done here) + # var=$'a\tb\tc ddd' + # End: (done in wait_and_exit()) + # + if(not @Global::parset_vars) { + ::error(255,"Too few named destination variables"); + } + print shift @Global::parset_vars,"="; + } + local $/ = "\n"; + my $tag = $self->tag(); + my @out; + while(<$in_fh>) { + $outputlength += length $_; + # Tag lines with \r, too + $_ =~ s/(?<=[\r])(?=.|$)/$tag/gs; + push @out, $tag,$_; + } + # Remove last newline + # This often makes it easier to use the output in shell + @out and ${out[$#out]} =~ s/\n$//s; + print ::Q(join("",@out)),"\n"; + return $outputlength; +} + +sub print_normal($) { + my $self = shift; + my ($fdno,$in_fh,$out_fh) = @_; + my $buf; + close $self->fh($fdno,"w"); + if($? and $opt::compress) { + ::error($opt::compress_program." failed."); + $self->set_exitstatus(255); + } + if(not $self->virgin()) { + seek $in_fh, 0, 0; + # $in_fh is now ready for reading at position 0 + my $outputlength = 0; + my @output; + + if($Global::parset and $fdno == 1) { + $outputlength += $self->print_parset($fdno,$in_fh,$out_fh); + } elsif(defined $opt::tag or defined $opt::tagstring + or $Global::color or $opt::colorfailed) { + if($Global::color or $opt::colorfailed) { + my ($color,$reset_color) = $self->color(); + my $colortag = $color.$self->tag(); + # Read line by line + local $/ = "\n"; + while(<$in_fh>) { + $outputlength += length $_; + # Tag lines with \r, too + chomp; + s{([\n\r])(?=.|$)}{$reset_color$1$colortag}gs; + print $out_fh $colortag,$_,$reset_color,"\n"; + } + } else { + my $tag = $self->tag(); + my $pretag = 1; + my $s; + while(sysread($in_fh,$buf,32767)) { + $outputlength += length $buf; + $buf =~ s/(?<=[\r\n])(?=.)/$tag/gs; + print $out_fh ($pretag ? $tag : ""),$buf; + if($Global::membuffer) { + push @{$self->{'output'}{$fdno}}, + ($pretag ? $tag : ""),$buf; + } + # Should next print start with a tag? + $s = substr($buf, -1); + # This is faster than ($s eq "\n") || ($s eq "\r") + $pretag = ($s eq "\n") ? 1 : ($s eq "\r"); + } + } + } else { + # Most efficient way of copying data from $in_fh to $out_fh + # Intel i7-3632QM: 25k- + while(sysread($in_fh,$buf,32767)) { + print $out_fh $buf; + $outputlength += length $buf; + if($Global::membuffer) { + push @{$self->{'output'}{$fdno}}, $buf; + } + } + } + if($fdno == 1) { + $self->add_returnsize($outputlength); + } + close $in_fh; + if($? and $opt::compress) { + ::error($opt::decompress_program." failed."); + $self->set_exitstatus(255); + } + } +} + +sub print_results($) { + my $self = shift; + my ($fdno,$in_fh,$out_fh) = @_; + my $buf; + close $self->fh($fdno,"w"); + if($? and $opt::compress) { + ::error($opt::compress_program." failed."); + $self->set_exitstatus(255); + } + if(not $self->virgin()) { + seek $in_fh, 0, 0; + # $in_fh is now ready for reading at position 0 + my $outputlength = 0; + my @output; + + if($Global::membuffer) { + # Read data into membuffer + if($opt::tag or $opt::tagstring) { + # Read line by line + local $/ = "\n"; + my $tag = $self->tag(); + while(<$in_fh>) { + $outputlength += length $_; + # Tag lines with \r, too + $_ =~ s/(?<=[\r])(?=.|$)/$tag/gs; + push @{$self->{'output'}{$fdno}}, $tag, $_; + } + } else { + # Most efficient way of copying data from $in_fh to $out_fh + while(sysread($in_fh,$buf,60000)) { + $outputlength += length $buf; + push @{$self->{'output'}{$fdno}}, $buf; + } + } + } else { + # Not membuffer: No need to read the file + if($opt::compress) { + $outputlength = -1; + } else { + # Determine $outputlength = file length + seek($in_fh, 0, 2) || ::die_bug("cannot seek result"); + $outputlength = tell($in_fh); + } + } + if($fdno == 1) { $self->add_returnsize($outputlength); } + close $in_fh; + if($? and $opt::compress) { + ::error($opt::decompress_program." failed."); + $self->set_exitstatus(255); + } + } +} + +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 = $self->wrapped(); + } + # Newlines make it hard to parse the joblog + $cmd =~ s/\n/\0/g; + print $Global::joblog + join("\t", $self->seq(), $self->sshlogin()->string(), + $self->starttime(), sprintf("%10.3f",$self->runtime()), + $self->transfersize(), $self->returnsize(), + $self->exitstatus(), $self->exitsignal(), $cmd + ). "\n"; + flush $Global::joblog; + $self->set_job_in_joblog(); +} + +sub tag($) { + my $self = shift; + if(not defined $self->{'tag'} or not $Global::cache_replacement_eval) { + if(defined $opt::tag or defined $opt::tagstring) { + $self->{'tag'} = + ($self->{'commandline'}-> + replace_placeholders([$opt::tagstring],0,0)). + "\t"; + } else { + # No tag + $self->{'tag'} = ""; + } + } + return $self->{'tag'}; +} + +sub untabtag($) { + # tag with \t replaced with spaces + my $self = shift; + my $tag = $self->tag(); + if(not defined $self->{'untab'}{$tag}) { + $self->{'untab'}{$tag} = ::untabify($tag); + } + return $self->{'untab'}{$tag}; +} + +{ + my (@color,$eol,$reset_color,$init); + + sub init_color() { + if(not $init) { + $init = 1; + # color combinations that are readable: black/white text + # on colored background, but not white on yellow + my @color_combinations = + # Force each color code to have the same length in chars + # This will make \t work as expected + ((map { [sprintf("%03d",$_),"000"] } + 6..7,9..11,13..15,40..51,75..87,113..123,147..159, + 171..182,185..231,249..254), + (map { [sprintf("%03d",$_),231] } + 1..9,12..13,16..45,52..81,88..114,124..149, + 160..178,180,182..184,196..214,232..250)); + # reorder list so adjacent colors are dissimilar + # %23 and %7 were found experimentally + my @order = reverse sort { + (($a%23) <=> ($b%23)) + or + (($b%7) <=> ($a%7)); + } 0..$#color_combinations; + @order = @order[54 .. $#color_combinations, 0 .. 53]; + @color = map { + # TODO Can this be done with `tput` codes? + "\033[48;5;".$_->[0].";38;5;".$_->[1]."m" + } @color_combinations[ @order ]; + + # clr_eol el = clear to end of line + $eol = `sh -c "tput el /dev/null`; + chomp($eol); + if($eol eq "") { $eol = "\033[K"; } + # exit_attribute_mode sgr0 = turn off all attributes + $reset_color = `sh -c "tput sgr0 /dev/null`; + chomp($reset_color); + if($reset_color eq "") { $reset_color = "\033[m"; } + } + } + + sub color($) { + my $self = shift; + if(not defined $self->{'color'}) { + if($Global::color) { + # Choose a value based on the seq + $self->{'color'} = $color[$self->seq() % ($#color+1)].$eol; + $self->{'reset_color'} = $reset_color; + } else { + $self->{'color'} = ""; + $self->{'reset_color'} = ""; + } + if($opt::colorfailed) { + if($self->exitstatus()) { + # White on Red + # Can this be done more generally? + $self->{'color'} = + "\033[48;5;"."196".";38;5;"."231"."m".$eol; + $self->{'reset_color'} = $reset_color; + } + } + } + return ($self->{'color'},$self->{'reset_color'}); + } +} + +sub hostgroups($) { + my $self = shift; + if(not defined $self->{'hostgroups'}) { + $self->{'hostgroups'} = + $self->{'commandline'}->{'arg_list'}[0][0]->{'hostgroups'}; + } + return @{$self->{'hostgroups'}}; +} + +sub exitstatus($) { + my $self = shift; + return $self->{'exitstatus'}; +} + +sub set_exitstatus($$) { + my $self = shift; + my $exitstatus = shift; + if($exitstatus) { + # Overwrite status if non-zero + $self->{'exitstatus'} = $exitstatus; + } else { + # Set status but do not overwrite + # Status may have been set by --timeout + $self->{'exitstatus'} ||= $exitstatus; + } + $opt::sqlworker and + $Global::sql->update("SET Exitval = ? WHERE Seq = ".$self->seq(), + $exitstatus); +} + +sub reset_exitstatus($) { + my $self = shift; + undef $self->{'exitstatus'}; +} + +sub exitsignal($) { + my $self = shift; + return $self->{'exitsignal'}; +} + +sub set_exitsignal($$) { + my $self = shift; + my $exitsignal = shift; + $self->{'exitsignal'} = $exitsignal; + $opt::sqlworker and + $Global::sql->update("SET _Signal = ? WHERE Seq = ".$self->seq(), + $exitsignal); +} + +{ + my $total_jobs; + + sub should_we_halt { + # Should we halt? Immediately? Gracefully? + # Returns: N/A + my $job = shift; + my $limit; + if($Global::semaphore) { + # Emulate Bash's +128 if there is a signal + $Global::halt_exitstatus = + ($job->exitstatus() + or + $job->exitsignal() ? $job->exitsignal() + 128 : 0); + } + if($job->exitstatus() or $job->exitsignal()) { + # Job failed + $Global::exitstatus++; + $Global::total_failed++; + if($Global::halt_fail) { + ::status("$Global::progname: This job failed:", + $job->replaced()); + $limit = $Global::total_failed; + } + } elsif($Global::halt_success) { + ::status("$Global::progname: This job succeeded:", + $job->replaced()); + $limit = $Global::total_completed - $Global::total_failed; + } + if($Global::halt_done) { + ::status("$Global::progname: This job finished:", + $job->replaced()); + $limit = $Global::total_completed; + } + if(not defined $limit) { + return "" + } + # --halt # => 1..100 (number of jobs failed, 101 means > 100) + # --halt % => 1..100 (pct of jobs failed) + if($Global::halt_pct and not $Global::halt_count) { + $total_jobs ||= $Global::JobQueue->total_jobs(); + # From the pct compute the number of jobs that must fail/succeed + $Global::halt_count = $total_jobs * $Global::halt_pct; + } + if($limit >= $Global::halt_count) { + # At least N jobs have failed/succeded/completed + # or at least N% have failed/succeded/completed + # So we should prepare for exit + if($Global::halt_fail or $Global::halt_done) { + # Set exit status + if(not defined $Global::halt_exitstatus) { + if($Global::halt_pct) { + # --halt now,fail=X% or soon,fail=X% + # --halt now,done=X% or soon,done=X% + $Global::halt_exitstatus = + ::ceil($Global::total_failed / $total_jobs * 100); + } elsif($Global::halt_count) { + # --halt now,fail=X or soon,fail=X + # --halt now,done=X or soon,done=X + $Global::halt_exitstatus = + ::min($Global::total_failed,101); + } + if($Global::halt_count and $Global::halt_count == 1) { + # --halt now,fail=1 or soon,fail=1 + # --halt now,done=1 or soon,done=1 + # Emulate Bash's +128 if there is a signal + $Global::halt_exitstatus = + ($job->exitstatus() + or + $job->exitsignal() ? $job->exitsignal() + 128 : 0); + } + } + ::debug("halt","Pct: ",$Global::halt_pct, + " count: ",$Global::halt_count, + " status: ",$Global::halt_exitstatus,"\n"); + } elsif($Global::halt_success) { + $Global::halt_exitstatus = 0; + } + if($Global::halt_when eq "soon") { + $Global::start_no_new_jobs ||= 1; + if(scalar(keys %Global::running) > 0) { + # Only warn if there are more jobs running + ::status + ("$Global::progname: Starting no more jobs. ". + "Waiting for ". (keys %Global::running). + " jobs to finish."); + } + } + return($Global::halt_when); + } + return ""; + } +} + + +package CommandLine; + +sub new($) { + my $class = shift; + my $seq = shift; + my $commandref = shift; + $commandref || die; + my $arg_queue = shift; + my $context_replace = shift; + my $max_number_of_args = shift; # for -N and normal (-n1) + my $transfer_files = shift; + my $return_files = shift; + my $template_names = shift; + my $template_contents = shift; + my $replacecount_ref = shift; + my $len_ref = shift; + my %replacecount = %$replacecount_ref; + my %len = %$len_ref; + for (keys %$replacecount_ref) { + # Total length of this replacement string {} replaced with all args + $len{$_} = 0; + } + return bless { + 'command' => $commandref, + 'seq' => $seq, + 'len' => \%len, + 'arg_list' => [], + 'arg_list_flat' => [], + 'arg_list_flat_orig' => [undef], + 'arg_queue' => $arg_queue, + 'max_number_of_args' => $max_number_of_args, + 'replacecount' => \%replacecount, + 'context_replace' => $context_replace, + 'transfer_files' => $transfer_files, + 'return_files' => $return_files, + 'template_names' => $template_names, + 'template_contents' => $template_contents, + 'replaced' => undef, + }, ref($class) || $class; +} + +sub flush_cache() { + my $self = shift; + for my $arglist (@{$self->{'arg_list'}}) { + for my $arg (@$arglist) { + $arg->flush_cache(); + } + } + $self->{'arg_queue'}->flush_cache(); + $self->{'replaced'} = undef; +} + +sub seq($) { + my $self = shift; + return $self->{'seq'}; +} + +sub set_seq($$) { + my $self = shift; + $self->{'seq'} = shift; +} + +sub slot($) { + # Find the number of a free job slot and return it + # Uses: + # @Global::slots - list with free jobslots + # Returns: + # $jobslot = number of jobslot + my $self = shift; + if(not $self->{'slot'}) { + if(not @Global::slots) { + # $max_slot_number will typically be $Global::max_jobs_running + push @Global::slots, ++$Global::max_slot_number; + } + $self->{'slot'} = shift @Global::slots; + } + return $self->{'slot'}; +} + +{ + my $already_spread; + my $darwin_max_len; + + sub populate($) { + # Add arguments from arg_queue until the number of arguments or + # max line length is reached + # Uses: + # $Global::usable_command_line_length + # $opt::cat + # $opt::fifo + # $Global::JobQueue + # $opt::m + # $opt::X + # $Global::max_jobs_running + # Returns: N/A + my $self = shift; + my $next_arg; + my $max_len = $Global::usable_command_line_length || die; + if($^O eq "darwin") { + # Darwin's limit is affected by: + # * number of environment names (variables+functions) + # * size of environment + # * the length of arguments: + # a one-char argument lowers the limit by 5 + # To be safe assume all arguments are one-char + # The max_len is cached between runs, but if the size of + # the environment is different we need to recompute the + # usable max length for this run of GNU Parallel + # See https://unix.stackexchange.com/a/604943/2972 + if(not $darwin_max_len) { + my $envc = (keys %ENV); + my $envn = length join"",(keys %ENV); + my $envv = length join"",(values %ENV); + $darwin_max_len = -146+($max_len - $envn - $envv) - $envc*10; + ::debug("init", + "length: $darwin_max_len ". + "3+($max_len - $envn - $envv)/5 - $envc*2"); + } + $max_len = $darwin_max_len; + } + if($opt::cat or $opt::fifo) { + # Get the empty arg added by --pipepart (if any) + $Global::JobQueue->{'commandlinequeue'}->{'arg_queue'}->get(); + # $PARALLEL_TMP will point to a tempfile that will be used as {} + $Global::JobQueue->{'commandlinequeue'}->{'arg_queue'}-> + unget([Arg->new('"$PARALLEL_TMP"')]); + } + while (not $self->{'arg_queue'}->empty()) { + $next_arg = $self->{'arg_queue'}->get(); + if(not defined $next_arg) { + next; + } + $self->push($next_arg); + if($self->len() >= $max_len) { + # Command length is now > max_length + # If there are arguments: remove the last + # If there are no arguments: Error + # TODO stuff about -x opt_x + if($self->number_of_args() > 1) { + # There is something to work on + $self->{'arg_queue'}->unget($self->pop()); + last; + } else { + my $args = join(" ", map { $_->orig() } @$next_arg); + ::error(255,"Command line too long (". + $self->len(). " >= ". + $max_len. + ") at input ". + $self->{'arg_queue'}->arg_number(). + ": ". + ((length $args > 50) ? + (substr($args,0,50))."..." : + $args)); + } + } + + if(defined $self->{'max_number_of_args'}) { + if($self->number_of_args() >= + $self->{'max_number_of_args'}) { + last; + } + } + } + if(($opt::m or $opt::X) and not $already_spread + and $self->{'arg_queue'}->empty() and $Global::max_jobs_running) { + # -m or -X and EOF => Spread the arguments over all jobslots + # (unless they are already spread) + $already_spread ||= 1; + if($self->number_of_args() > 1) { + $self->{'max_number_of_args'} = + ::ceil($self->number_of_args()/$Global::max_jobs_running); + $Global::JobQueue->{'commandlinequeue'}->{'max_number_of_args'} = + $self->{'max_number_of_args'}; + $self->{'arg_queue'}->unget($self->pop_all()); + while($self->number_of_args() < $self->{'max_number_of_args'}) { + $self->push($self->{'arg_queue'}->get()); + } + } + $Global::JobQueue->flush_total_jobs(); + } + + if($opt::sqlmaster) { + # Insert the V1..Vn for this $seq in SQL table + # instead of generating one + $Global::sql->insert_records($self->seq(), $self->{'command'}, + $self->{'arg_list_flat_orig'}); + } + } +} + +sub push($) { + # Add one or more records as arguments + # Returns: N/A + my $self = shift; + my $record = shift; + push @{$self->{'arg_list_flat_orig'}}, map { $_->orig() } @$record; + push @{$self->{'arg_list_flat'}}, @$record; + push @{$self->{'arg_list'}}, $record; + # Make @arg available for {= =} + *Arg::arg = $self->{'arg_list_flat_orig'}; + + my $quote_arg = ($Global::quote_replace and not $Global::quoting); + my $col; + for my $perlexpr (keys %{$self->{'replacecount'}}) { + if($perlexpr =~ /^(-?\d+)(?:\D.*|)$/) { + # Positional replacement string + # Deal with negative positional replacement string + $col = ($1 < 0) ? $1 : $1-1; + if(defined($record->[$col])) { + $self->{'len'}{$perlexpr} += + length $record->[$col]->replace($perlexpr,$quote_arg,$self); + } + } else { + for my $arg (@$record) { + if(defined $arg) { + $self->{'len'}{$perlexpr} += + length $arg->replace($perlexpr,$quote_arg,$self); + } + } + } + } +} + +sub pop($) { + # Remove last argument + # Returns: + # the last record + my $self = shift; + my $record = pop @{$self->{'arg_list'}}; + # pop off arguments from @$record + splice @{$self->{'arg_list_flat_orig'}}, -($#$record+1), $#$record+1; + splice @{$self->{'arg_list_flat'}}, -($#$record+1), $#$record+1; + my $quote_arg = ($Global::quote_replace and not $Global::quoting); + for my $perlexpr (keys %{$self->{'replacecount'}}) { + if($perlexpr =~ /^(\d+) /) { + # Positional + defined($record->[$1-1]) or next; + $self->{'len'}{$perlexpr} -= + length $record->[$1-1]->replace($perlexpr,$quote_arg,$self); + } else { + for my $arg (@$record) { + if(defined $arg) { + $self->{'len'}{$perlexpr} -= + length $arg->replace($perlexpr,$quote_arg,$self); + } + } + } + } + return $record; +} + +sub pop_all($) { + # Remove all arguments and zeros the length of replacement perlexpr + # Returns: + # all records + my $self = shift; + my @popped = @{$self->{'arg_list'}}; + for my $perlexpr (keys %{$self->{'replacecount'}}) { + $self->{'len'}{$perlexpr} = 0; + } + $self->{'arg_list'} = []; + $self->{'arg_list_flat_orig'} = [undef]; + $self->{'arg_list_flat'} = []; + return @popped; +} + +sub number_of_args($) { + # The number of records + # Returns: + # number of records + my $self = shift; + # This is really the number of records + return $#{$self->{'arg_list'}}+1; +} + +sub number_of_recargs($) { + # The number of args in records + # Returns: + # number of args records + my $self = shift; + my $sum = 0; + my $nrec = scalar @{$self->{'arg_list'}}; + if($nrec) { + $sum = $nrec * (scalar @{$self->{'arg_list'}[0]}); + } + return $sum; +} + +sub args_as_string($) { + # Returns: + # all unmodified arguments joined with ' ' (similar to {}) + my $self = shift; + return (join " ", map { $_->orig() } + map { @$_ } @{$self->{'arg_list'}}); +} + +sub results_out($) { + sub max_file_name_length { + # Figure out the max length of a subdir + # TODO and the max total length + # Ext4 = 255,130816 + # Uses: + # $Global::max_file_length is set + # Returns: + # $Global::max_file_length + my $testdir = shift; + + my $upper = 100_000_000; + # Dir length of 8 chars is supported everywhere + my $len = 8; + my $dir = "d"x$len; + do { + rmdir($testdir."/".$dir); + $len *= 16; + $dir = "d"x$len; + } while ($len < $upper and mkdir $testdir."/".$dir); + # Then search for the actual max length between $len/16 and $len + my $min = $len/16; + my $max = $len; + while($max-$min > 5) { + # If we are within 5 chars of the exact value: + # it is not worth the extra time to find the exact value + my $test = int(($min+$max)/2); + $dir = "d"x$test; + if(mkdir $testdir."/".$dir) { + rmdir($testdir."/".$dir); + $min = $test; + } else { + $max = $test; + } + } + $Global::max_file_length = $min; + return $min; + } + + my $self = shift; + my $out = $self->replace_placeholders([$opt::results],0,0); + if($out eq $opt::results) { + # $opt::results simple string: Append args_as_dirname + my $args_as_dirname = $self->args_as_dirname(0); + # Output in: prefix/name1/val1/name2/val2/stdout + $out = $opt::results."/".$args_as_dirname; + if(-d $out or eval{ File::Path::mkpath($out); }) { + # OK + } else { + # mkpath failed: Argument too long or not quoted + # Set $Global::max_file_length, which will keep the individual + # dir names shorter than the max length + max_file_name_length($opt::results); + # Quote dirnames with + + $args_as_dirname = $self->args_as_dirname(1); + # prefix/name1/val1/name2/val2/ + $out = $opt::results."/".$args_as_dirname; + File::Path::mkpath($out); + } + $out .="/"; + } else { + if($out =~ m:/$:s) { + # / = dir + if(-d $out or eval{ File::Path::mkpath($out); }) { + # OK + } else { + ::error(255,"Cannot make dir '$out'."); + } + } else { + $out =~ m:(.*)/:s; + File::Path::mkpath($1); + } + } + return $out; +} + +{ + my %map; + my %stringmap; + my $sep; + + # test: '' . .. a. a.. + ++ 0..255 on fat12 ext4 + sub args_as_dirname($) { + # Returns: + # all arguments joined with '/' (similar to {}) + # Chars that are not safe on all file systems are quoted. + sub init() { + # ext4: / \t \n \0 \\ \r + # fat: 0..31 " * / : < > ? \ | Maybe also: # [ ] ; = , + # exfat: 128..255 + # Other FS: , [ ] { } ( ) ! ; " ' * ? < > | + # + # Quote these as: + # + = ++ + # \0 = +0 + # \t = +t + # \\ = +b (backslash) + # \n = +n + # \r = +r + # / = +z (zlash) + # ? = +y (whY?) + # " = +d (double quote) + # ' = +q (quote) + # * = +a (asterisk) + # < = +l (less than) + # > = +g (greater than) + # : = +k (kolon) + # ! = +x (eXclamation) + # | = +p (pipe) + # # = +h (hash) + # ; = +s (semicolon) + # = = +e (equal) + # , = +c (comma) + # 1..32 128..255 = +XX (hex value) + # [ ] = +e +f + # ( ) = +i +j + # { } = +v +w + # Quote '' as +m (eMpty) + # Quote . as +_ + # Quote .. as +__ + # (Unused: ou) + %map = qw( + + ++ + \0 +0 + \t +t + \\ +b + \n +n + \r +r + / +z + ? +y + " +d + ' +q + * +a + < +l + > +g + : +k + ! +x + | +p + # +h + ; +s + = +e + , +c + [ +e + ( +i + { +v + ] +f + ) +j + } +w + ); + # 1..32 128..255 = +XX (hex value) + map { $map{sprintf "%c",$_} = sprintf "+%02x",$_ } 1..32, 128..255; + # Default value = itself + map { $map{sprintf "%c",$_} ||= sprintf "%c",$_ } 0..255; + # Quote '' as +m (eMpty) + $stringmap{""} = "+m"; + # Quote . as +_ + $stringmap{"."} = "+_"; + # Quote .. as +__ + $stringmap{".."} = "+__"; + # Set dir separator + eval 'use File::Spec; $sep = File::Spec->catfile("", "");'; + $sep ||= '/'; + } + # If $Global::max_file_length: Keep subdirs < $Global::max_file_length + my $self = shift; + my $quote = shift; + my @res = (); + if(not $sep) { init(); } + + for my $rec_ref (@{$self->{'arg_list'}}) { + # If headers are used, sort by them. + # Otherwise keep the order from the command line. + my @header_indexes_sorted = header_indexes_sorted($#$rec_ref+1); + for my $n (@header_indexes_sorted) { + CORE::push(@res, + $Global::input_source_header{$n}, + $quote ? + ( + grep { $_ ne "\0noarg" } map { + my $s = $_; + # Quote + as ++ + $s =~ s/(.)/$map{$1}/gs; + if($Global::max_file_length) { + # Keep each subdir shorter than the longest + # allowed file name + $s = substr($s,0,$Global::max_file_length); + } + $s; } + $rec_ref->[$n-1]->orig() + ) : + ( + grep { $_ ne "\0noarg" } map { + my $s = $_; + # Quote / as +z and + as ++ + $s =~ s/($sep|\+)/$map{$1}/gos; + if($Global::max_file_length) { + # Keep each subdir shorter than the longest + # allowed file name + $s = substr($s,0,$Global::max_file_length); + } + $s; } + $rec_ref->[$n-1]->orig() + ) + ); + } + } + return join $sep, map { $stringmap{$_} || $_ } @res; + } +} + +sub header_indexes_sorted($) { + # Sort headers first by number then by name. + # E.g.: 1a 1b 11a 11b + # Returns: + # Indexes of %Global::input_source_header sorted + my $max_col = shift; + + no warnings 'numeric'; + for my $col (1 .. $max_col) { + # Make sure the header is defined. If it is not: use column number + if(not defined $Global::input_source_header{$col}) { + $Global::input_source_header{$col} = $col; + } + } + my @header_indexes_sorted = sort { + # Sort headers numerically then asciibetically + $Global::input_source_header{$a} <=> $Global::input_source_header{$b} + or + $Global::input_source_header{$a} cmp $Global::input_source_header{$b} + } 1 .. $max_col; + return @header_indexes_sorted; +} + +sub len($) { + # Uses: + # @opt::shellquote + # The length of the command line with args substituted + my $self = shift; + my $len = 0; + # Add length of the original command with no args + # Length of command w/ all replacement args removed + $len += $self->{'len'}{'noncontext'} + @{$self->{'command'}} -1; + ::debug("length", "noncontext + command: $len\n"); + # MacOS has an overhead of 8 bytes per argument + my $darwin = ($^O eq "darwin") ? 8 : 0; + my $recargs = $self->number_of_recargs(); + if($self->{'context_replace'}) { + # Context is duplicated for each arg + $len += $recargs * $self->{'len'}{'context'}; + for my $replstring (keys %{$self->{'replacecount'}}) { + # If the replacements string is more than once: mulitply its length + $len += $self->{'len'}{$replstring} * + $self->{'replacecount'}{$replstring}; + ::debug("length", $replstring, " ", $self->{'len'}{$replstring}, "*", + $self->{'replacecount'}{$replstring}, "\n"); + } + # echo 11 22 33 44 55 66 77 88 99 1010 + # echo 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 + # 5 + ctxgrp*arg + ::debug("length", "Ctxgrp: ", $self->{'len'}{'contextgroups'}, + " Groups: ", $self->{'len'}{'noncontextgroups'}, "\n"); + # Add space between context groups + $len += ($recargs-1) * ($self->{'len'}{'contextgroups'}); + if($darwin) { + $len += $recargs * $self->{'len'}{'contextgroups'} * $darwin; + } + } else { + # Each replacement string may occur several times + # Add the length for each time + $len += 1*$self->{'len'}{'context'}; + ::debug("length", "context+noncontext + command: $len\n"); + for my $replstring (keys %{$self->{'replacecount'}}) { + # (space between recargs + length of replacement) + # * number this replacement is used + $len += ($recargs -1 + $self->{'len'}{$replstring}) * + $self->{'replacecount'}{$replstring}; + if($darwin) { + $len += ($recargs * $self->{'replacecount'}{$replstring} + * $darwin); + } + } + } + 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: ' => "'" + " => '"' + # TODO can we count the number of expanding chars? + # and count them in arguments, too? + $len *= 3; + } + if(@opt::shellquote) { + # Pessimistic length if --shellquote is set + # Worse than worst case: ' => "'" + for(@opt::shellquote) { + $len *= 3; + } + $len *= 5; + } + 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($) { + # Uses: + # $Global::quote_replace + # $Global::quoting + # Returns: + # $replaced = command with place holders replaced and prepended + my $self = shift; + if(not defined $self->{'replaced'}) { + # Don't quote arguments if the input is the full command line + my $quote_arg = ($Global::quote_replace and not $Global::quoting); + # or if ($opt::cat or $opt::pipe) as they use $PARALLEL_TMP + $quote_arg = ($opt::cat || $opt::fifo) ? 0 : $quote_arg; + $self->{'replaced'} = $self-> + replace_placeholders($self->{'command'},$Global::quoting, + $quote_arg); + my $len = length $self->{'replaced'}; + if ($len != $self->len()) { + ::debug("length", $len, " != ", $self->len(), + " ", $self->{'replaced'}, "\n"); + } else { + ::debug("length", $len, " == ", $self->len(), + " ", $self->{'replaced'}, "\n"); + } + } + return $self->{'replaced'}; +} + +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; + + # 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)/ + } + } + # 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; + + 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; + # @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 { + # Normal replace + $normal_replace ||= 1; + ($arg ? $arg->replace($2,$quote_arg,$self) : ""); + } + }sgxe) { + # Token is \257<..\257> + } else { + if($Global::escape_string_present) { + # Command line contains \257: + # Unescape it \257\256 => \257 + $a =~ s/\257\256/\257/g; + } + } + $a + } @ctxgroup; + $normal_replace or last; + $space = "\0spc"; + } + } else { + # Context group has no a replacement string: Copy it once + CORE::push @replaced, map { + $Global::escape_string_present and s/\257\256/\257/g; $_; + } @ctxgroup; + } + # New context group + @ctxgroup=(); + } + if($t eq "\0spc" or $t eq " ") { + CORE::push @replaced,$t; + } else { + CORE::push @ctxgroup,$t; + } + } + } 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, map { + $Global::escape_string_present and s/\257\256/\257/g; $_; + } $t; + } + } + } + *Arg::arg = []; + ::debug("replace","Replaced: ".join":",@replaced,"\n"); + + # 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($) { + # Skip this job + my $self = shift; + $self->{'skip'} = 1; +} + + +package CommandLineQueue; + +sub new($) { + my $class = shift; + my $commandref = shift; + my $read_from = shift; + my $context_replace = shift || 0; + my $max_number_of_args = shift; + my $transfer_files = shift; + my $return_files = shift; + my $template_names = shift; + my $template_contents = shift; + my @unget = (); + my $posrpl; + my ($replacecount_ref, $len_ref); + my @command = @$commandref; + my $seq = 1; + # Replace replacement strings with {= perl expr =} + # '{=' 'perlexpr' '=}' => '{= perlexpr =}' + @command = merge_rpl_parts(@command); + + # Protect matching inside {= perl expr =} + # by replacing {= and =} with \257< and \257> + # in options that can contain replacement strings: + # @command, --transferfile, --return, + # --tagstring, --workdir, --results + for(@command, @$transfer_files, @$return_files, + @$template_names, @$template_contents, + $opt::tagstring, $opt::workdir, $opt::results, $opt::retries, + @opt::filter) { + # Skip if undefined + defined($_) or next; + # Escape \257 => \257\256 + $Global::escape_string_present += s/\257/\257\256/g; + # Needs to match rightmost left parens (Perl defaults to leftmost) + # to deal with: {={==} and {={==}=} + # Replace {= -> \257< and =} -> \257> + # + # Complex way to do: + # s/{=(.*)=}/\257<$1\257>/g + # which would not work + s[\Q$Global::parensleft\E # Match {= + # Match . unless the next string is {= or =} + # needed to force matching the shortest {= =} + ((?:(?! \Q$Global::parensleft\E|\Q$Global::parensright\E ).)*?) + \Q$Global::parensright\E ] # Match =} + {\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: + # --rpl '% s/a/b/' --rpl '%% s/b/a/' + # + # Replace the shorthand string (--rpl) + # with the {= perl expr =} + # + # Avoid searching for shorthand strings inside existing {= perl expr =} + # + # Replace $$1 in {= perl expr =} with groupings in shorthand string + # + # --rpl '{/(\.\S+)/(\.\S+)} s/$$1/$$2/g;' + # echo {/.tar/.gz} ::: UU.tar.gz + my ($prefix,$grp_regexp,$postfix) = + $rpl =~ /^( [^(]* ) # Prefix - e.g. {%% + ( \(.*\) )? # Group capture regexp - e.g (.*) + ( [^)]* )$ # Postfix - e.g } + /xs; + $grp_regexp ||= ''; + my $rplval = $Global::rpl{$rpl}; + while(s{( (?: ^|\257> ) (?: [^\257]*|[\257][^<>] )*? ) + # Don't replace after \257 unless \257> + \Q$prefix\E $grp_regexp \Q$postfix\E} + { + # The start remains the same + my $unchanged = $1; + # Dummy entry to start at 1. + my @grp = (1); + # $2 = first ()-group in $grp_regexp + # Put $2 in $grp[1], Put $3 in $grp[2] + # so first ()-group in $grp_regexp is $grp[1]; + for(my $i = 2; defined $grp[$#grp]; $i++) { + push @grp, eval '$'.$i; + } + my $rv = $rplval; + # replace $$1 with $_pAr_gRp1, $$2 with $_pAr_gRp2 + # in the code to be executed + $rv =~ s/\$\$ (\d+)/\$_pAr_gRp$1/gx; + # prepend with $_pAr_gRp1 = perlquote($1), + my $set_args = ""; + for(my $i = 1;defined $grp[$i]; $i++) { + $set_args .= "\$_pAr_gRp$i = \"" . + ::perl_quote_scalar($grp[$i]) . "\";"; + } + $unchanged . "\257<" . $set_args . $rv . "\257>" + }gxes) { + } + # Do the same for the positional replacement strings + $posrpl = $rpl; + if($posrpl =~ s/^\{//) { + # Only do this if the shorthand start with { + $prefix=~s/^\{//; + # Don't replace after \257 unless \257> + while(s{( (?: ^|\257> ) (?: [^\257]*|[\257][^<>] )*? ) + \{(-?\d+) \s* \Q$prefix\E $grp_regexp \Q$postfix\E} + { + # The start remains the same + my $unchanged = $1; + my $position = $2; + # Dummy entry to start at 1. + my @grp = (1); + # $3 = first ()-group in $grp_regexp + # Put $3 in $grp[1], Put $4 in $grp[2] + # so first ()-group in $grp_regexp is $grp[1]; + for(my $i = 3; defined $grp[$#grp]; $i++) { + push @grp, eval '$'.$i; + } + my $rv = $rplval; + # replace $$1 with $_pAr_gRp1, $$2 with $_pAr_gRp2 + # in the code to be executed + $rv =~ s/\$\$ (\d+)/\$_pAr_gRp$1/gx; + # prepend with $_pAr_gRp1 = perlquote($1), + my $set_args = ""; + for(my $i = 1;defined $grp[$i]; $i++) { + $set_args .= "\$_pAr_gRp$i = \"" . + ::perl_quote_scalar($grp[$i]) . "\";"; + } + $unchanged . "\257<" . $position . $set_args . $rv . "\257>" + }gxes) { + } + } + } + } + # Add {} if no replacement strings in @command + ($replacecount_ref, $len_ref, @command) = + replacement_counts_and_lengths($transfer_files, $return_files, + $template_names, $template_contents, + @command); + if("@command" =~ /^[^ \t\n=]*\257append()) { + $seq = $Global::sql->max_seq() + 1; + } + + return bless { + ('unget' => \@unget, + 'command' => \@command, + 'replacecount' => $replacecount_ref, + 'arg_queue' => RecordQueue->new($read_from,$opt::colsep), + 'context_replace' => $context_replace, + 'len' => $len_ref, + 'max_number_of_args' => $max_number_of_args, + 'size' => undef, + 'transfer_files' => $transfer_files, + 'return_files' => $return_files, + 'template_names' => $template_names, + 'template_contents' => $template_contents, + 'seq' => $seq, + ) + }, ref($class) || $class; +} + +sub merge_rpl_parts($) { + # '{=' 'perlexpr' '=}' => '{= perlexpr =}' + # Input: + # @in = the @command as given by the user + # Uses: + # $Global::parensleft + # $Global::parensright + # Returns: + # @command with parts merged to keep {= and =} as one + my @in = @_; + my @out; + my $l = quotemeta($Global::parensleft); + my $r = quotemeta($Global::parensright); + + while(@in) { + my $s = shift @in; + $_ = $s; + # Remove matching (right most) parens + while(s/(.*)$l.*?$r/$1/os) {} + if(/$l/o) { + # Missing right parens + while(@in) { + $s .= " ".shift @in; + $_ = $s; + while(s/(.*)$l.*?$r/$1/os) {} + if(not /$l/o) { + last; + } + } + } + push @out, $s; + } + return @out; +} + +sub replacement_counts_and_lengths($$@) { + # Count the number of different replacement strings. + # Find the lengths of context for context groups and non-context + # groups. + # If no {} found in @command: add it to @command + # + # Input: + # \@transfer_files = array of filenames to transfer + # \@return_files = array of filenames to return + # \@template_names = array of names to copy to + # \@template_contents = array of contents to write + # @command = command template + # Output: + # \%replacecount, \%len, @command + my $transfer_files = shift; + my $return_files = shift; + my $template_names = shift; + my $template_contents = shift; + my @command = @_; + my (%replacecount,%len); + my $sum = 0; + while($sum == 0) { + # Count how many times each replacement string is used + my @cmd = @command; + my $contextlen = 0; + my $noncontextlen = 0; + my $contextgroups = 0; + for my $c (@cmd) { + while($c =~ s/ \257<( (?: [^\257]*|[\257][^<>] )*?)\257> /\000/xs) { + # %replacecount = { "perlexpr" => number of times seen } + # e.g { "s/a/b/" => 2 } + $replacecount{$1}++; + $sum++; + } + # Measure the length of the context around the {= perl expr =} + # Use that {=...=} has been replaced with \000 above + # So there is no need to deal with \257< + while($c =~ s/ (\S*\000\S*) //xs) { + my $w = $1; + $w =~ tr/\000//d; # Remove all \000's + $contextlen += length($w); + $contextgroups++; + } + # All {= perl expr =} have been removed: The rest is non-context + $noncontextlen += length $c; + } + for(@$transfer_files, @$return_files, + @$template_names, @$template_contents, + @opt::filter, + $opt::tagstring, $opt::workdir, $opt::results, $opt::retries) { + # Options that can contain replacement strings + defined($_) or next; + my $t = $_; + 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 + $replacecount{$1} ||= 1; + } + } + if($opt::bar) { + # If the command does not contain {} force it to be computed + # as it is being used by --bar + $replacecount{""} ||= 1; + } + + $len{'context'} = 0+$contextlen; + $len{'noncontext'} = $noncontextlen; + $len{'contextgroups'} = $contextgroups; + $len{'noncontextgroups'} = @cmd-$contextgroups; + ::debug("length", "@command Context: ", $len{'context'}, + " Non: ", $len{'noncontext'}, " Ctxgrp: ", $len{'contextgroups'}, + " NonCtxGrp: ", $len{'noncontextgroups'}, "\n"); + if($sum == 0) { + if(not @command) { + # Default command = {} + @command = ("\257<\257>"); + } elsif(($opt::pipe or $opt::pipepart) + and not $opt::fifo and not $opt::cat) { + # With --pipe / --pipe-part you can have no replacement + last; + } else { + # Append {} to the command if there are no {...}'s and no {=...=} + push @command, ("\257<\257>"); + } + } + } + return(\%replacecount,\%len,@command); +} + +sub get($) { + my $self = shift; + if(@{$self->{'unget'}}) { + my $cmd_line = shift @{$self->{'unget'}}; + return ($cmd_line); + } else { + if($opt::sqlworker) { + # Get the sequence number from the SQL table + $self->set_seq($SQL::next_seq); + # Get the command from the SQL table + $self->{'command'} = $SQL::command_ref; + my @command; + # Recompute replace counts based on the read command + ($self->{'replacecount'}, + $self->{'len'}, @command) = + replacement_counts_and_lengths($self->{'transfer_files'}, + $self->{'return_files'}, + $self->{'template_name'}, + $self->{'template_contents'}, + @$SQL::command_ref); + if("@command" =~ /^[^ \t\n=]*\257new($self->seq(), + $self->{'command'}, + $self->{'arg_queue'}, + $self->{'context_replace'}, + $self->{'max_number_of_args'}, + $self->{'transfer_files'}, + $self->{'return_files'}, + $self->{'template_names'}, + $self->{'template_contents'}, + $self->{'replacecount'}, + $self->{'len'}, + ); + $cmd_line->populate(); + ::debug("run","cmd_line->number_of_args ", + $cmd_line->number_of_args(), "\n"); + if(not $Global::no_more_input and ($opt::pipe or $opt::pipepart)) { + if($cmd_line->replaced() eq "") { + # Empty command - pipe requires a command + ::error(255,"--pipe/--pipepart must have a command to pipe ". + "into (e.g. 'cat')."); + } + } 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($) { + my $self = shift; + unshift @{$self->{'unget'}}, @_; +} + +sub empty($) { + my $self = shift; + my $empty = (not @{$self->{'unget'}}) && + $self->{'arg_queue'}->empty(); + ::debug("run", "CommandLineQueue->empty $empty"); + return $empty; +} + +sub seq($) { + my $self = shift; + return $self->{'seq'}; +} + +sub set_seq($$) { + my $self = shift; + $self->{'seq'} = shift; +} + +sub quote_args($) { + my $self = shift; + # If there is not command emulate |bash + return $self->{'command'}; +} + + +package Limits::Command; + +# Maximal command line length (for -m and -X) +sub max_length($) { + # Find the max_length of a command line and cache it + # Returns: + # number of chars on the longest command line allowed + if(not $Limits::Command::line_max_len) { + # Disk cache of max command line length + my $len_cache = $Global::cache_dir . "/tmp/sshlogin/" . ::hostname() . + "/linelen"; + my $cached_limit; + local $/ = undef; + if(open(my $fh, "<", $len_cache)) { + $cached_limit = <$fh>; + $cached_limit || ::warning("Invalid content in $len_cache"); + close $fh; + } + if(not $cached_limit) { + $cached_limit = real_max_length(); + # If $HOME is write protected: Do not fail + my $dir = ::dirname($len_cache); + -d $dir or eval { File::Path::mkpath($dir); }; + open(my $fh, ">", $len_cache.$$); + print $fh $cached_limit; + close $fh; + rename $len_cache.$$, $len_cache || ::die_bug("rename cache file"); + } + $Limits::Command::line_max_len = tmux_length($cached_limit); + } + return int($Limits::Command::line_max_len); +} + +sub real_max_length() { + # Find the max_length of a command line + # Returns: + # The maximal command line length with 1 byte arguments + # return find_max(" c"); + return find_max("c"); +} + +sub find_max($) { + my $string = shift; + # This is slow on Cygwin, so give Cygwin users a warning + if($^O eq "cygwin" or $^O eq "msys") { + ::warning("Finding the maximal command line length. ". + "This may take up to 1 minute.") + } + # Use an upper bound of 100 MB if the shell allows for infinite + # long lengths + my $upper = 100_000_000; + my $lower; + # 1000 is supported everywhere, so the search can start anywhere 1..999 + # 324 makes the search much faster on Cygwin, so let us use that + my $len = 324; + do { + if($len > $upper) { return $len }; + $lower = $len; + $len *= 4; + ::debug("init", "Maxlen: $lower<$len<$upper(".($upper-$lower)."): "); + } while (is_acceptable_command_line_length($len,$string)); + # Then search for the actual max length between + # last successful length ($len/16) and upper bound + return binary_find_max(int($len/16),$len,$string); +} + + +# Prototype forwarding +sub binary_find_max($$$); +sub binary_find_max($$$) { + # Given a lower and upper bound find the max (length or args) of a + # command line + # Returns: + # number of chars on the longest command line allowed + my ($lower, $upper, $string) = (@_); + if($lower == $upper + or $lower == $upper-1 + or $lower/$upper > 0.99) { + # $lower is +- 1 or within 1%: Don't search more + return $lower; + } + # Unevenly split binary search which is faster for Microsoft Windows. + # Guessing too high is cheap. Guessing too low is expensive. + my $split = ($^O eq "cygwin" or $^O eq "msys") ? 0.93 : 0.5; + my $middle = int (($upper-$lower)*$split + $lower); + ::debug("init", "Maxlen: $lower<$middle<$upper(".($upper-$lower)."): "); + if (is_acceptable_command_line_length($middle,$string)) { + return binary_find_max($middle,$upper,$string); + } else { + return binary_find_max($lower,$middle,$string); + } +} + +{ + my $prg; + + sub is_acceptable_command_line_length($$) { + # Test if a command line of this length can run + # in the current environment + # If the string is " x" it tests how many args are allowed + # Returns: + # 0 if the command line length is too long + # 1 otherwise + my $len = shift; + my $string = shift; + if($Global::parallel_env) { + $len += length $Global::parallel_env; + } + # Force using non-built-in command + $prg ||= ::which("echo") || ::error(255,'echo must be in $PATH'); + my $l = length ::qqx("$prg ".${string}x(($len-1-length $prg)/length $string)); + if($l < $len/2) { + # The command returned OK, but did not output $len chars + # => this failed (Centos3 does this craziness) + return 0 + } + ::debug("init", "$len=$?\n"); + return not $?; + } +} + +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 + # tmux 2.0 has a 16kB limit + # tmux 2.1 has a 16kB limit + # tmux 2.2 has a 16kB limit + # Input: + # $len = maximal command line length + # Returns: + # $tmux_len = maximal length runable in tmux + local $/ = "\n"; + my $len = shift; + if($opt::tmux) { + $ENV{'PARALLEL_TMUX'} ||= "tmux"; + if(not ::which($ENV{'PARALLEL_TMUX'})) { + ::error(255,$ENV{'PARALLEL_TMUX'}." not found in \$PATH."); + } + my @out; + for my $l (1, 2020, 16320, 30000, $len) { + my $tmpfile = ::tmpname("tms"); + my $qtmp = ::Q($tmpfile); + my $tmuxcmd = $ENV{'PARALLEL_TMUX'}. + " -S $qtmp new-session -d -n echo $l". + ("t"x$l). " && echo $l; rm -f $qtmp"; + push @out, ::qqx($tmuxcmd); + ::rm($tmpfile); + } + ::debug("tmux","tmux-out ",@out); + chomp @out; + # The arguments is given 3 times on the command line + # and the tmux wrapping is around 30 chars + # (29 for tmux1.9, 33 for tmux1.8) + my $tmux_len = ::max(@out); + $len = ::min($len,int($tmux_len/4-33)); + ::debug("tmux","tmux-length ",$len); + } + return $len; +} + + +package RecordQueue; + +sub new($) { + my $class = shift; + my $fhs = shift; + my $colsep = shift; + my @unget = (); + my $arg_sub_queue; + if($opt::sqlworker) { + # Open SQL table + $arg_sub_queue = SQLRecordQueue->new(); + } elsif(defined $colsep) { + # Open one file with colsep or CSV + $arg_sub_queue = RecordColQueue->new($fhs); + } else { + # Open one or more files if multiple -a + $arg_sub_queue = MultifileQueue->new($fhs); + } + return bless { + 'unget' => \@unget, + 'arg_number' => 0, + 'arg_sub_queue' => $arg_sub_queue, + }, ref($class) || $class; +} + +sub get($) { + # Returns: + # reference to array of Arg-objects + my $self = shift; + if(@{$self->{'unget'}}) { + $self->{'arg_number'}++; + # Flush cached computed replacements in Arg-objects + # To fix: parallel --bar echo {%} ::: a b c ::: d e f + my $ret = shift @{$self->{'unget'}}; + if($ret) { + map { $_->flush_cache() } @$ret; + } + return $ret; + } + 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 "\0noarg" + # to mean no-string + ::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"); + # \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 + map { $_->flush_cache() } @$ret; + } + return $ret; +} + +sub unget($) { + my $self = shift; + ::debug("run", "RecordQueue-unget\n"); + $self->{'arg_number'} -= @_; + unshift @{$self->{'unget'}}, @_; +} + +sub empty($) { + my $self = shift; + my $empty = (not @{$self->{'unget'}}) && + $self->{'arg_sub_queue'}->empty(); + ::debug("run", "RecordQueue->empty $empty"); + return $empty; +} + +sub flush_cache($) { + my $self = shift; + for my $record (@{$self->{'unget'}}) { + for my $arg (@$record) { + $arg->flush_cache(); + } + } + $self->{'arg_sub_queue'}->flush_cache(); +} + +sub arg_number($) { + my $self = shift; + return $self->{'arg_number'}; +} + + +package RecordColQueue; + +sub new($) { + my $class = shift; + my $fhs = shift; + my @unget = (); + my $arg_sub_queue = MultifileQueue->new($fhs); + return bless { + 'unget' => \@unget, + 'arg_sub_queue' => $arg_sub_queue, + }, ref($class) || $class; +} + +sub get($) { + # Returns: + # reference to array of Arg-objects + my $self = shift; + if(@{$self->{'unget'}}) { + return shift @{$self->{'unget'}}; + } + if($self->{'arg_sub_queue'}->empty()) { + return undef; + } + my $in_record = $self->{'arg_sub_queue'}->get(); + if(defined $in_record) { + my @out_record = (); + for my $arg (@$in_record) { + ::debug("run", "RecordColQueue::arg $arg\n"); + my $line = $arg->orig(); + ::debug("run", "line='$line'\n"); + if($line ne "") { + if($opt::csv) { + # Parse CSV and put it into a record + chomp $line; + if(not $Global::csv->parse($line)) { + die "CSV has unexpected format: ^$line^"; + } + for($Global::csv->fields()) { + push @out_record, Arg->new($_); + } + } else { + # Split --colsep into record + for my $s (split /$opt::colsep/o, $line, -1) { + push @out_record, Arg->new($s); + } + } + } else { + push @out_record, Arg->new(""); + } + } + return \@out_record; + } else { + return undef; + } +} + +sub unget($) { + my $self = shift; + ::debug("run", "RecordColQueue-unget '@_'\n"); + unshift @{$self->{'unget'}}, @_; +} + +sub empty($) { + my $self = shift; + my $empty = (not @{$self->{'unget'}}) && + $self->{'arg_sub_queue'}->empty(); + ::debug("run", "RecordColQueue->empty $empty"); + return $empty; +} + +sub flush_cache($) { + my $self = shift; + for my $arg (@{$self->{'unget'}}) { + $arg->flush_cache(); + } + $self->{'arg_sub_queue'}->flush_cache(); +} + + +package SQLRecordQueue; + +sub new($) { + my $class = shift; + my @unget = (); + return bless { + 'unget' => \@unget, + }, ref($class) || $class; +} + +sub get($) { + # Returns: + # reference to array of Arg-objects + my $self = shift; + if(@{$self->{'unget'}}) { + return shift @{$self->{'unget'}}; + } + return $Global::sql->get_record(); +} + +sub unget($) { + my $self = shift; + ::debug("run", "SQLRecordQueue-unget '@_'\n"); + unshift @{$self->{'unget'}}, @_; +} + +sub empty($) { + my $self = shift; + if(@{$self->{'unget'}}) { return 0; } + my $get = $self->get(); + if(defined $get) { + $self->unget($get); + } + my $empty = not $get; + ::debug("run", "SQLRecordQueue->empty $empty"); + return $empty; +} + +sub flush_cache($) { + my $self = shift; + for my $record (@{$self->{'unget'}}) { + for my $arg (@$record) { + $arg->flush_cache(); + } + } +} + + +package MultifileQueue; + +@Global::unget_argv=(); + +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 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."); + } + } + return bless { + 'unget' => \@Global::unget_argv, + 'fhs' => $fhs, + 'arg_matrix' => undef, + }, ref($class) || $class; +} + +sub get($) { + my $self = shift; + if($opt::link) { + return $self->link_get(); + } else { + return $self->nest_get(); + } +} + +sub unget($) { + my $self = shift; + ::debug("run", "MultifileQueue-unget '@_'\n"); + unshift @{$self->{'unget'}}, @_; +} + +sub empty($) { + my $self = shift; + my $empty = (not @Global::unget_argv) && + not @{$self->{'unget'}}; + for my $fh (@{$self->{'fhs'}}) { + $empty &&= eof($fh); + } + ::debug("run", "MultifileQueue->empty $empty "); + return $empty; +} + +sub flush_cache($) { + my $self = shift; + for my $record (@{$self->{'unget'}}, @{$self->{'arg_matrix'}}) { + for my $arg (@$record) { + $arg->flush_cache(); + } + } +} + +sub link_get($) { + my $self = shift; + if(@{$self->{'unget'}}) { + return shift @{$self->{'unget'}}; + } + my @record = (); + my $prepend; + my $empty = 1; + for my $i (0..$#{$self->{'fhs'}}) { + my $fh = $self->{'fhs'}[$i]; + my $arg = read_arg_from_fh($fh); + if(defined $arg) { + # Record $arg for recycling at end of file + push @{$self->{'arg_matrix'}[$i]}, $arg; + push @record, $arg; + $empty = 0; + } else { + ::debug("run", "EOA "); + # End of file: Recycle arguments + push @{$self->{'arg_matrix'}[$i]}, shift @{$self->{'arg_matrix'}[$i]}; + # return last @{$args->{'args'}{$fh}}; + push @record, @{$self->{'arg_matrix'}[$i]}[-1]; + } + } + if($empty) { + return undef; + } else { + return \@record; + } +} + +sub nest_get($) { + my $self = shift; + if(@{$self->{'unget'}}) { + return shift @{$self->{'unget'}}; + } + my @record = (); + my $prepend; + my $empty = 1; + my $no_of_inputsources = $#{$self->{'fhs'}} + 1; + if(not $self->{'arg_matrix'}) { + # Initialize @arg_matrix with one arg from each file + # read one line from each file + my @first_arg_set; + my $all_empty = 1; + for (my $fhno = 0; $fhno < $no_of_inputsources ; $fhno++) { + my $arg = read_arg_from_fh($self->{'fhs'}[$fhno]); + if(defined $arg) { + $all_empty = 0; + } + $self->{'arg_matrix'}[$fhno][0] = $arg || Arg->new(""); + push @first_arg_set, $self->{'arg_matrix'}[$fhno][0]; + } + if($all_empty) { + # All filehandles were at eof or eof-string + return undef; + } + return [@first_arg_set]; + } + + # Treat the case with one input source special. For multiple + # input sources we need to remember all previously read values to + # generate all combinations. But for one input source we can + # forget the value after first use. + if($no_of_inputsources == 1) { + my $arg = read_arg_from_fh($self->{'fhs'}[0]); + if(defined($arg)) { + return [$arg]; + } + return undef; + } + for (my $fhno = $no_of_inputsources - 1; $fhno >= 0; $fhno--) { + if(eof($self->{'fhs'}[$fhno])) { + next; + } else { + # read one + my $arg = read_arg_from_fh($self->{'fhs'}[$fhno]); + defined($arg) || next; # If we just read an EOF string: Treat this as EOF + my $len = $#{$self->{'arg_matrix'}[$fhno]} + 1; + $self->{'arg_matrix'}[$fhno][$len] = $arg; + # make all new combinations + my @combarg = (); + for (my $fhn = 0; $fhn < $no_of_inputsources; $fhn++) { + push(@combarg, [0, $#{$self->{'arg_matrix'}[$fhn]}], + # Is input source --link'ed to the next? + $opt::linkinputsource[$fhn+1]); + } + # Find only combinations with this new entry + $combarg[2*$fhno] = [$len,$len]; + # map combinations + # [ 1, 3, 7 ], [ 2, 4, 1 ] + # => + # [ m[0][1], m[1][3], m[2][7] ], [ m[0][2], m[1][4], m[2][1] ] + my @mapped; + for my $c (expand_combinations(@combarg)) { + my @a; + for my $n (0 .. $no_of_inputsources - 1 ) { + push @a, $self->{'arg_matrix'}[$n][$$c[$n]]; + } + push @mapped, \@a; + } + # append the mapped to the ungotten arguments + push @{$self->{'unget'}}, @mapped; + # get the first + if(@mapped) { + return shift @{$self->{'unget'}}; + } + } + } + # all are eof or at EOF string; return from the unget queue + return shift @{$self->{'unget'}}; +} + +{ + my $cr_count = 0; + my $nl_count = 0; + my $dos_crnl_determined; + sub read_arg_from_fh($) { + # Read one Arg from filehandle + # Returns: + # Arg-object with one read line + # undef if end of file + my $fh = shift; + my $prepend; + my $arg; + my $half_record = 0; + do {{ + # This makes 10% faster + if(not defined ($arg = <$fh>)) { + if(defined $prepend) { + return Arg->new($prepend); + } else { + return undef; + } + } + if(not $dos_crnl_determined and not defined $opt::d) { + # Warn if input has CR-NL and -d is not set + if($arg =~ /\r$/) { + $cr_count++; + } else { + $nl_count++; + } + if($cr_count == 3 or $nl_count == 3) { + $dos_crnl_determined = 1; + if($nl_count == 0 and $cr_count == 3) { + ::warning('The first three values end in CR-NL. '. + 'Consider using -d "\r\n"'); + } + } + } + if($opt::csv) { + # We need to read a full CSV line. + if(($arg =~ y/"/"/) % 2 ) { + # The number of " on the line is uneven: + # If we were in a half_record => we have a full record now + # If we were outside a half_record => + # we are in a half record now + $half_record = not $half_record; + } + if($half_record) { + # CSV half-record with quoting: + # col1,"col2 2""x3"" board newline <-this one + # cont",col3 + $prepend .= $arg; + redo; + } else { + # Now we have a full CSV record + } + } + # Remove delimiter + chomp $arg; + if($Global::end_of_file_string and + $arg eq $Global::end_of_file_string) { + # Ignore the rest of input file + close $fh; + ::debug("run", "EOF-string ($arg) met\n"); + if(defined $prepend) { + return Arg->new($prepend); + } else { + return undef; + } + } + if(defined $prepend) { + $arg = $prepend.$arg; # For line continuation + undef $prepend; + } + if($Global::ignore_empty) { + if($arg =~ /^\s*$/) { + redo; # Try the next line + } + } + if($Global::max_lines) { + if($arg =~ /\s$/) { + # Trailing space => continued on next line + $prepend = $arg; + redo; + } + } + }} while (1 == 0); # Dummy loop {{}} for redo + if(defined $arg) { + return Arg->new($arg); + } else { + ::die_bug("multiread arg undefined"); + } + } +} + +# Prototype forwarding +sub expand_combinations(@); +sub expand_combinations(@) { + # Input: + # ([xmin,xmax], [ymin,ymax], ...) + # Returns: ([x,y,...],[x,y,...]) + # where xmin <= x <= xmax and ymin <= y <= ymax + my $minmax_ref = shift; + my $link = shift; # This is linked to the next input source + my $xmin = $$minmax_ref[0]; + my $xmax = $$minmax_ref[1]; + my @p; + if(@_) { + my @rest = expand_combinations(@_); + if($link) { + # Linked to next col with --link/:::+/::::+ + # TODO BUG does not wrap values if not same number of vals + push(@p, map { [$$_[0], @$_] } + grep { $xmin <= $$_[0] and $$_[0] <= $xmax } @rest); + } else { + # If there are more columns: Compute those recursively + for(my $x = $xmin; $x <= $xmax; $x++) { + push @p, map { [$x, @$_] } @rest; + } + } + } else { + for(my $x = $xmin; $x <= $xmax; $x++) { + push @p, [$x]; + } + } + return @p; +} + + +package Arg; + +sub new($) { + my $class = shift; + my $orig = shift; + my @hostgroups; + if($opt::hostgroups) { + if($orig =~ s:@(.+)::) { + # We found hostgroups on the arg + @hostgroups = split(/\+|,/, $1); + if(not grep { defined $Global::hostgroups{$_} } @hostgroups) { + # This hostgroup is not defined using -S + # Add it + ::warning("Adding hostgroups: @hostgroups"); + # Add sshlogin + for(grep { not defined $Global::hostgroups{$_} } @hostgroups) { + my $sshlogin = SSHLogin->new($_); + my $sshlogin_string = $sshlogin->string(); + $Global::host{$sshlogin_string} = $sshlogin; + $Global::hostgroups{$sshlogin_string} = 1; + } + } + } else { + # No hostgroup on the arg => any hostgroup + @hostgroups = (keys %Global::hostgroups); + } + } + return bless { + 'orig' => $orig, + 'hostgroups' => \@hostgroups, + }, ref($class) || $class; +} + +sub Q($) { + # Q alias for ::shell_quote_scalar + my $ret = ::Q($_[0]); + no warnings 'redefine'; + *Q = \&::Q; + return $ret; +} + +sub pQ($) { + # pQ alias for ::perl_quote_scalar + my $ret = ::pQ($_[0]); + no warnings 'redefine'; + *pQ = \&::pQ; + return $ret; +} + +sub hash($) { + $Global::use{"DBI"} ||= eval "use B; 1;"; + B::hash(@_); +} + +sub total_jobs() { + return $Global::JobQueue->total_jobs(); +} + +{ + my %perleval; + my $job; + sub skip() { + # shorthand for $job->skip(); + $job->skip(); + } + sub slot() { + # shorthand for $job->slot(); + $job->slot(); + } + sub seq() { + # shorthand for $job->seq(); + $job->seq(); + } + sub uq() { + # Do not quote this arg + $Global::unquote_arg = 1; + } + sub yyyy_mm_dd_hh_mm_ss(@) { + # ISO8601 2038-01-19T03:14:08 + ::strftime("%Y-%m-%dT%H:%M:%S", localtime(shift || time())); + } + sub yyyy_mm_dd_hh_mm(@) { + # ISO8601 2038-01-19T03:14 + ::strftime("%Y-%m-%dT%H:%M", localtime(shift || time())); + } + sub yyyy_mm_dd(@) { + # ISO8601 2038-01-19 + ::strftime("%Y-%m-%d", localtime(shift || time())); + } + sub hh_mm_ss(@) { + # ISO8601 03:14:08 + ::strftime("%H:%M:%S", localtime(shift || time())); + } + sub hh_mm(@) { + # ISO8601 03:14 + ::strftime("%H:%M", localtime(shift || time())); + } + sub yyyymmddhhmmss(@) { + # ISO8601 20380119 + ISO8601 031408 + ::strftime("%Y%m%d%H%M%S", localtime(shift || time())); + } + sub yyyymmddhhmm(@) { + # ISO8601 20380119 + ISO8601 0314 + ::strftime("%Y%m%d%H%M", localtime(shift || time())); + } + sub yyyymmdd(@) { + # ISO8601 20380119 + ::strftime("%Y%m%d", localtime(shift || time())); + } + sub hhmmss(@) { + # ISO8601 031408 + ::strftime("%H%M%S", localtime(shift || time())); + } + sub hhmm(@) { + # ISO8601 0314 + ::strftime("%H%M", localtime(shift || time())); + } + + sub replace($$$$) { + # Calculates the corresponding value for a given perl expression + # Returns: + # The calculated string (quoted if asked for) + my $self = shift; + my $perlexpr = shift; # E.g. $_=$_ or s/.gz// + my $quote = shift; # should the string be quoted? + # This is actually a CommandLine-object, + # but it looks nice to be able to say {= $job->slot() =} + $job = shift; + # Positional replace treated as normal replace + $perlexpr =~ s/^(-?\d+)? *//; + if(not $Global::cache_replacement_eval + or + not $self->{'cache'}{$perlexpr}) { + # Only compute the value once + # Use $_ as the variable to change + local $_; + if($Global::trim eq "n") { + $_ = $self->{'orig'}; + } else { + # Trim the input + $_ = trim_of($self->{'orig'}); + } + ::debug("replace", "eval ", $perlexpr, " ", $_, "\n"); + if(not $perleval{$perlexpr}) { + # Make an anonymous function of the $perlexpr + # And more importantly: Compile it only once + if($perleval{$perlexpr} = + eval('sub { no strict; no warnings; my $job = shift; '. + $perlexpr.' }')) { + # All is good + } else { + # The eval failed. Maybe $perlexpr is invalid perl? + ::error(255,"Cannot use $perlexpr: $@"); + } + } + # Execute the function + $perleval{$perlexpr}->($job); + $self->{'cache'}{$perlexpr} = $_; + if($Global::unquote_arg) { + # uq() was called in perlexpr + $self->{'cache'}{'unquote'}{$perlexpr} = 1; + # Reset for next perlexpr + $Global::unquote_arg = 0; + } + } + # Return the value quoted if needed + if($self->{'cache'}{'unquote'}{$perlexpr}) { + return($self->{'cache'}{$perlexpr}); + } else { + return($quote ? Q($self->{'cache'}{$perlexpr}) + : $self->{'cache'}{$perlexpr}); + } + } +} + +sub flush_cache($) { + # Flush cache of computed values + my $self = shift; + $self->{'cache'} = undef; +} + +sub orig($) { + my $self = shift; + return $self->{'orig'}; +} + +sub set_orig($$) { + my $self = shift; + $self->{'orig'} = shift; +} + +sub trim_of($) { + # Removes white space as specifed by --trim: + # n = nothing + # l = start + # r = end + # lr|rl = both + # Returns: + # string with white space removed as needed + my @strings = map { defined $_ ? $_ : "" } (@_); + my $arg; + if($Global::trim eq "n") { + # skip + } elsif($Global::trim eq "l") { + for my $arg (@strings) { $arg =~ s/^\s+//; } + } elsif($Global::trim eq "r") { + for my $arg (@strings) { $arg =~ s/\s+$//; } + } elsif($Global::trim eq "rl" or $Global::trim eq "lr") { + for my $arg (@strings) { $arg =~ s/^\s+//; $arg =~ s/\s+$//; } + } else { + ::error(255,"--trim must be one of: r l rl lr."); + } + return wantarray ? @strings : "@strings"; +} + + +package TimeoutQueue; + +sub new($) { + my $class = shift; + my $delta_time = shift; + my ($pct); + if($delta_time =~ /(\d+(\.\d+)?)%/) { + # Timeout in percent + $pct = $1/100; + $delta_time = 1_000_000; + } + $delta_time = ::multiply_time_units($delta_time); + + return bless { + 'queue' => [], + 'delta_time' => $delta_time, + 'pct' => $pct, + 'remedian_idx' => 0, + 'remedian_arr' => [], + 'remedian' => undef, + }, ref($class) || $class; +} + +sub delta_time($) { + my $self = shift; + return $self->{'delta_time'}; +} + +sub set_delta_time($$) { + my $self = shift; + $self->{'delta_time'} = shift; +} + +sub remedian($) { + my $self = shift; + return $self->{'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 + # robust averaging method for large data sets." Journal of the + # American Statistical Association 85.409 (1990): 97-104. + my $self = shift; + my $val = shift; + my $i = $self->{'remedian_idx'}++; + my $rref = $self->{'remedian_arr'}; + $rref->[0][$i%999] = $val; + $rref->[1][$i/999%999] = (sort @{$rref->[0]})[$#{$rref->[0]}/2]; + $rref->[2][$i/999/999%999] = (sort @{$rref->[1]})[$#{$rref->[1]}/2]; + $self->{'remedian'} = (sort @{$rref->[2]})[$#{$rref->[2]}/2]; +} + +sub update_median_runtime($) { + # Update delta_time based on runtime of finished job if timeout is + # a percentage + my $self = shift; + my $runtime = shift; + if($self->{'pct'}) { + $self->set_remedian($runtime); + $self->{'delta_time'} = $self->{'pct'} * $self->remedian(); + ::debug("run", "Timeout: $self->{'delta_time'}s "); + } +} + +sub process_timeouts($) { + # Check if there was a timeout + my $self = shift; + # $self->{'queue'} is sorted by start time + while (@{$self->{'queue'}}) { + my $job = $self->{'queue'}[0]; + if($job->endtime()) { + # Job already finished. No need to timeout the job + # This could be because of --keep-order + shift @{$self->{'queue'}}; + } elsif($job->is_timedout($self->{'delta_time'})) { + # Need to shift off queue before kill + # because kill calls usleep that calls process_timeouts + shift @{$self->{'queue'}}; + ::warning("This job was killed because it timed out:", + $job->replaced()); + $job->kill(); + } else { + # Because they are sorted by start time the rest are later + last; + } + } +} + +sub insert($) { + my $self = shift; + my $in = shift; + push @{$self->{'queue'}}, $in; +} + + +package SQL; + +sub new($) { + my $class = shift; + my $dburl = shift; + $Global::use{"DBI"} ||= eval "use DBI; 1;"; + # +DBURL = append to this DBURL + my $append = $dburl=~s/^\+//; + my %options = parse_dburl(get_alias($dburl)); + my %driveralias = ("sqlite" => "SQLite", + "sqlite3" => "SQLite", + "pg" => "Pg", + "postgres" => "Pg", + "postgresql" => "Pg", + "csv" => "CSV", + "oracle" => "Oracle", + "ora" => "Oracle"); + my $driver = $driveralias{$options{'databasedriver'}} || + $options{'databasedriver'}; + my $database = $options{'database'}; + my $host = $options{'host'} ? ";host=".$options{'host'} : ""; + my $port = $options{'port'} ? ";port=".$options{'port'} : ""; + my $dsn = "DBI:$driver:dbname=$database$host$port"; + my $userid = $options{'user'}; + my $password = $options{'password'};; + if(not grep /$driver/, DBI->available_drivers) { + ::error(255,"$driver not supported. ". + "Are you missing a perl DBD::$driver module?"); + } + my $dbh; + if($driver eq "CSV") { + # CSV does not use normal dsn + if(-d $database) { + $dbh = DBI->connect("dbi:CSV:", "", "", { f_dir => "$database", }) + or die $DBI::errstr; + } else { + ::error(255,"$database is not a directory."); + } + } else { + $dbh = DBI->connect($dsn, $userid, $password, + { RaiseError => 1, AutoInactiveDestroy => 1 }) + or die $DBI::errstr; + } + $dbh->{'PrintWarn'} = $Global::debug || 0; + $dbh->{'PrintError'} = $Global::debug || 0; + $dbh->{'RaiseError'} = 1; + $dbh->{'ShowErrorStatement'} = 1; + $dbh->{'HandleError'} = sub {}; + if(not defined $options{'table'}) { + ::error(255,"The DBURL ($dburl) must contain a table."); + } + + return bless { + 'dbh' => $dbh, + 'driver' => $driver, + 'max_number_of_args' => undef, + 'table' => $options{'table'}, + 'append' => $append, + }, ref($class) || $class; +} + +# Prototype forwarding +sub get_alias($); +sub get_alias($) { + my $alias = shift; + $alias =~ s/^(sql:)*//; # Accept aliases prepended with sql: + if ($alias !~ /^:/) { + return $alias; + } + + # Find the alias + my $path; + if (-l $0) { + ($path) = readlink($0) =~ m|^(.*)/|; + } else { + ($path) = $0 =~ m|^(.*)/|; + } + + my @deprecated = ("$ENV{HOME}/.dburl.aliases", + "$path/dburl.aliases", "$path/dburl.aliases.dist"); + for (@deprecated) { + if(-r $_) { + ::warning("$_ is deprecated. ". + "Use .sql/aliases instead (read man sql)."); + } + } + my @urlalias=(); + check_permissions("$ENV{HOME}/.sql/aliases"); + check_permissions("$ENV{HOME}/.dburl.aliases"); + my @search = ("$ENV{HOME}/.sql/aliases", + "$ENV{HOME}/.dburl.aliases", "/etc/sql/aliases", + "$path/dburl.aliases", "$path/dburl.aliases.dist"); + for my $alias_file (@search) { + # local $/ needed if -0 set + local $/ = "\n"; + if(-r $alias_file) { + my $in = ::open_or_exit("<",$alias_file); + push @urlalias, <$in>; + close $in; + } + } + my ($alias_part,$rest) = $alias=~/(:\w*)(.*)/; + # If we saw this before: we have an alias loop + if(grep {$_ eq $alias_part } @Private::seen_aliases) { + ::error("$alias_part is a cyclic alias."); + exit -1; + } else { + push @Private::seen_aliases, $alias_part; + } + + my $dburl; + for (@urlalias) { + /^$alias_part\s+(\S+.*)/ and do { $dburl = $1; last; } + } + + if($dburl) { + return get_alias($dburl.$rest); + } else { + ::error("$alias is not defined in @search"); + exit(-1); + } +} + +sub check_permissions($) { + my $file = shift; + + if(-e $file) { + if(not -o $file) { + my $username = (getpwuid($<))[0]; + ::warning("$file should be owned by $username: ". + "chown $username $file"); + } + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($file); + if($mode & 077) { + my $username = (getpwuid($<))[0]; + ::warning("$file should be only be readable by $username: ". + "chmod 600 $file"); + } + } +} + +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:' + ((?:oracle|ora|mysql|pg|postgres|postgresql)(?:s|ssl|)| + (?:sqlite|sqlite2|sqlite3|csv)):// # Databasedriver ($1) + (?: + ([^:@/][^:@]*|) # Username ($2) + (?: + :([^@]*) # Password ($3) + )? + @)? + ([^:/]*)? # Hostname ($4) + (?: + : + ([^/]*)? # Port ($5) + )? + (?: + / + ([^/?]*)? # Database ($6) + )? + (?: + / + ([^?]*)? # Table ($7) + )? + (?: + \? + (.*)? # Query ($8) + )? + $!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)); + $options{host} = ::undef_if_empty(uri_unescape($4)); + $options{port} = ::undef_if_empty(uri_unescape($5)); + $options{database} = ::undef_if_empty(uri_unescape($6)); + $options{table} = ::undef_if_empty(uri_unescape($7)); + $options{query} = ::undef_if_empty(uri_unescape($8)); + ::debug("sql", "dburl $url\n"); + ::debug("sql", "databasedriver ", $options{databasedriver}, + " user ", $options{user}, + " password ", $options{password}, " host ", $options{host}, + " port ", $options{port}, " database ", $options{database}, + " table ", $options{table}, " query ", $options{query}, "\n"); + } else { + ::error("$url is not a valid DBURL"); + exit 255; + } + return %options; +} + +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. + # Note from RFC1630: "Sequences which start with a percent sign + # but are not followed by two hexadecimal characters are reserved + # for future extension" + my $str = shift; + if (@_ && wantarray) { + # not executed for the common case of a single argument + my @str = ($str, @_); # need to copy + foreach (@str) { + s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + } + return @str; + } + $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; + $str; +} + +sub run($) { + my $self = shift; + my $stmt = shift; + if($self->{'driver'} eq "CSV") { + $stmt=~ s/;$//; + if($stmt eq "BEGIN" or + $stmt eq "COMMIT") { + return undef; + } + } + my @retval; + my $dbh = $self->{'dbh'}; + ::debug("sql","$opt::sqlmaster$opt::sqlworker run $stmt\n"); + # Execute with the rest of the args - if any + my $rv; + my $sth; + my $lockretry = 0; + while($lockretry < 10) { + $sth = $dbh->prepare($stmt); + if($sth + and + eval { $rv = $sth->execute(@_) }) { + last; + } else { + if($@ =~ /no such table|Table .* doesn.t exist|relation ".*" does not exist/ + or + $DBI::errstr =~ /no such table|Table .* doesn.t exist|relation ".*" does not exist/) { + # This is fine: + # It is just a worker that reported back too late - + # another worker had finished the job first + # and the table was then dropped + $rv = $sth = 0; + last; + } + if($DBI::errstr =~ /locked/) { + ::debug("sql", "Lock retry: $lockretry"); + $lockretry++; + ::usleep(rand()*300); + } elsif(not $sth) { + # Try again + $lockretry++; + } else { + ::error(255,$DBI::errstr); + } + } + } + if($lockretry >= 10) { + ::die_bug("retry > 10: $DBI::errstr"); + } + if($rv < 0 and $DBI::errstr){ + ::error(255,$DBI::errstr); + } + return $sth; +} + +sub get($) { + my $self = shift; + my $sth = $self->run(@_); + my @retval; + # If $sth = 0 it means the table was dropped by another process + while($sth) { + my @row = $sth->fetchrow_array(); + @row or last; + push @retval, \@row; + } + return \@retval; +} + +sub table($) { + my $self = shift; + return $self->{'table'}; +} + +sub append($) { + my $self = shift; + return $self->{'append'}; +} + +sub update($) { + my $self = shift; + my $stmt = shift; + my $table = $self->table(); + $self->run("UPDATE $table $stmt",@_); +} + +sub output($) { + my $self = shift; + my $commandline = shift; + + $self->update("SET Stdout = ?, Stderr = ? WHERE Seq = ". + $commandline->seq(), + join("",@{$commandline->{'output'}{1}}), + join("",@{$commandline->{'output'}{2}})); +} + +sub max_number_of_args($) { + # Maximal number of args for this table + my $self = shift; + if(not $self->{'max_number_of_args'}) { + # Read the number of args from the SQL table + my $table = $self->table(); + my $v = $self->get("SELECT * FROM $table LIMIT 1;"); + my @reserved_columns = qw(Seq Host Starttime JobRuntime Send + Receive Exitval _Signal Command Stdout Stderr); + if(not $v) { + ::error("$table contains no records"); + } + # Count the number of Vx columns + $self->{'max_number_of_args'} = $#{$v->[0]} - $#reserved_columns; + } + return $self->{'max_number_of_args'}; +} + +sub set_max_number_of_args($$) { + my $self = shift; + $self->{'max_number_of_args'} = shift; +} + +sub create_table($) { + my $self = shift; + if($self->append()) { return; } + my $max_number_of_args = shift; + $self->set_max_number_of_args($max_number_of_args); + my $table = $self->table(); + $self->run(qq(DROP TABLE IF EXISTS $table;)); + # BIGINT and TEXT are not supported in these databases or are too small + my %vartype = ( + "Oracle" => { "BIGINT" => "NUMBER(19,0)", + "TEXT" => "CLOB", }, + "mysql" => { "TEXT" => "BLOB", }, + "CSV" => { "BIGINT" => "INT", + "FLOAT" => "REAL", }, + ); + my $BIGINT = $vartype{$self->{'driver'}}{"BIGINT"} || "BIGINT"; + my $TEXT = $vartype{$self->{'driver'}}{"TEXT"} || "TEXT"; + my $FLOAT = $vartype{$self->{'driver'}}{"FLOAT"} || "FLOAT(44)"; + my $v_def = join "", map { "V$_ $TEXT," } (1..$self->max_number_of_args()); + $self->run(qq{CREATE TABLE $table + (Seq $BIGINT, + Host $TEXT, + Starttime $FLOAT, + JobRuntime $FLOAT, + Send $BIGINT, + Receive $BIGINT, + Exitval $BIGINT, + _Signal $BIGINT, + Command $TEXT,}. + $v_def. + qq{Stdout $TEXT, + Stderr $TEXT);}); +} + +sub insert_records($) { + my $self = shift; + my $seq = shift; + my $command_ref = shift; + my $record_ref = shift; + my $table = $self->table(); + # For SQL encode the command with \257 space as split points + my $command = join("\257 ",@$command_ref); + 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) ". + "VALUES ($v_vals);", $seq, $command, -1000, + 0, @$record_ref[1..$#$record_ref]); +} + + +sub get_record($) { + my $self = shift; + my @retval; + my $table = $self->table(); + my @v_cols = map { ", V$_" } (1..$self->max_number_of_args()); + my $rand = "Reserved-".$$.rand(); + my $v; + my $more_pending; + + do { + if($self->{'driver'} eq "CSV") { + # Sub SELECT is not supported in CSV + # So to minimize the race condition below select a job at random + my $r = $self->get("SELECT Seq, Command @v_cols FROM $table ". + "WHERE Exitval = -1000 LIMIT 100;"); + $v = [ sort { rand() > 0.5 } @$r ]; + } else { + # Avoid race condition where multiple workers get the same job + # by setting Stdout to a unique string + # (SELECT * FROM (...) AS dummy) is needed due to sillyness in MySQL + $self->update("SET Stdout = ?,Exitval = ? ". + "WHERE Seq = (". + " SELECT * FROM (". + " SELECT min(Seq) FROM $table WHERE Exitval = -1000". + " ) AS dummy". + ") AND Exitval = -1000;", $rand, -1210); + # If a parallel worker overwrote the unique string this will get nothing + $v = $self->get("SELECT Seq, Command @v_cols FROM $table ". + "WHERE Stdout = ?;", $rand); + } + if($v->[0]) { + my $val_ref = $v->[0]; + # Mark record as taken + my $seq = shift @$val_ref; + # Save the sequence number to use when running the job + $SQL::next_seq = $seq; + $self->update("SET Exitval = ? WHERE Seq = ".$seq, -1220); + # Command is encoded with '\257 space' as splitting char + my @command = split /\257 /, shift @$val_ref; + $SQL::command_ref = \@command; + for (@$val_ref) { + push @retval, Arg->new($_); + } + } else { + # If the record was updated by another job in parallel, + # then we may not be done, so see if there are more jobs pending + $more_pending = + $self->get("SELECT Seq FROM $table WHERE Exitval = ?;", -1210); + } + } while (not $v->[0] and $more_pending->[0]); + + if(@retval) { + return \@retval; + } else { + return undef; + } +} + +sub total_jobs($) { + my $self = shift; + my $table = $self->table(); + my $v = $self->get("SELECT count(*) FROM $table;"); + if($v->[0]) { + return $v->[0]->[0]; + } else { + ::die_bug("SQL::total_jobs"); + } +} + +sub max_seq($) { + my $self = shift; + my $table = $self->table(); + my $v = $self->get("SELECT max(Seq) FROM $table;"); + if($v->[0]) { + return $v->[0]->[0]; + } else { + ::die_bug("SQL::max_seq"); + } +} + +sub finished($) { + # Check if there are any jobs left in the SQL table that do not + # have a "real" exitval + my $self = shift; + if($opt::wait or $Global::start_sqlworker) { + my $table = $self->table(); + my $rv = $self->get("select Seq,Exitval from $table ". + "where Exitval <= -1000 limit 1"); + return not $rv->[0]; + } else { + return 1; + } +} + +package Semaphore; + +# This package provides a counting semaphore +# +# If a process dies without releasing the semaphore the next process +# that needs that entry will clean up dead semaphores +# +# The semaphores are stored in $PARALLEL_HOME/semaphores/id- Each +# file in $PARALLEL_HOME/semaphores/id-/ is the process ID of the +# process holding the entry. If the process dies, the entry can be +# taken by another process. + +sub new($) { + my $class = shift; + my $id = shift; + my $count = shift; + $id =~ s/([^-_a-z0-9])/unpack("H*",$1)/ige; # Convert non-word chars to hex + $id = "id-".$id; # To distinguish it from a process id + my $parallel_locks = $Global::cache_dir . "/semaphores"; + -d $parallel_locks or ::mkdir_or_die($parallel_locks); + my $lockdir = "$parallel_locks/$id"; + my $lockfile = $lockdir.".lock"; + if(-d $parallel_locks and -w $parallel_locks + and -r $parallel_locks and -x $parallel_locks) { + # skip + } else { + ::error(255,"Semaphoredir must be writable: '$parallel_locks'"); + } + + if($count < 1) { ::die_bug("semaphore-count: $count"); } + return bless { + 'lockfile' => $lockfile, + 'lockfh' => Symbol::gensym(), + 'lockdir' => $lockdir, + 'id' => $id, + 'idfile' => $lockdir."/".$id, + 'pid' => $$, + 'pidfile' => $lockdir."/".$$.'@'.::hostname(), + 'count' => $count + 1 # nlinks returns a link for the 'id-' as well + }, ref($class) || $class; +} + +sub remove_dead_locks($) { + my $self = shift; + my $lockdir = $self->{'lockdir'}; + + for my $d (glob "$lockdir/*") { + $d =~ m:$lockdir/([0-9]+)\@([-\._a-z0-9]+)$:o or next; + my ($pid, $host) = ($1, $2); + if($host eq ::hostname()) { + if(kill 0, $pid) { + ::debug("sem", "Alive: $pid $d\n"); + } else { + ::debug("sem", "Dead: $d\n"); + ::rm($d); + } + } + } +} + +sub acquire($) { + my $self = shift; + my $sleep = 1; # 1 ms + my $start_time = time; + while(1) { + # Can we get a lock? + $self->atomic_link_if_count_less_than() and last; + $self->remove_dead_locks(); + # Retry slower and slower up to 1 second + $sleep = ($sleep < 1000) ? ($sleep * 1.1) : ($sleep); + # Random to avoid every sleeping job waking up at the same time + ::usleep(rand()*$sleep); + if($opt::semaphoretimeout) { + if($opt::semaphoretimeout > 0 + and + time - $start_time > $opt::semaphoretimeout) { + # Timeout: Take the semaphore anyway + ::warning("Semaphore timed out. Stealing the semaphore."); + if(not -e $self->{'idfile'}) { + open (my $fh, ">", $self->{'idfile'}) or + ::die_bug("timeout_write_idfile: $self->{'idfile'}"); + close $fh; + } + link $self->{'idfile'}, $self->{'pidfile'}; + last; + } + if($opt::semaphoretimeout < 0 + and + time - $start_time > -$opt::semaphoretimeout) { + # Timeout: Exit + ::warning("Semaphore timed out. Exiting."); + exit(1); + last; + } + } + } + ::debug("sem", "acquired $self->{'pid'}\n"); +} + +sub release($) { + my $self = shift; + ::rm($self->{'pidfile'}); + if($self->nlinks() == 1) { + # This is the last link, so atomic cleanup + $self->lock(); + if($self->nlinks() == 1) { + ::rm($self->{'idfile'}); + rmdir $self->{'lockdir'}; + } + $self->unlock(); + } + ::debug("run", "released $self->{'pid'}\n"); +} + +sub pid_change($) { + # This should do what release()+acquire() would do without having + # to re-acquire the semaphore + my $self = shift; + + my $old_pidfile = $self->{'pidfile'}; + $self->{'pid'} = $$; + $self->{'pidfile'} = $self->{'lockdir'}."/".$$.'@'.::hostname(); + my $retval = link $self->{'idfile'}, $self->{'pidfile'}; + ::debug("sem","link($self->{'idfile'},$self->{'pidfile'})=$retval\n"); + ::rm($old_pidfile); +} + +sub atomic_link_if_count_less_than($) { + # Link $file1 to $file2 if nlinks to $file1 < $count + my $self = shift; + my $retval = 0; + $self->lock(); + my $nlinks = $self->nlinks(); + ::debug("sem","$nlinks<$self->{'count'} "); + if($nlinks < $self->{'count'}) { + -d $self->{'lockdir'} or ::mkdir_or_die($self->{'lockdir'}); + if(not -e $self->{'idfile'}) { + open (my $fh, ">", $self->{'idfile'}) or + ::die_bug("write_idfile: $self->{'idfile'}"); + close $fh; + } + $retval = link $self->{'idfile'}, $self->{'pidfile'}; + ::debug("sem","link($self->{'idfile'},$self->{'pidfile'})=$retval\n"); + } + $self->unlock(); + ::debug("sem", "atomic $retval"); + return $retval; +} + +sub nlinks($) { + my $self = shift; + if(-e $self->{'idfile'}) { + return (stat(_))[3]; + } else { + return 0; + } +} + +sub lock($) { + my $self = shift; + my $sleep = 100; # 100 ms + my $total_sleep = 0; + $Global::use{"Fcntl"} ||= eval "use Fcntl qw(:DEFAULT :flock); 1;"; + my $locked = 0; + while(not $locked) { + if(tell($self->{'lockfh'}) == -1) { + # File not open + open($self->{'lockfh'}, ">", $self->{'lockfile'}) + or ::debug("run", "Cannot open $self->{'lockfile'}"); + } + if($self->{'lockfh'}) { + # File is open + chmod 0666, $self->{'lockfile'}; # assuming you want it a+rw + if(flock($self->{'lockfh'}, LOCK_EX()|LOCK_NB())) { + # The file is locked: No need to retry + $locked = 1; + last; + } else { + if ($! =~ m/Function not implemented/) { + ::warning("flock: $!", + "Will wait for a random while."); + ::usleep(rand(5000)); + # File cannot be locked: No need to retry + $locked = 2; + last; + } + } + } + # Locking failed in first round + # Sleep and try again + $sleep = ($sleep < 1000) ? ($sleep * 1.1) : ($sleep); + # Random to avoid every sleeping job waking up at the same time + ::usleep(rand()*$sleep); + $total_sleep += $sleep; + if($opt::semaphoretimeout) { + if($opt::semaphoretimeout > 0 + and + $total_sleep/1000 > $opt::semaphoretimeout) { + # Timeout: Take the semaphore anyway + ::warning("Semaphore timed out. Taking the semaphore."); + $locked = 3; + last; + } + if($opt::semaphoretimeout < 0 + and + $total_sleep/1000 > -$opt::semaphoretimeout) { + # Timeout: Exit + ::warning("Semaphore timed out. Exiting."); + $locked = 4; + last; + } + } else { + if($total_sleep/1000 > 30) { + ::warning("Semaphore stuck for 30 seconds. ". + "Consider using --semaphoretimeout."); + } + } + } + ::debug("run", "locked $self->{'lockfile'}"); +} + +sub unlock($) { + my $self = shift; + ::rm($self->{'lockfile'}); + close $self->{'lockfh'}; + ::debug("run", "unlocked\n"); +} + +# Keep perl -w happy + +$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() { + unpack_combined_executable(); + save_stdin_stdout_stderr(); + save_original_signal_handler(); + parse_options(); + ::debug("init", "Open file descriptors: ", join(" ",keys %Global::fh), "\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::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::sqlmaster and $opt::sqlworker) { + # Start a real --sqlworker in the background later + $Global::start_sqlworker = 1; + $opt::sqlworker = undef; + } + + $Global::start_time = ::now(); + 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, + \@Global::template_names, \@Global::template_contents + ); + + if($opt::sqlmaster) { + # Create SQL table to hold joblog + output + # Figure out how many arguments are in a job + # (It is affected by --colsep, -N, $number_source_fh) + my $record_queue = $Global::JobQueue->{'commandlinequeue'}{'arg_queue'}; + my $record = $record_queue->get(); + my $no_of_values = $number_of_args * (1+$#{$record}); + $record_queue->unget($record); + $Global::sql->create_table($no_of_values); + if($opt::sqlworker) { + # Start a real --sqlworker in the background later + $Global::start_sqlworker = 1; + $opt::sqlworker = undef; + } + } + + if($opt::pipepart) { + pipepart_setup(); + } elsif($opt::pipe) { + if($opt::tee) { + pipe_tee_setup(); + } elsif($opt::shard or $opt::bin) { + pipe_shard_setup(); + } elsif($opt::groupby) { + pipe_group_by_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::progress) { + ::status_no_nl(init_progress()); + } + if($opt::tee or $opt::shard or $opt::bin) { + # All jobs must be running in parallel for --tee/--shard/--bin + while(start_more_jobs()) {} + $Global::start_no_new_jobs = 1; + if(not $Global::JobQueue->empty()) { + if($opt::tee) { + ::error(255,"--tee requires --jobs to be higher. ". + "Try --jobs 0."); + } elsif($opt::bin) { + ::error(255,"--bin requires --jobs to be higher than ". + "the number of", "arguments. Increase --jobs."); + } elsif($opt::shard) { + ::error(255,"--shard requires --jobs to be higher ". + "than the number of", + "arguments. Increase --jobs."); + } else { + ::die_bug("--bin/--shard/--tee should not get here"); + } + } + } elsif($opt::pipe and not $opt::pipepart and not $opt::semaphore) { + # Fill all jobslots + while(start_more_jobs()) {} + spreadstdin(); + } else { + # Reap the finished jobs and start more + while(reapers() + 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(); -- cgit v1.2.3