#!/usr/bin/env perl

# Copyright (C) 2007,2008,2009,2010,2011,2012,2013,2014,2015,2016

# Ole Tange and Free Software Foundation, Inc.

#

# This program is free software; you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# 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 <http://www.gnu.org/licenses/>

# or write to the Free Software Foundation, Inc., 51 Franklin St,

# Fifth Floor, Boston, MA 02110-1301 USA

# open3 used in Job::start

use IPC::Open3;

# &WNOHANG used in reaper

use POSIX qw(:sys_wait_h setsid ceil :errno_h);

# 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;

save_stdin_stdout_stderr();

save_original_signal_handler();

parse_options();

::debug("init", "Open file descriptors: ", join(" ",keys %Global::fd), "\n");

my $number_of_args;

if($Global::max_number_of_args) {

$number_of_args = $Global::max_number_of_args;

} elsif ($opt::X or $opt::m or $opt::xargs) {

$number_of_args = undef;

} else {

$number_of_args = 1;

}

my @command = @ARGV;

my @input_source_fh;

if($opt::pipepart) {

# -a is used for data - not for command line args

@input_source_fh = map { open_or_exit($_) } "/dev/null";

} else {

@input_source_fh = map { open_or_exit($_) } @opt::a;

if(not @input_source_fh and not $opt::pipe) {

@input_source_fh = (*STDIN);

}

}

if($opt::sqlmaster) {

# Create SQL table to hold joblog + output

$Global::sql->create_table($#input_source_fh+1);

if($opt::sqlworker) {

# Start a real --sqlworker in the background later

$Global::start_sqlworker = 1;

$opt::sqlworker = undef;

}

}

if($opt::skip_first_line) {

# Skip the first line for the first file handle

my $fh = $input_source_fh[0];

<$fh>;

}

set_input_source_header();

sub set_input_source_header {

if($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;

my $id = 1;

for my $fh (@input_source_fh) {

my $line = <$fh>;

chomp($line);

::debug("init", "Delimiter: '$delimiter'");

for my $s (split /$delimiter/o, $line) {

::debug("init", "Colname: '$s'");

# Replace {colname} with {2}

for(@command,@Global::ret_files,@Global::transfer_files) {

s:\{$s(|/|//|\.|/\.)\}:\{$id$1\}:g;

# {=header1 ... =} => {=1 ... =}

s:$left $s (.*?) $right:$l$id$1$r:gx;

}

$Global::input_source_header{$id} = $s;

$id++;

}

}

} else {

my $id = 1;

for my $fh (@input_source_fh) {

$Global::input_source_header{$id} = $id;

$id++;

}

}

}

if($opt::filter_hosts and (@opt::sshlogin or @opt::sshloginfile)) {

# Parallel check all hosts are up. Remove hosts that are down

filter_hosts();

}

if($opt::nonall or $opt::onall) {

onall(\@input_source_fh,@command);

wait_and_exit(min(undef_as_zero($Global::exitstatus),254));

}

# TODO --transfer foo/./bar --cleanup

# multiple --transfer and --basefile with different /./

$Global::JobQueue = JobQueue->new(

\@command,\@input_source_fh,$Global::ContextReplace,

$number_of_args,\@Global::transfer_files,\@Global::ret_files);

if($opt::pipepart) {

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($_);

} else {

::error("$_ is neither a file nor a block device");

wait_and_exit(255);

}

}

# Compute $Global::max_jobs_running

$Global::dummy_jobs = 1;

for my $sshlogin (values %Global::host) {

$sshlogin->max_jobs_running();

}

$Global::max_jobs_running or

::die_bug("Global::max_jobs_running not set");

# Run in total $job_slots*(- $blocksize) jobs

# Set --blocksize = size / no of proc / 10

$Global::blocksize = 1 +

int($size / $Global::max_jobs_running / -$opt::blocksize);

}

@Global::cat_partials = map { pipe_part_files($_) } @opt::a;

# Unget the empty arg as many times as there are parts

$Global::JobQueue->{'commandlinequeue'}{'arg_queue'}->unget(

map { [Arg->new("\0")] } @Global::cat_partials

);

}

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.

