#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

my @pchr = qw( K Q R B N P );
my $w1   = 'QRKPNBQ';  # <- Q is repeated!
my $w2 = join "", map $_ x (() = $w1 =~ /$_/g), @pchr;
say "$w1 \-> $w2";
[download]

Cool! And, yes, it is checked elsewhere that the string only contains "valid" characters.

You could avoid the temp $i by iterating over the indexes instead. Doing that that just puts you one line more (also presuming this is run under a use 5.010 or higher directive so you have say so that gets it back absolute line count wise). You could also use List::MoreUtils for sort_by, but otherwise I couldn't say anything looks particularly awkward in your code.

use 5.010;
use List::MoreUtils qw( sort_by );

my @PCHR = qw( K Q R B N P );
my %pchr = map { $PCHR[$_] => $_ } 0..$#PCHR;
my $w1 = 'QRKPNB';
my $w2 = join '', sort_by { $pchr{$_} } split( //, $w1 );
say "$w1 -> $w2";
[download]

If you really didn't need @PCHR for anything other than creating the ordering hash you could create %pchr with something like this. Still has a temp but it's lexical to the do block, and you can get what was in @PCHR with sort_by {$pchr{$_}} keys %pchr. Really kind of depends what else exactly you're doing which one I'd go with.

my %pchr = do { my $i; map { $_ => $i++ } qw( K Q R B N P ) };
[download]

Yes, List::Util::sort_by makes it look better. Maybe, the Pythonian sorted() could also be an enhancement for List::Util resp. List::MoreUtils.

  my $i = 0;
# use constant PCHR => split //, 'KQRBNP';
# my %pchr = map { $_ => $i++ } PCHR;
  use constant PCHR => 'KQRBNP';
  my $w1 = 'QRKPNB';
  my $w2 = join '', 
    map $_->[1],
    sort { $a->[0] <=> $b->[0] } 
    map [ ( index PCHR, $_ ), $_ ],
    split //, $w1;
  print "$w1 -> $w2\n";
[download]

Interesting idea, thanks!

my @sizes = qw/6XS 5XS 6XL L S xL m 3xs/;

my $sort_sizes_sub = sub {
  my $uc_a = uc($a);
  my $uc_b = uc($b);
  my @sizes_sorted = qw/6XS 5XS 4XS 3XS 2XS XS S M L XL XXL 2XL 3XL 4X
+L 5XL 6XL/;
  return 0 if $uc_a eq $uc_b;
  foreach my $s (@sizes_sorted) {
    if ($s eq $uc_a) {
      return -1;
    }
    if ($s eq $uc_b) {
      return 1;
    }
  }
};

print join(' ', @sizes). "\n";
print join(' ', sort $sort_sizes_sub @sizes). "\n";
[download]

Result:

6XS 5XS 6XL L S xL m 3xs
6XS 5XS 3xs S m L xL 6XL
[download]

#!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11141469
use warnings;
use List::AllUtils qw( nsort_by );

my $pchr = 'KQRBNP';
my $w1 = 'QRKPNB';
my $w2 = join '', nsort_by { index $pchr, $_ } split //, $w1;
print "Given pchr = $pchr, then $w1 -> $w2\n";
[download]

my $pchr = "KQRBNP";
my $w1 = "QRKPNBNBQRK";

my $ascii = join '', map chr $_, 0..length($pchr);
my $w2 = join '', sort split //, eval "\$w1 =~ y/\Q$pchr\E/\Q$ascii\E/
+r";
eval "\$w2 =~ y/\Q$ascii\E/\Q$pchr\E/";

print "$w1 --[$pchr]--> $w2\n"
[download]

sub mk_sort {
    my $pchr = shift;
    my $a = join '', map chr, 0..length(\$pchr);
    eval qq{sub { (join '', sort split //, (shift =~ y/\Q$pchr\E/\Q$a\
+E/r)) =~ y/\Q$a\E/\Q$pchr\E/r }};
}

my $sort = mk_sort "KQRBNP";

my $w1 = "QRKPNBNBQRK";
my $w2 = $sort->($w1);

print "$w1 --> $w2\n"
[download]

The question is if you want it fast or pretty.

Without extra modules, this doesn't look particular awkward to me.

use strict;
use warnings;

my $PCHR = "KQRBNP";
my $w1   = "QRKPNB";
my $w2 =
  join "",
  sort { index ($PCHR, $a) <=> index ($PCHR, $b) }
  split //, $w1;

print "$w1 -> $w2";
[download]

of course it's far more efficient to store the index in a hash, which in turn needs to be precalculated.

Others have shown you external "sort_by" implementations using so-called "key-functions" like in Python ( That's when you can avoid to repeat code for $a and $b).

But I'm not sure if these key-functions - in Python or CPAN - actually cache the results for performance optimization in a hash. (This might be too clever if a key function is supposed to vary results)

Which brings us back to the question: fast or pretty?

How about a hash slice? No sorting required.

johngg@abouriou:~$ perl -Mstrict -Mwarnings -E 'say q{};
my @PCHR = qw{ K Q R B N P };
my $w1   =  q{QRKPNB};
my %w1LU = map { $_ => $_ } split m{}, $w1;
say join q{}, @w1LU{ @PCHR };'

KQRBNP
[download]

I hope this is of interest.

I see multiple limitations:
• you can't sort lists with repeated elements in $w1
• the slice will produce undef for every order-element from PCHR missing in the list
• list-elements without order won't show up

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}

my $pchr = "KQRBNP";
my $w1 = "QRKPNBNBQRK";

my %s;
$s{$_}++ for split //, $w1;
my $w2 = $pchr =~ s/(.)/$1 x $s{$1}/egr;

print "$w1 -> $w2\n"
[download]

Similar to yours and choroba's solutions but without string multiplication ('x'):

my $pchr = "KQRBNP";
my $w1 = "QRKPNBNBQRK";
my $w2 = "";

for my $L ( split //, $pchr ){
  $w1 =~ m/$L(?{ $w2 .= $L })(*FAIL)/;
}

print "$w1 -> $w2\n"
[download]

And a bit similar to drclaw's idea:

my $pchr = "KQRBNP";
my $w1 = "QRKPNBNBQRK";
my $w2 = "";

my $re = join "|", map { ".*$_" } split //, $pchr;
$w1 =~ m/^(?:$re)(?<=(.))(?{ $w2 .= $1 })(*FAIL)/;

print "$w1 -> $w2\n"
[download]

Not sure if regex is optimized in some versions and this code fails.

What about inverting the search? You already know the order of the characters. Match them as many times as possible against the input string as a regex with each character as an alternative (ie input "QRKPNB" becomes /Q|R|K|P|N|B/ )?

These couple of lines generate the regex based on the input and match the sorted list against it. The joined matches become the (sorted) output string:

my $PCHR="KQRBNP";
my $w1="QRKPNB";
my $w2=join "", $PCHR=~/@{[join "|",split "",$w1]}/g;
print "$w1 -> $w2\n";
[download]

Hope it might be of use or interest to your application