for my $movie (sort { my_article_sort($a->{title},$b->{title}) values %movies} { ... } for my $alpha (sort { my_article_sort($a,$b) } keys %alpha_movies) { ... } for my $character (sort { my_name_sort($a->{name},$b->{name}) values %player_characters} { ... } for my $color (sort { my_article_sort($a->{name},$b->{name}) values %colors} { ... } my @files = (map("$data_dir$_",grep(/txt$/,sort { my_article_sort($a,$b) } readdir($directory)))); #### package Base::Sorts; use strict; use warnings FATAL => qw( all ); use base 'Exporter'; our @EXPORT_OK = qw(my_article_sort my_name_sort short_sorts); use Carp qw(croak); use HTML::Entities qw(decode_entities); sub split_out_leading_number { my $s = shift; if ( $s =~/^((\d|,|\.)+)(.*)$/) { my ($leading_number, $rest) = ($1,$3); # Take any commas out of the number. $leading_number =~ s/,//g; return ($leading_number, $rest); } die "split_out_leading_number received bogus input '$s'!\n"; } sub my_article_sort { my ($c,$d) = @_; $c = lc($c); $d = lc($d); # When sorting lists of files, I want the index file to always come first. if ($c =~ /^index\./) { return -1; } elsif ($d =~ /^index\./) { return 1; } else { # This is the default sorting method. # Written with the help of kent/n in #perl on freenode. for ($c, $d) { s/<.+?>//g; # Strip out any html tags. s/\s*\b(A|a|An|an|The|the)(_|\s)//xi; # Strip off leading articles (in English). decode_entities($_); } if ( $c =~/^((\d|,|\.)+)(.*)$/ && $d =~ /^((\d|,|\.)+)(.*)$/) { my ($num1, $text1) = split_out_leading_number($c); my ($num2, $text2) = split_out_leading_number($d); # First compare the numbers, then compare the remaining parts of the string. $num1 <=> $num2 || $text1 cmp $text2 } else { $c cmp $d; } } } sub my_name_sort { my ($c,$d) = @_; $c = lc($c); $d = lc($d); # When sorting lists of files, I want the index file to always come first. # There may be an index file in a folder of files I want sorted by name. if ($c =~ /^index\./) { return -1; } elsif ($d =~ /^index\./) { return 1; } else { # When I sort by name I prefer lastname firstname. # I have not yet written this to account for Sr., Jr., or Roman numerals after the last name. for ($c,$d) { s/<.+?>//g; # Strip out any html tags. s/\|.+$//; $_ = join(' ', (reverse split(/(?:_|\s)(?=[^_\s]+$)/, $_,2))) if $_ !~ /^_/; s/^_//; decode_entities($_); } return $c cmp $d; } } sub short_sorts { my ($a,$b,$type) = @_; # Legend: # s = case sensitive # i = case insensitive # a = ascending # d = descending # r = reverse (right to left) # n = numbers # l = length of value my %sorts; $sorts{$_} = sub { $_[0] cmp $_[1] } for qw(sa as); $sorts{$_} = sub { $_[1] cmp $_[0] } for qw(sd ds); $sorts{$_} = sub { uc $_[0] cmp uc $_[1] } for qw(ia ai); $sorts{$_} = sub { uc $_[1] cmp uc $_[0] } for qw(id di); $sorts{$_} = sub { $_[0] <=> $_[1] } for qw(na an); $sorts{$_} = sub { $_[1] <=> $_[0] } for qw(nd dn); $sorts{$_} = sub { reverse($_[0]) cmp reverse($_[1]) } for qw(sar sra asr ars rsa ras); $sorts{$_} = sub { reverse($_[1]) cmp reverse($_[0]) } for qw(sdr srd dsr drs rsd rds); $sorts{$_} = sub { uc reverse($_[0]) cmp uc reverse($_[1]) } for qw(iar ira air ari ria rai); $sorts{$_} = sub { uc reverse($_[1]) cmp uc reverse($_[0]) } for qw(idr ird dir dri rid rdi); $sorts{$_} = sub { reverse $_[0] <=> reverse $_[1] } for qw(nar nra anr arn rna ran); $sorts{$_} = sub { reverse $_[1] <=> reverse $_[0] } for qw(ndr nrd dnr drn rnd rdn); $sorts{$_} = sub { length($_[0]) <=> length($_[1]) } for qw(la al); $sorts{$_} = sub { length($_[1]) <=> length($_[0]) } for qw(ld dl); if ($type) { croak "$type is not supported" if !exists $sorts{$type}; return $sorts{$type}->($a,$b); } else { die "A sort type was not selected."; } }