for my $sshlogin (values %Global::host) {

$sshlogin->max_jobs_running();

}

init_run_jobs();

my $sem;

if($Global::semaphore) {

$sem = acquire_semaphore();

}

$SIG{TERM} = \&start_no_new_jobs;

start_more_jobs();

if($opt::pipe and not $opt::pipepart) {

spreadstdin();

}

::debug("init", "Start draining\n");

drain_job_queue();

::debug("init", "Done draining\n");

reaper();

::debug("init", "Done reaping\n");

if($opt::pipe and @opt::a) {

for my $job (@Global::tee_jobs) {

::rm($job->fh(2,"name"));

$job->set_fh(2,"name","");

$job->print();

::rm($job->fh(1,"name"));

}

}

::debug("init", "Cleaning\n");

if($Global::semaphore) {

$sem->release();

}

cleanup();

::debug("init", "Halt\n");

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 * 100);

} elsif($Global::halt_count) {

$Global::halt_exitstatus =

::min(undef_as_zero($Global::total_failed),101);

}

}

wait_and_exit($Global::halt_exitstatus);

} else {

wait_and_exit(min(undef_as_zero($Global::exitstatus),101));

}

sub __PIPE_MODE__ {}

sub pipe_part_files {

# 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("$file is not a seekable file.");

::wait_and_exit(255);

}

my $header = find_header(\$buf,open_or_exit($file));

# find positions

my @pos = find_split_positions($file,$Global::blocksize,length $header);

# Make @cat_partials

my @cat_partials = ();

for(my $i=0; $i<$#pos; $i++) {

push @cat_partials, cat_partial($file, 0, length($header), $pos[$i], $pos[$i+1]);

}

return @cat_partials;

}

sub find_header {

# Input:

# $buf_ref = reference to read-in buffer

# $fh = filehandle to read from

# Uses:

# $opt::header

# $Global::blocksize

# Returns:

# $header string

my ($buf_ref, $fh) = @_;

my $header = "";

if($opt::header) {

if($opt::header eq ":") { $opt::header = "(.*\n)"; }

# Number = number of lines

$opt::header =~ s/^(\d+)$/"(.*\n)"x$1/e;

while(read($fh,substr($$buf_ref,length $$buf_ref,0),$Global::blocksize)) {

if($$buf_ref=~s/^($opt::header)//) {

$header = $1;

last;

}

}

}

return $header;

}

sub find_split_positions {

# Input:

# $file = the file to read

# $block = (minimal) --block-size of each chunk

# $headerlen = length of header to be skipped

# Uses:

# $opt::recstart

# $opt::recend

# Returns:

# @positions of block start/end

my($file, $block, $headerlen) = @_;

my $size = -s $file;

if(-b $file) {

# $file is a blockdevice

$size = size_of_block_dev($file);

}

$block = int $block;

# The optimal dd blocksize for mint, redhat, solaris, openbsd = 2^17..2^20

# The optimal dd blocksize for freebsd = 2^15..2^17

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,$headerlen);

for(my $pos = $block+$headerlen; $pos < $size; $pos += $block) {

my $buf;

if($recendrecstart eq "") {

push(@pos,$pos);

} else {

seek($fh, $pos, 0) || die;

while(read($fh,substr($buf,length $buf,0),$dd_block_size)) {

if($opt::regexp) {

# If match /$recend$recstart/ => Record position

if($buf =~ /^(.*$recend)$recstart/os) {

# Start looking for next record _after_ this match

$pos += length($1);

push(@pos,$pos);

last;

}

} else {

# If match $recend$recstart => Record position

my $i = index64(\$buf,$recendrecstart);

if($i != -1) {

# Start looking for next record _after_ this match

$pos += $i + length($recendrecstart);

push(@pos,$pos);

last;

}

}

}

}

}

push(@pos,$size);

close $fh;

return @pos;

}

