#!perl
use 5.010001;
our $AUTHORITY = 'cpan:PERLANCAR';
our $DATE = '2025-01-13';
our $DIST = 'App-subsort';
our $VERSION = '0.052';
my %opts = (
chomp => 1,
ignore_case => 0,
reverse => 0,
key => undef,
input_record_separator => "\n",
output_record_separator => "",
);
my ($routine, $meta);
my $routine_args = {};
my @files;
my $res = GetOptions(
'ignore_case|f' => sub { $opts{ignore_case} = 1 },
'reverse|r' => sub { $opts{reverse} = 1 },
'key|k=s' => \$opts{key},
'no-chomp|C' => sub { $opts{chomp} = 0 },
'0:s' => sub {
if (!defined($_[1]) || $_[1] eq '') {
$opts{input_record_separator} = "\0";
} elsif ($_[1] =~ /\A[0-7]{3}\z/) {
$opts{input_record_separator} = chr(oct($_[1]));
} elsif ($_[1] =~ /\Ax[0-9A-Fa-f]{2}\z/) {
$opts{input_record_separator} = chr(hex($_[1]));
} else {
warn "Invalid record separator (-0), please specify octal e.g. -0177 or hexadecimal e.g. -0x7f";
die "";
}
},
'para' => sub {
$opts{input_record_separator} = "";
},
'help|h' => sub {
print <<'TEXT';
sortsub - Sort lines of text using Sort::Sub routines
Usage:
% subsort [OPTIONS] <ROUTINE> [FILE]...
% subsort --help (or -h)
% subsort --list (or -l)
% subsort --version (or -v)
Examples:
# sort by length, in descending order
% subsort by_length -r < data
% subsort 'by_length<r>' < data
Options:
--help, -h Show this help message and exit.
--version, -v Show version and exit.
--list, -l List available Sort::Sub routines.
--no-chomp, -C Don't chomp newlines (input record separator) from input
and don't re-add newlines (output record separator) when
printing.
--ignore-case, -f Do a case-insensitive sort.
--reverse, -r Do a reverse sort.
--arg=s, -A Argument to pass to sorter. In the form of name=val. Can
be specified multiple times.
-0[octal or hexa] Specify record separator character (default is newline).
--para Split input per paragraph (by blank lines).
--key=s, -k Perl code to generate sort key to sort against.
TEXT
exit 0;
},
'version|v' => sub {
no warnings 'once';
say "subsort version ", ($main::VERSION // 'dev'),
" (", ($main::DATE // 'no date'), ")";
exit 0;
},
'list|l' => sub {
my $mods = Module::List::Tiny::list_modules(
"Sort::Sub::", {list_modules=>1});
for (sort keys %$mods) {
s/.+:://;
say $_;
}
exit 0;
},
'<>' => optspec(
destination => sub {
my $val = shift;
if (!defined $routine) {
$routine = $val;
} else {
push @files, $val;
}
},
completion => sub {
my %args = @_;
if ($args{argpos} == 0) {
Complete::Module::complete_module(
word => $args{word},
ns_prefix => "Sort::Sub",
);
} else {
Complete::File::complete_file(
word => $args{word},
);
}
},
),
'arg|A=s' => optspec(
destination => sub {
my $val = $_[1];
die "subsort: Invalid syntax in --arg (-A), please use name=val: $val\n"
unless $val =~ /(.+?)=(.*)/;
$routine_args->{$1} = $2;
},
completion => sub {
my %args = @_;
my $compres;
my $rname;
{
$rname = $routine;
last if defined $rname;
$rname = $args{words}[0] if @{ $args{words} };
}
return [] unless defined $rname;
my $mod = "Sort::Sub::$rname";
(my $mod_pm = "$mod.pm") =~ s!::!/!g;
eval { require $mod_pm };
return {message=>"Cannot load $mod: $@"} if $@;
my $meta;
eval { $meta = $mod->meta };
return [] unless $meta;
return Complete::Sequence::complete_sequence(
word => $args{word},
sequence => [
sub {
[$meta->{args} ? keys(%{ $meta->{args} }) : ()];
},
'=',
sub {
my $stash = shift;
my $argname = $stash->{completed_item_words}[0];
return [] unless defined $argname;
my $argspec = $meta->{args}{$argname};
return [] unless $argspec->{schema};
arrayify_answer(
Complete::Sah::complete_from_schema(
word => $stash->{cur_word},
schema => $argspec->{schema},
)
);
},
],
);
RETURN_COMPRES:
return $compres;
},
),
);
exit 1 unless $res;
die "subsort: Please specify routine to use\n" unless defined $routine;
$routine =~ s/-/_/g;
($routine, $meta) = Sort::Sub::get_sorter(
"$routine".
($routine =~ /</ ? '' :
"<".($opts{ignore_case} ? "i":"").($opts{reverse} ? "r":"").">"),
$routine_args,
"with meta",
);
@ARGV = @files;
local $/ = $opts{input_record_separator};
local $\ = $opts{output_record_separator};
if (defined $opts{key}) {
my $code_gen_key = eval "sub { $opts{key} }";
die "Can't compile code in --key: $@" if $@;
my @lines = map {$_} <>;
if ($opts{chomp}) { chomp @lines }
my @keys; for (@lines) { push @keys, $code_gen_key->($_) }
my @sorted_indices = sort {
local $main::a = $keys[$a];
local $main::b = $keys[$b];
if ($meta->{compares_record}) {
$main::a = [$main::a, $_];
$main::b = [$main::b, $_];
}
my $res = $routine->($main::a, $main::b);
log_trace "Comparing keys %s and %s: %d",
$main::a, $main::b, $res;
$res;
} 0..$#lines;
if ($opts{chomp}) {
say $lines[$_] for @sorted_indices;
} else {
print $lines[$_] for @sorted_indices;
}
} else {
my $i = 0;
for (sort {
my $res;
if ($meta->{compares_record}) {
$res = $routine->($main::a, $main::b);
log_trace "Comparing data records %s and %s: %d",
$main::a, $main::b, $res;
} else {
$res = $routine->($main::a->[0], $main::b->[0]);
log_trace "Comparing data items %s and %s: %d",
$main::a->[0], $main::b->[0], $res;
}
$res;
} map { if ($opts{chomp}) { chomp; [$_, $i++] } else { [$_, $i++] } } <>) {
if ($opts{chomp}) {
say $_->[0];
} else {
print $_->[0];
}
}
}