mirror of
https://git.savannah.gnu.org/git/parallel.git
synced 2024-10-18 04:49:40 +00:00
460 lines
12 KiB
Perl
Executable file
460 lines
12 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
# SPDX-FileCopyrightText: 2021-2023 Ole Tange, http://ole.tange.dk and Free Software and Foundation, Inc.
|
|
# SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
parsort - Sort (big files) in parallel
|
|
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
B<parsort> I<options for sort>
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
B<parsort> uses GNU B<sort> to sort in parallel. It works just like
|
|
B<sort> but faster on inputs with more than 1 M lines, if you have a
|
|
multicore machine.
|
|
|
|
Hopefully these ideas will make it into GNU B<sort> in the future.
|
|
|
|
|
|
=head1 OPTIONS
|
|
|
|
Same as B<sort>. Except:
|
|
|
|
=over 4
|
|
|
|
=item B<--parallel=>I<N>
|
|
|
|
Change the number of sorts run concurrently to I<N>. I<N> will be
|
|
increased to number of files if B<parsort> is given more than I<N>
|
|
files.
|
|
|
|
=back
|
|
|
|
|
|
=head1 EXAMPLE
|
|
|
|
Sort files:
|
|
|
|
parsort *.txt > sorted.txt
|
|
|
|
Sort stdin (standard input) numerically:
|
|
|
|
cat numbers | parsort -n > sorted.txt
|
|
|
|
|
|
=head1 PERFORMANCE
|
|
|
|
B<parsort> is faster on files than on stdin (standard input), because
|
|
different parts of a file can be read in parallel.
|
|
|
|
On a 48 core machine you should see a speedup of 3x over B<sort>.
|
|
|
|
|
|
=head1 AUTHOR
|
|
|
|
Copyright (C) 2020-2023 Ole Tange,
|
|
http://ole.tange.dk and Free Software Foundation, Inc.
|
|
|
|
|
|
=head1 LICENSE
|
|
|
|
Copyright (C) 2012 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/>.
|
|
|
|
|
|
=head1 DEPENDENCIES
|
|
|
|
B<parsort> uses B<sort>, B<bash>, and B<parallel>.
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
B<sort>
|
|
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use Getopt::Long;
|
|
use POSIX qw(mkfifo);
|
|
|
|
Getopt::Long::Configure("bundling","require_order");
|
|
|
|
my @ARGV_before = @ARGV;
|
|
|
|
GetOptions(
|
|
"debug|D" => \$opt::D,
|
|
"version" => \$opt::version,
|
|
"verbose|v" => \$opt::verbose,
|
|
"b|ignore-leading-blanks" => \$opt::ignore_leading_blanks,
|
|
"d|dictionary-order" => \$opt::dictionary_order,
|
|
"f|ignore-case" => \$opt::ignore_case,
|
|
"g|general-numeric-sort" => \$opt::general_numeric_sort,
|
|
"i|ignore-nonprinting" => \$opt::ignore_nonprinting,
|
|
"M|month-sort" => \$opt::month_sort,
|
|
"h|human-numeric-sort" => \$opt::human_numeric_sort,
|
|
"n|numeric-sort" => \$opt::numeric_sort,
|
|
"N|numascii" => \$opt::numascii,
|
|
"r|reverse" => \$opt::reverse,
|
|
"R|random-sort" => \$opt::random_sort,
|
|
"sort=s" => \$opt::sort,
|
|
"V|version-sort" => \$opt::version_sort,
|
|
"k|key=s" => \@opt::key,
|
|
"t|field-separator=s" => \$opt::field_separator,
|
|
"z|zero-terminated" => \$opt::zero_terminated,
|
|
"files0-from=s" => \$opt::files0_from,
|
|
"random-source=s" => \$opt::dummy,
|
|
"batch-size=s" => \$opt::dummy,
|
|
"check=s" => \$opt::dummy,
|
|
"c" => \$opt::dummy,
|
|
"C" => \$opt::dummy,
|
|
"compress-program=s" => \$opt::dummy,
|
|
"T|temporary-directory=s" => \$opt::dummy,
|
|
"parallel=s" => \$opt::parallel,
|
|
"u|unique" => \$opt::dummy,
|
|
"S|buffer-size=s" => \$opt::dummy,
|
|
"s|stable" => \$opt::dummy,
|
|
"help" => \$opt::dummy,
|
|
) || exit(255);
|
|
$Global::progname = ($0 =~ m:(^|/)([^/]+)$:)[1];
|
|
$Global::version = 20231122;
|
|
if($opt::version) { version(); exit 0; }
|
|
# Remove -D and --parallel=N
|
|
my @s = (grep { ! /^-D$|^--parallel=\S+$/ }
|
|
@ARGV_before[0..($#ARGV_before-$#ARGV-1)]);
|
|
my @sortoptions;
|
|
while(@s) {
|
|
my $o = shift @s;
|
|
# Remove '--parallel N'
|
|
if($o eq "--parallel") {
|
|
$o = shift @s;
|
|
} else {
|
|
push @sortoptions, $o;
|
|
}
|
|
}
|
|
@Global::sortoptions = shell_quote(@sortoptions);
|
|
$ENV{'TMPDIR'} ||= "/tmp";
|
|
|
|
sub merge {
|
|
# Input:
|
|
# @cmd = commands to 'cat' (part of) a file
|
|
# 'cat a' 'cat b' 'cat c' =>
|
|
# sort -m <(sort -m <(cat a) <(cat b)) <(sort -m <(cat c))
|
|
my @cmd = @_;
|
|
chomp(@cmd);
|
|
while($#cmd > 0) {
|
|
my @tmp;
|
|
while($#cmd >= 0) {
|
|
my $a = shift @cmd;
|
|
my $b = shift @cmd;
|
|
$a &&= "<($a)";
|
|
$b &&= "<($b)";
|
|
# This looks like useless use of 'cat', but contrary to
|
|
# naive belief it increases performance dramatically.
|
|
push @tmp, "sort -m @Global::sortoptions $a $b | cat"
|
|
}
|
|
@cmd = @tmp;
|
|
}
|
|
return @cmd;
|
|
}
|
|
|
|
sub sort_files {
|
|
# Input is files
|
|
my @files = @_;
|
|
# Let GNU Parallel generate the commands to read parts of files
|
|
# The commands split at \n (or \0)
|
|
# and there will be at least one for each CPU thread
|
|
my @subopt;
|
|
if($opt::zero_terminated) { push @subopt, qw(--recend "\0"); }
|
|
if($opt::parallel) { push @subopt, qw(--jobs), $opt::parallel; }
|
|
# $uniq is needed because @files could contain \n
|
|
my $uniq = join "", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..20);
|
|
open(my $par,"-|",qw(parallel), @subopt,
|
|
qw(--pipepart --block -1 --dryrun -vv sort),
|
|
@Global::sortoptions, $uniq, '::::', @files) || die;
|
|
# Generated commands:
|
|
# <file perl-catter | (sort ... $uniq )
|
|
# Use $uniq to split into commands
|
|
# (We cannot use \n because 'file' may contain newline)
|
|
my @cmd = map { "$_)\n" } split(/$uniq[)]\n/, join("",<$par>));
|
|
debug(1,@cmd);
|
|
close $par;
|
|
@cmd = merge(@cmd);
|
|
# The command uses <(...) so it is incompatible with /bin/sh
|
|
open(my $bash,"|-","bash") || die;
|
|
print $bash @cmd;
|
|
close $bash;
|
|
}
|
|
|
|
sub sort_stdin {
|
|
# Input is stdin
|
|
# Spread the input between n processes that each sort
|
|
# n = number of CPU threads
|
|
my $numthreads;
|
|
chomp($numthreads = $opt::parallel || `parallel --number-of-threads`);
|
|
my @fifos = map { tmpfifo() } 1..$numthreads;
|
|
map { mkfifo($_,0600) } @fifos;
|
|
# This trick removes the fifo as soon as it is connected in the other end
|
|
# (rm fifo; ...) < fifo
|
|
my @cmd = (map { "(rm $_; sort @Global::sortoptions) < $_" }
|
|
map { Q($_) } @fifos);
|
|
@cmd = merge(@cmd);
|
|
if(fork) {
|
|
} else {
|
|
my @subopt = $opt::zero_terminated ? qw(--recend "\0") : ();
|
|
exec(qw(parallel -0 -j), $numthreads, @subopt,
|
|
# 286k is the best mean value after testing 250..350
|
|
qw(--block 286k --pipe --roundrobin cat > {} :::),@fifos);
|
|
}
|
|
# The command uses <(...) so it is incompatible with /bin/sh
|
|
open(my $bash,"|-","bash") || die;
|
|
print $bash @cmd;
|
|
close $bash;
|
|
}
|
|
|
|
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'}) {
|
|
if(not -e $ENV{'TMPDIR'}) {
|
|
::error("Tmpdir '$ENV{'TMPDIR'}' does not exist.","Try 'mkdir ".
|
|
Q($ENV{'TMPDIR'})."'");
|
|
} else {
|
|
::error("Tmpdir '$ENV{'TMPDIR'}' is not writable.","Try 'chmod +w ".
|
|
Q($ENV{'TMPDIR'})."'");
|
|
}
|
|
exit(255);
|
|
}
|
|
do {
|
|
$tmpname = $ENV{'TMPDIR'}."/".$name.
|
|
join"", map { (0..9,"a".."z","A".."Z")[rand(62)] } (1..5);
|
|
} while(-e $tmpname);
|
|
return $tmpname;
|
|
}
|
|
|
|
sub tmpfifo {
|
|
# Find an unused name and mkfifo on it
|
|
my $tmpfifo = tmpname("psort");
|
|
mkfifo($tmpfifo,0600);
|
|
return $tmpfifo;
|
|
}
|
|
|
|
sub debug {
|
|
# Returns: N/A
|
|
$opt::D or return;
|
|
@_ = grep { defined $_ ? $_ : "" } @_;
|
|
print STDERR @_[1..$#_];
|
|
}
|
|
|
|
sub version() {
|
|
# Returns: N/A
|
|
print join
|
|
("\n",
|
|
"GNU $Global::progname $Global::version",
|
|
"Copyright (C) 2020-2023 Ole Tange, http://ole.tange.dk and Free Software",
|
|
"Foundation, Inc.",
|
|
"License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>",
|
|
"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/parallel\n",
|
|
);
|
|
}
|
|
|
|
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
|
|
my $s = $_[0];
|
|
if($s =~ /[^-_.+a-z0-9\/]/i) {
|
|
$s =~ s/'/'"'"'/g; # "-quote single quotes
|
|
$s = "'$s'"; # '-quote entire string
|
|
$s =~ s/^''//; # Remove unneeded '' at ends
|
|
$s =~ s/''$//; # (faster than s/^''|''$//g)
|
|
return $s;
|
|
} elsif ($s eq "") {
|
|
return "''";
|
|
} else {
|
|
# No quoting needed
|
|
return $s;
|
|
}
|
|
}
|
|
|
|
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 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 || "parsort";
|
|
status_no_nl(map { ($prog, ": Warning: ", $_, "\n"); } @w);
|
|
}
|
|
|
|
{
|
|
my %warnings;
|
|
sub warning_once(@) {
|
|
my @w = @_;
|
|
my $prog = $Global::progname || "parsort";
|
|
$warnings{@w}++ or
|
|
status_no_nl(map { ($prog, ": Warning: ", $_, "\n"); } @w);
|
|
}
|
|
}
|
|
|
|
sub error(@) {
|
|
my @w = @_;
|
|
my $prog = $Global::progname || "parsort";
|
|
status(map { ($prog.": Error: ". $_); } @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");
|
|
exit(255);
|
|
}
|
|
|
|
if(@ARGV) {
|
|
sort_files(@ARGV);
|
|
} elsif(length $opt::files0_from) {
|
|
$/="\0";
|
|
open(my $fh,"<",$opt::files0_from) || die;
|
|
my @files = <$fh>;
|
|
chomp(@files);
|
|
sort_files(@files);
|
|
} else {
|
|
sort_stdin();
|
|
}
|
|
|
|
# Test
|
|
# -z
|
|
# OK: cat bigfile | parsort
|
|
# OK: parsort -k4n files*.txt
|
|
# OK: parsort files*.txt
|
|
# OK: parsort "file with space"
|
|
|