From 5adcd33f7be5c161c7e043ca768b1f111f95c48c Mon Sep 17 00:00:00 2001 From: Ole Tange Date: Wed, 4 Aug 2021 21:05:40 +0200 Subject: [PATCH] parallel: --ctag(string) implemented. --- doc/release_new_version | 2 +- src/parallel | 119 +++++++++++++----- src/parallel.pod | 18 ++- testsuite/tests-to-run/parallel-local-0.3s.sh | 8 ++ testsuite/wanted-results/parallel-local-0.3s | 5 + 5 files changed, 118 insertions(+), 34 deletions(-) diff --git a/doc/release_new_version b/doc/release_new_version index 01108adf..cc6f3511 100644 --- a/doc/release_new_version +++ b/doc/release_new_version @@ -255,7 +255,7 @@ from:tange@gnu.org to:parallel@gnu.org, bug-parallel@gnu.org stable-bcc: Jesse Alama -Subject: GNU Parallel 20210822 ('turkish fire/greek fire/tysk syndflod/Tunesia') released <<[stable]>> +Subject: GNU Parallel 20210822 ('South Africa/Kristina Timanovskaya/turkish fire/greek fire/tysk syndflod/Tunesia') released <<[stable]>> GNU Parallel 20210822 ('') <<[stable]>> has been released. It is available for download at: lbry://@GnuParallel:4 diff --git a/src/parallel b/src/parallel index 966cb5ec..e89488cb 100755 --- a/src/parallel +++ b/src/parallel @@ -1555,6 +1555,8 @@ sub options_hash() { "nice=i" => \$opt::nice, "tag" => \$opt::tag, "tagstring|tag-string=s" => \$opt::tagstring, + "ctag" => \$opt::ctag, + "ctagstring|ctag-string=s" => \$opt::ctagstring, "onall" => \$opt::onall, "nonall" => \$opt::nonall, "filter-hosts|filterhosts|filter-host" => \$opt::filter_hosts, @@ -1785,6 +1787,15 @@ sub parse_options(@) { if(defined $opt::null) { $/ = "\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) { + $Global::color = 1; + } + 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.*\Q$Global::parensright\E/ @@ -2027,10 +2038,6 @@ sub parse_options(@) { not ($opt::xargs or $opt::m)) { $Global::ContextReplace = 1; } - if(defined $opt::tag and not defined $opt::tagstring) { - # Default = {} - $opt::tagstring = $Global::parensleft.$Global::parensright; - } if(grep /^$Global::arg_sep\+?$|^$Global::arg_file_sep\+?$/o, @ARGV) { # Deal with ::: :::+ :::: and ::::+ @ARGV = read_args_from_command_line(); @@ -5840,13 +5847,15 @@ sub which(@) { if($shellpath = readlink "/proc/$testpid/exe") { ::debug("init","procpath $shellpath\n"); if($shellpath =~ m:/$shell$:o) { - ::debug("init", "proc which ".$shellpath." => "); + ::debug("init", + "proc which ".$shellpath." => "); return $shellpath; } } } ::debug("init", "which ".$shellname." => "); - $shellpath = (which($shellname,@{$fakename{$shellname}}))[0]; + $shellpath = (which($shellname, + @{$fakename{$shellname}}))[0]; ::debug("init", "shell path $shellpath\n"); return $shellpath; } @@ -5907,11 +5916,13 @@ sub which(@) { if(not %pid_parentpid_cmd) { # Filter for SysV-style `ps` - my $sysv = q( ps -ef | perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;). + 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 | perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;). + 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); @@ -5939,7 +5950,8 @@ sub which(@) { 'syllable' => "echo ps not supported", ); } - $pid_parentpid_cmd{$^O} or ::die_bug("pid_parentpid_cmd for $^O missing"); + $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 @@ -6111,7 +6123,8 @@ sub kill_youngest_if_over_limit() { push @{$jobs_of{$job->sshlogin()}}, $job; } for my $sshlogin (@sshlogins) { - for my $job (sort { $b->seq() <=> $a->seq() } @{$jobs_of{$sshlogin}}) { + for my $job (sort { $b->seq() <=> $a->seq() } + @{$jobs_of{$sshlogin}}) { if($sshlogin->limit() == 2) { $job->kill(); last; @@ -6141,7 +6154,8 @@ sub suspend_young_if_not_enough_mem() { 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}}; + my @jobs = (sort { $b->seq() <=> $a->seq() } + @{$jobs_of{$sshlogin}}); # how many should be running? # limit*1 => 1; # limit*1.5 => 2; @@ -6162,8 +6176,8 @@ sub suspend_young_if_not_enough_mem() { for my $job (@{$jobs_of{$sshlogin}}) { if($job->suspended()) { $job->resume(); - ::debug("mem","\nResume ",$#{$jobs_of{$sshlogin}}+1, " jobs. Seq ", - $job->seq(), " resumed ", + ::debug("mem","\nResume ",$#{$jobs_of{$sshlogin}}+1, + " jobs. Seq ", $job->seq(), " resumed ", $sshlogin->memfree()," > ",2*$limit); last; } @@ -6189,7 +6203,8 @@ sub kill_youngster_if_not_enough_mem() { push @{$jobs_of{$job->sshlogin()}}, $job; } for my $sshlogin (@sshlogins) { - for my $job (sort { $b->seq() <=> $a->seq() } @{$jobs_of{$sshlogin}}) { + 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() } @@ -10162,8 +10177,10 @@ sub interactive_start($) { ::status("See output with: $ENV{'PARALLEL_TMUX'} -S $tmuxsocket attach"); } $tmux = "sh -c '". - $ENV{'PARALLEL_TMUX'}." -S $tmuxsocket new-session -s p$$ -d \"sleep .2\" >/dev/null 2>&1';" . - $ENV{'PARALLEL_TMUX'}." -S $tmuxsocket new-window -t p$$ -n $title"; + $ENV{'PARALLEL_TMUX'}. + " -S $tmuxsocket new-session -s p$$ -d \"sleep .2\" >/dev/null 2>&1';" . + $ENV{'PARALLEL_TMUX'}. + " -S $tmuxsocket new-window -t p$$ -n $title"; ::debug("tmux", "title len:", $l_tit, " act ", $l_act, " max ", $Limits::Command::line_max_len, " tot ", @@ -10175,7 +10192,8 @@ sub interactive_start($) { ( "(".$actual_command.');'. # The triple print is needed - otherwise the testsuite fails - q[ perl -e 'while($t++<3){ print $ARGV[0],"\n" }' $?h/$status >> ].$tmpfifo."&". + q[ perl -e 'while($t++<3){ print $ARGV[0],"\n" }' $?h/$status >> ]. + $tmpfifo."&". "echo $title; echo \007Job finished at: `date`;sleep 10" ). # Run outside tmux @@ -10361,7 +10379,8 @@ sub print($) { sub jsonquote($) { my $a = shift; if(not $jsonmap{"\001"}) { - map { $jsonmap{sprintf("%c",$_)} = sprintf '\u%04x', $_ } 0..31; + map { $jsonmap{sprintf("%c",$_)} = + sprintf '\u%04x', $_ } 0..31; } $a =~ s/\\/\\\\/g; $a =~ s/\"/\\"/g; @@ -10609,15 +10628,19 @@ sub print_linebuffer($) { 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])(?=.|$)/$tag/gs; + substr($buf,0,$i-1) =~ + s/(?<=[\n\r])(?=.|$)/$tag/gs; # The length changed, so find the new ending pos - $i = ::max((rindex($buf,"\n")+1), (rindex($buf,"\r")+1)); + $i = ::max((rindex($buf,"\n")+1), + (rindex($buf,"\r")+1)); } else { # Replace with freshly computed value of tag unshift @$halfline_ref, $self->tag(); - substr($buf,0,$i-1) =~ s/(?<=[\n\r])(?=.|$)/$self->tag()/gse; + substr($buf,0,$i-1) =~ + s/(?<=[\n\r])(?=.|$)/$self->tag()/gse; # The length changed, so find the new ending pos - $i = ::max((rindex($buf,"\n")+1), (rindex($buf,"\r")+1)); + $i = ::max((rindex($buf,"\n")+1), + (rindex($buf,"\r")+1)); } } # Print the partial line (halfline) and the last half @@ -10862,17 +10885,51 @@ sub print_joblog($) { $self->set_job_in_joblog(); } -sub tag($) { - my $self = shift; - if(not defined $self->{'tag'} or not $Global::cache_replacement_eval) { - if($opt::tag or defined $opt::tagstring) { - $self->{'tag'} = $self->{'commandline'}-> - replace_placeholders([$opt::tagstring],0,0)."\t"; - } else { - $self->{'tag'} = ""; +{ + my @color; + + sub tag($) { + sub init_color() { + # color combinations that are readable: black/white text + # on colored background, but not white on yellow + @color = + # 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..231,249..254), + (map { [sprintf("%03d",$_),231] } + 1..9,12..13,16..45,52..81,88..116,124..151,153, + 160..180,182..185,187..189,196..214,232..252, + 255..254)); + # reorder list so adjacent colors are dissimilar + # %7 and %17 were found experimentally + @color = @color[ + sort { ($b%7 <=> $a%7) or ($a%17 <=> $b%17) } 0..$#color + ]; } + my $self = shift; + if(not defined $self->{'tag'} or not $Global::cache_replacement_eval) { + if($opt::tag or defined $opt::tagstring) { + if($Global::color) { + if(not @color) { init_color() } + # Choose a value based on the seq + my $col = @color[$self->seq() % ($#color+1)]; + $self->{'tag'} = "\033[48;5;".$col->[0]. + ";38;5;".$col->[1]."m". + ($self->{'commandline'}-> + replace_placeholders([$opt::tagstring],0,0)). + "\033[00m\t"; + } else { + $self->{'tag'} = $self->{'commandline'}-> + replace_placeholders([$opt::tagstring],0,0)."\t"; + } + } else { + $self->{'tag'} = ""; + } + } + return $self->{'tag'}; } - return $self->{'tag'}; } sub hostgroups($) { diff --git a/src/parallel.pod b/src/parallel.pod index bb5247e7..bfe2acb9 100644 --- a/src/parallel.pod +++ b/src/parallel.pod @@ -740,6 +740,16 @@ Even quoted newlines are parsed correctly: When used with B<--pipe> only pass full CSV-records. +=item B<--ctag> I (alpha testing) + +Color tag. See B<--tag>. + + +=item B<--ctagstring> I (alpha testing) + +Color tagstring. See B<--tagstring>. + + =item B<--delay> I Delay starting next job by I. GNU B will pause @@ -2695,7 +2705,7 @@ to GNU B giving each child its own process group, which is then killed. Process groups are dependant on the tty. -=item B<--tag> +=item B<--tag> (alpha testing) Tag lines with arguments. Each output line will be prepended with the arguments and TAB (\t). When combined with B<--onall> or B<--nonall> @@ -2703,8 +2713,10 @@ the lines will be prepended with the sshlogin instead. B<--tag> is ignored when using B<-u>. +B<--ctag> gives the tag a color. -=item B<--tagstring> I + +=item B<--tagstring> I (alpha testing) Tag lines with a string. Each output line will be prepended with I and TAB (\t). I can contain replacement strings such as @@ -2712,6 +2724,8 @@ B<{}>. B<--tagstring> is ignored when using B<-u>, B<--onall>, and B<--nonall>. +B<--ctagstring> gives the tag a color. + =item B<--tee> diff --git a/testsuite/tests-to-run/parallel-local-0.3s.sh b/testsuite/tests-to-run/parallel-local-0.3s.sh index c138eaf9..a4b24478 100644 --- a/testsuite/tests-to-run/parallel-local-0.3s.sh +++ b/testsuite/tests-to-run/parallel-local-0.3s.sh @@ -16,6 +16,14 @@ export -f stdsort # Test amount of parallelization # parallel --shuf --jl /tmp/myjl -j1 'export JOBS={1};'bash tests-to-run/parallel-local-0.3s.sh ::: {1..16} ::: {1..5} +par_ctagstring() { + echo '### --ctag --ctagstring should be different from --tag --tagstring' + parallel --tag echo ::: 1 ::: a| wc -c + parallel --ctag echo ::: 1 ::: a | wc -c + parallel --tagstring 'I{1}\tB{2}' echo ::: 1 ::: a | wc -c + parallel --ctagstring 'I{1}\tB{2}' echo ::: 1 ::: a | wc -c +} + par_pct() { echo '### Test {%...} {%%...} {#...} {##...}' a=z.z.z.foo diff --git a/testsuite/wanted-results/parallel-local-0.3s b/testsuite/wanted-results/parallel-local-0.3s index 6b03892e..d8ea49bf 100644 --- a/testsuite/wanted-results/parallel-local-0.3s +++ b/testsuite/wanted-results/parallel-local-0.3s @@ -108,6 +108,11 @@ par_csv_pipe 11000" par_csv_pipe More records in single block par_csv_pipe 9000" par_csv_pipe 11000" +par_ctagstring ### --ctag --ctagstring should be different from --tag --tagstring +par_ctagstring 8 +par_ctagstring 33 +par_ctagstring 10 +par_ctagstring 35 par_delimiter ### Test --delimiter and -d: Delimiter instead of newline par_delimiter # Yes there is supposed to be an extra newline for -d N par_delimiter This is line 1