sub cat_partial {

# Input:

# $file = the file to read

# ($start, $end, [$start2, $end2, ...]) = start byte, end byte

# Returns:

# Efficient perl 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;

return "<". shell_quote_scalar($file) .

q{ perl -e 'while(@ARGV) { sysseek(STDIN,shift,0) || die; $left = shift; while($read = sysread(STDIN,$buf, ($left > 131072 ? 131072 : $left))){ $left -= $read; syswrite(STDOUT,$buf); } }' } .

" @start_len";

}

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 = $Global::blocksize;

my $in = *STDIN;

my $header = find_header(\$buf,$in);

while(1) {

my $anything_written = 0;

my $buflen = length $buf;

my $readsize = ($buflen < $blocksize) ? $blocksize-$buflen : $blocksize;

# If $buf < $blocksize, append so it is $blocksize long after reading.

# Otherwise append a full $blocksize

if(not read($in,substr($buf,$buflen,0),$readsize)) {

# End-of-file

$chunk_number != 1 and last;

# Force the while-loop once if everything was read by header reading

$one_time_through++ and last;

}

if($opt::r) {

# Remove empty lines

$buf =~ s/^\s*\n//gm;

if(length $buf == 0) {

next;

}

}

if($Global::max_lines and not $Global::max_number_of_args) {

# Read n-line records

my $n_lines = $buf =~ tr/\n/\n/;

my $last_newline_pos = rindex64(\$buf,"\n");

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);

} elsif($opt::regexp) {

if($Global::max_number_of_args) {

# -N => (start..*?end){n}

# -L -N => (start..*?end){n*l}

my $read_n_lines = $Global::max_number_of_args * ($Global::max_lines || 1);

while($buf =~ s/((?:$recstart.*?$recend){$read_n_lines})($recstart.*)$/$2/os) {

# Copy to modifiable variable

my $b = $1;

$anything_written +=

write_record_to_pipe($chunk_number++,\$header,\$b,

$recstart,$recend,length $1);

}

} else {

eof($in) and last;

# Find the last recend-recstart in $buf

if($buf =~ s/(.*$recend)($recstart.*?)$/$2/os) {

# Copy to modifiable variable

my $b = $1;

$anything_written +=

write_record_to_pipe($chunk_number++,\$header,\$b,

$recstart,$recend,length $1);

}

}

} else {

if($Global::max_number_of_args) {

# -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) {

$i += length $recend; # find the actual splitting location

$anything_written +=

write_record_to_pipe($chunk_number++,\$header,\$buf,

$recstart,$recend,$i);

shorten(\$buf,$i);

}

} else {

eof($in) and last;

# Find the last recend+recstart in $buf

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);

}

}

}

if(not $anything_written

and not eof($in)

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.");

}

}

}

::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);

}

}

$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) {

# If $recstart/$recend contains '|' this 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 block

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;

$job->set_virgin(0);

$written += $job->non_blocking_write();

last;

}

}

if($written) {

$sleep = $sleep/1.5+0.001;

}

} 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 $block_size = 2**31-1;

my $strlen = length($$ref);

# No point in doing extra work if we don't need to.

if($strlen < $block_size 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, $block_size),

$match, $pos-$offset);

if($ret != -1) {

return $ret + $offset;

}

