Sponsoring The Perl Toolchain Summit 2025: Help make this important event another success Learn more

SREZIC / App-psort-0.01_52 / bin / psort 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
—
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

              
#!/usr/bin/perl -w
# -*- perl -*-
#
# Author: Slaven Rezic
#
# Copyright (C) 2009,2011 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://www.rezic.de/eserte/
#
use strict;
use Getopt::Long;
use vars qw($VERSION);
$VERSION = "0.01_52";
my $sort_type = 'alpha';
my $reverse;
my $ignore_leading_blanks;
my $ignore_case;
my $ignore_nonprinting;
my $perlscript;
my @modules;
my $cmp_perlscript;
Getopt::Long::Configure("bundling");
GetOptions(
           "n|numeric-sort"       => sub { $sort_type = 'numeric' },
           "N|natural-sort"       => sub { $sort_type = 'sort_naturally' },
           "V|version-sort"       => sub { $sort_type = 'version' },
           "C|compare-function=s" => \$cmp_perlscript,
           "b|ignore-leading-blanks" => \$ignore_leading_blanks,
           "f|ignore-case"        => \$ignore_case,
           "i|ignore-nonprinting" => \$ignore_nonprinting,
           "r|reverse"            => \$reverse,
           "e|field-function=s"   => \$perlscript,
           'M|module=s@'          => \@modules,
           "v|version"            => sub {
               print "psort version $VERSION\n";
               exit 0;
           },
          ) or die <<EOF;
usage: $0 [-n | -N | -V | -C ...] [-r] -e ...
-n: compare numerically
-N: compare using Sort::Naturally
-V: compare versions
-C: compare using any perl code (\$a and \$b are defined)
-r: reverse sorting
-e: perl oneliner, should return the value to be compared as last value
-M: add perl modules
EOF
if ($cmp_perlscript) {
    $sort_type = eval "sub { $cmp_perlscript }";
    die "Cannot compile 'cmp' code: $@" if $@;
}
for my $module_spec (@modules) {
    my($module,$imports) = split /=/, $module_spec, 2;
    eval qq{require $module};
    die $@ if $@;
    my @imports;
    if (defined $imports) {
        @imports = split /,/, $imports;
        $module->import(@imports);
    }
}
my @data;
my $cb = defined $perlscript ? do {
    my $sub = eval "sub { $perlscript }";
    die "Cannot compile code: $@" if $@;
    $sub;
} : sub { $_ };
if (@ARGV) {
    for my $file (@ARGV) {
        add_psort(do { open my $fh, $file or die "Can't open $file: $!"; $fh });
    }
} else {
    add_psort(\*STDIN);
}
if ($sort_type eq 'numeric') {
    no warnings 'numeric', 'uninitialized';
    if ($reverse) {
        @data = sort { $b->[1] <=> $a->[1] } @data;
    } else {
        @data = sort { $a->[1] <=> $b->[1] } @data;
    }
} elsif ($sort_type eq 'alpha') {
    no warnings 'uninitialized';
    if ($reverse) {
        @data = sort { $b->[1] cmp $a->[1] } @data;
    } else {
        @data = sort { $a->[1] cmp $b->[1] } @data;
    }
} elsif ($sort_type eq 'sort_naturally') {
    require Sort::Naturally;
    no warnings 'uninitialized';
    if ($reverse) {
        @data = sort { Sort::Naturally::ncmp($b->[1], $a->[1]) } @data;
    } else {
        @data = sort { Sort::Naturally::ncmp($a->[1], $b->[1]) } @data;
    }
} elsif ($sort_type eq 'version') {
    require CPAN::Version;
    no warnings 'uninitialized';
    if ($reverse) {
        @data = sort { CPAN::Version->vcmp($b->[1], $a->[1]) } @data;
    } else {
        @data = sort { CPAN::Version->vcmp($a->[1], $b->[1]) } @data;
    }
} elsif (UNIVERSAL::isa($sort_type, 'CODE')) {
    no warnings 'uninitialized';
    if ($reverse) {
        @data = sort { local($a, $b) = ($b->[1], $a->[1]); $sort_type->() } @data;
    } else {
        @data = sort { local($a, $b) = ($a->[1], $b->[1]); $sort_type->() } @data;
    }
} else {
    die "Unhandled sort type '$sort_type'";
}
for (@data) {
    print $_->[0];
}
sub add_psort {
    my($fh) = @_;
    while(<$fh>) {
        my $line = $_;
        my $res = $cb->($_); # force scalar context
        $res = lc $res            if $ignore_case;
        $res =~ s{^\s+}{}         if $ignore_leading_blanks;
        $res =~ s{[[:^print]]}{}g if $ignore_nonprinting;
        push @data, [$line, $res];
    }
}
__END__
=head1 NAME
psort - a perl-enhanced sort
=head1 SYNOPSIS
    psort [-n | -N | -V | -C '$a cmp $b'] [-r] -e '/...(...).../ && $1'
=head1 AUTHOR
Slaven ReziE<x0107>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2009,2011 by Slaven ReziE<x0107>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.
=head1 SEE ALSO
L<sort(1)>, L<Sort::Naturally>.
=cut