$offset += ($block_size - $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) {

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) {

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 is no longer virgin

$job->set_virgin(0);

if($opt::retries) {

# Copy $buffer[0..$endpos] to $job->{'block'}

# Remove rec_sep

# Run $job->add_transfersize

$job->set_block($header_ref,$buffer_ref,$endpos,$recstart,$recend);

if(fork()) {

# Skip

} else {

$job->write($job->block_ref());

close $job->fh(0,"w");

exit(0);

}

} else {

# We ignore the removed rec_sep which is technically wrong.

$job->add_transfersize($endpos + length $$header_ref);

if(fork()) {

# Skip

} else {

# Chop of at $endpos as we do not know how many rec_sep will

# be removed.

substr($$buffer_ref,$endpos,length $$buffer_ref) = "";

# Remove rec_sep

if($opt::remove_rec_sep) {

Job::remove_rec_sep($buffer_ref,$recstart,$recend);

}

$job->write($header_ref);

$job->write($buffer_ref);

close $job->fh(0,"w");

exit(0);

}

}

close $job->fh(0,"w");

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 options_hash {

# Returns:

# %hash = the GetOptions config

return

("debug|D=s" => \$opt::D,

"xargs" => \$opt::xargs,

"m" => \$opt::m,

"X" => \$opt::X,

"v" => \@opt::v,

"sql=s" => \$opt::retired,

"sqlmaster=s" => \$opt::sqlmaster,

"sqlworker=s" => \$opt::sqlworker,

"sqlandworker=s" => \$opt::sqlandworker,

"joblog|jl=s" => \$opt::joblog,

"results|result|res=s" => \$opt::results,

"resume" => \$opt::resume,

"resume-failed|resumefailed" => \$opt::resume_failed,

"retry-failed|retryfailed" => \$opt::retry_failed,

"silent" => \$opt::silent,

"keep-order|keeporder|k" => \$opt::keeporder,

"no-keep-order|nokeeporder|nok|no-k" => \$opt::nokeeporder,

"group" => \$opt::group,

"g" => \$opt::retired,

"ungroup|u" => \$opt::ungroup,

"linebuffer|linebuffered|line-buffer|line-buffered|lb" => \$opt::linebuffer,

"tmux" => \$opt::tmux,

"tmuxpane" => \$opt::tmuxpane,

"null|0" => \$opt::0,

"quote|q" => \$opt::q,

# Replacement strings

"parens=s" => \$opt::parens,

"rpl=s" => \@opt::rpl,

"plus" => \$opt::plus,

"I=s" => \$opt::I,

"extensionreplace|er=s" => \$opt::U,

"U=s" => \$opt::retired,

"basenamereplace|bnr=s" => \$opt::basenamereplace,

"dirnamereplace|dnr=s" => \$opt::dirnamereplace,

"basenameextensionreplace|bner=s" => \$opt::basenameextensionreplace,

"seqreplace=s" => \$opt::seqreplace,

"slotreplace=s" => \$opt::slotreplace,

"jobs|j=s" => \$opt::jobs,

"delay=f" => \$opt::delay,

"sshdelay=f" => \$opt::sshdelay,

"load=s" => \$opt::load,

"noswap" => \$opt::noswap,

"max-line-length-allowed" => \$opt::max_line_length_allowed,

"number-of-cpus" => \$opt::number_of_cpus,

"number-of-cores" => \$opt::number_of_cores,

"use-cpus-instead-of-cores" => \$opt::use_cpus_instead_of_cores,

"shellquote|shell_quote|shell-quote" => \$opt::shellquote,

"nice=i" => \$opt::nice,

"tag" => \$opt::tag,

"tagstring|tag-string=s" => \$opt::tagstring,

"onall" => \$opt::onall,

"nonall" => \$opt::nonall,

"filter-hosts|filterhosts|filter-host" => \$opt::filter_hosts,

"sshlogin|S=s" => \@opt::sshlogin,

"sshloginfile|slf=s" => \@opt::sshloginfile,

"controlmaster|M" => \$opt::controlmaster,

"ssh=s" => \$opt::ssh,

"transfer-file|transferfile|transfer-files|transferfiles|tf=s"

=> \@opt::transfer_files,

"return=s" => \@opt::return,

"trc=s" => \@opt::trc,

"transfer" => \$opt::transfer,

"cleanup" => \$opt::cleanup,

"basefile|bf=s" => \@opt::basefile,

"B=s" => \$opt::retired,

"ctrlc|ctrl-c" => \$opt::retired,

"noctrlc|no-ctrlc|no-ctrl-c" => \$opt::retired,

"workdir|work-dir|wd=s" => \$opt::workdir,

"W=s" => \$opt::retired,

"tmpdir=s" => \$opt::tmpdir,

"tempdir=s" => \$opt::tmpdir,

"use-compress-program|compress-program=s" => \$opt::compress_program,

"use-decompress-program|decompress-program=s" => \$opt::decompress_program,

"compress" => \$opt::compress,

"tty" => \$opt::tty,

"T" => \$opt::retired,

"H=i" => \$opt::retired,

"dry-run|dryrun" => \$opt::dryrun,

"progress" => \$opt::progress,

"eta" => \$opt::eta,

"bar" => \$opt::bar,

"shuf" => \$opt::shuf,

"arg-sep|argsep=s" => \$opt::arg_sep,

"arg-file-sep|argfilesep=s" => \$opt::arg_file_sep,

"trim=s" => \$opt::trim,

"env=s" => \@opt::env,

"recordenv|record-env" => \$opt::record_env,

"plain" => \$opt::plain,

"profile|J=s" => \@opt::profile,

"pipe|spreadstdin" => \$opt::pipe,

"robin|round-robin|roundrobin" => \$opt::roundrobin,

"recstart=s" => \$opt::recstart,

"recend=s" => \$opt::recend,

"regexp|regex" => \$opt::regexp,

"remove-rec-sep|removerecsep|rrs" => \$opt::remove_rec_sep,

"files|output-as-files|outputasfiles" => \$opt::files,

"block|block-size|blocksize=s" => \$opt::blocksize,

"tollef" => \$opt::tollef,

"gnu" => \$opt::gnu,

"link|xapply" => \$opt::link,

"linkinputsource|xapplyinputsource=i" => \@opt::linkinputsource,

"wc|willcite|will-cite|nn|nonotice|no-notice" => \$opt::willcite,

# Termination and retries

"halt-on-error|halt=s" => \$opt::halt,

"memfree=s" => \$opt::memfree,

"retries=i" => \$opt::retries,

"timeout=s" => \$opt::timeout,

"termseq|term-seq=s" => \$opt::termseq,

# xargs-compatibility - implemented, man, testsuite

"max-procs|P=s" => \$opt::jobs,

"delimiter|d=s" => \$opt::d,

"max-chars|s=i" => \$opt::max_chars,

"arg-file|a=s" => \@opt::a,

"no-run-if-empty|r" => \$opt::r,

"replace|i:s" => \$opt::i,

"E=s" => \$opt::eof,

"eof|e:s" => \$opt::eof,

"max-args|n=i" => \$opt::max_args,

"max-replace-args|N=i" => \$opt::max_replace_args,

"colsep|col-sep|C=s" => \$opt::colsep,

"help|h" => \$opt::help,

"L=f" => \$opt::L,

"max-lines|l:f" => \$opt::max_lines,

"interactive|p" => \$opt::interactive,

"verbose|t" => \$opt::verbose,

"version|V" => \$opt::version,

"minversion|min-version=i" => \$opt::minversion,

"show-limits|showlimits" => \$opt::show_limits,

"exit|x" => \$opt::x,

# Semaphore

"semaphore" => \$opt::semaphore,

"semaphoretimeout|st=i" => \$opt::semaphoretimeout,

"semaphorename|id=s" => \$opt::semaphorename,

"fg" => \$opt::fg,

"bg" => \$opt::bg,

"wait" => \$opt::wait,

# Shebang #!/usr/bin/parallel --shebang

"shebang|hashbang" => \$opt::shebang,

"internal-pipe-means-argfiles" => \$opt::internal_pipe_means_argfiles,

"Y" => \$opt::retired,

"skip-first-line" => \$opt::skip_first_line,

"header=s" => \$opt::header,

"cat" => \$opt::cat,

"fifo" => \$opt::fifo,

"pipepart|pipe-part" => \$opt::pipepart,

"hgrp|hostgrp|hostgroup|hostgroups" => \$opt::hostgroups,

);

}

sub get_options_from_array {

# Run GetOptions on @array

# Input:

# $array_ref = ref to @ARGV to parse

# @keep_only = Keep only these options

# 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_options {

# Returns: N/A