From: Gurusamy Sarathy Date: Thu, 2 Dec 1999 03:42:55 +0000 (+0000) Subject: allow XSUBs and prototyped subroutines to be used with sort() (tweaked X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4348140855c01942a6531a8decdfe1325fe36f8a;p=p5sagit%2Fp5-mst-13.2.git allow XSUBs and prototyped subroutines to be used with sort() (tweaked variant of patch suggested by Peter Haworth ) p4raw-id: //depot/perl@4614 --- diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e46df77..12d2684 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -469,6 +469,16 @@ this support (if it is available). You can Configure -Dusemorebits to turn on both the 64-bit support and the long double support. +=head2 Enhanced support for sort() subroutines + +Perl subroutines with a prototype of C<($$)> and XSUBs in general can +now be used as sort subroutines. In either case, the two elements to +be compared as passed as normal parameters in @_. See L. + +For unprototyped sort subroutines, the historical behavior of passing +the elements to be compared as the global variables $a and $b remains +unchanged. + =head2 Better syntax checks on parenthesized unary operators Expressions such as: diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 513cf7c..7cf4d3f 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -3941,12 +3941,16 @@ the name of (or a reference to) the actual subroutine to use. In place of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort subroutine. -In the interests of efficiency the normal calling code for subroutines is -bypassed, with the following effects: the subroutine may not be a -recursive subroutine, and the two elements to be compared are passed into -the subroutine not via C<@_> but as the package global variables $a and -$b (see example below). They are passed by reference, so don't -modify $a and $b. And don't try to declare them as lexicals either. +If the subroutine's prototype is C<($$)>, the elements to be compared +are passed by reference in C<@_>, as for a normal subroutine. If not, +the normal calling code for subroutines is bypassed in the interests of +efficiency, and the elements to be compared are passed into the subroutine +as the package global variables $a and $b (see example below). Note that +in the latter case, it is usually counter-productive to declare $a and +$b as lexicals. + +In either case, the subroutine may not be recursive. The values to be +compared are always passed by reference, so don't modify them. You also cannot exit out of the sort block or subroutine using any of the loop control operators described in L or with C. @@ -4026,6 +4030,14 @@ Examples: || $a->[2] cmp $b->[2] } map { [$_, /=(\d+)/, uc($_)] } @old; + + # using a prototype allows you to use any comparison subroutine + # as a sort subroutine (including other package's subroutines) + package other; + sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here + + package main; + @new = sort other::backwards @old; If you're using strict, you I declare $a and $b as lexicals. They are package globals. That means diff --git a/pp_ctl.c b/pp_ctl.c index ec7dfb8..54bd654 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -27,6 +27,8 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) static I32 sortcv(pTHXo_ SV *a, SV *b); +static I32 sortcv_stacked(pTHXo_ SV *a, SV *b); +static I32 sortcv_xsub(pTHXo_ SV *a, SV *b); static I32 sv_ncmp(pTHXo_ SV *a, SV *b); static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b); static I32 amagic_ncmp(pTHXo_ SV *a, SV *b); @@ -778,6 +780,8 @@ PP(pp_sort) I32 gimme = GIMME; OP* nextop = PL_op->op_next; I32 overloading = 0; + bool hasargs = FALSE; + I32 is_xsub = 0; if (gimme != G_ARRAY) { SP = MARK; @@ -796,28 +800,38 @@ PP(pp_sort) } else { cv = sv_2cv(*++MARK, &stash, &gv, 0); + if (cv && SvPOK(cv)) { + STRLEN n_a; + char *proto = SvPV((SV*)cv, n_a); + if (proto && strEQ(proto, "$$")) { + hasargs = TRUE; + } + } if (!(cv && CvROOT(cv))) { - if (gv) { + if (cv && CvXSUB(cv)) { + is_xsub = 1; + } + else if (gv) { SV *tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - if (cv && CvXSUB(cv)) - DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr)); DIE(aTHX_ "Undefined sort subroutine \"%s\" called", SvPVX(tmpstr)); } - if (cv) { - if (CvXSUB(cv)) - DIE(aTHX_ "Xsub called in sort"); + else { DIE(aTHX_ "Undefined subroutine in sort"); } - DIE(aTHX_ "Not a CODE reference in sort"); } - PL_sortcop = CvSTART(cv); - SAVEVPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; - SAVEVPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + if (is_xsub) + PL_sortcop = (OP*)cv; + else { + PL_sortcop = CvSTART(cv); + SAVEVPTR(CvROOT(cv)->op_ppaddr); + CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; + + SAVEVPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + } } } else { @@ -863,7 +877,6 @@ PP(pp_sort) PUSHBLOCK(cx, CXt_NULL, PL_stack_base); if (!(PL_op->op_flags & OPf_SPECIAL)) { - bool hasargs = FALSE; cx->cx_type = CXt_SUB; cx->blk_gimme = G_SCALAR; PUSHSUB(cx); @@ -871,7 +884,19 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } PL_sortcxix = cxstack_ix; - qsortsv((myorigmark+1), max, sortcv); + + if (hasargs && !is_xsub) { + /* This is mostly copied from pp_entersub */ + AV *av = (AV*)PL_curpad[0]; + +#ifndef USE_THREADS + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; + } + qsortsv((myorigmark+1), max, + is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; @@ -4148,6 +4173,74 @@ sortcv(pTHXo_ SV *a, SV *b) return result; } +static I32 +sortcv_stacked(pTHXo_ SV *a, SV *b) +{ + dTHR; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + AV *av = GvAV(PL_defgv); + + if (AvMAX(av) < 1) { + SV** ary = AvALLOC(av); + if (AvARRAY(av) != ary) { + AvMAX(av) += AvARRAY(av) - AvALLOC(av); + SvPVX(av) = (char*)ary; + } + if (AvMAX(av) < 1) { + AvMAX(av) = 1; + Renew(ary,2,SV*); + SvPVX(av) = (char*)ary; + } + } + AvFILLp(av) = 1; + + AvARRAY(av)[0] = a; + AvARRAY(av)[1] = b; + PL_stack_sp = PL_stack_base; + PL_op = PL_sortcop; + CALLRUNOPS(aTHX); + if (PL_stack_sp != PL_stack_base + 1) + Perl_croak(aTHX_ "Sort subroutine didn't return single value"); + if (!SvNIOKp(*PL_stack_sp)) + Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); + result = SvIV(*PL_stack_sp); + while (PL_scopestack_ix > oldscopeix) { + LEAVE; + } + leave_scope(oldsaveix); + return result; +} + +static I32 +sortcv_xsub(pTHXo_ SV *a, SV *b) +{ + dSP; + I32 oldsaveix = PL_savestack_ix; + I32 oldscopeix = PL_scopestack_ix; + I32 result; + CV *cv=(CV*)PL_sortcop; + + SP = PL_stack_base; + PUSHMARK(SP); + EXTEND(SP, 2); + *++SP = a; + *++SP = b; + PUTBACK; + (void)(*CvXSUB(cv))(aTHXo_ cv); + if (PL_stack_sp != PL_stack_base + 1) + Perl_croak(aTHX_ "Sort subroutine didn't return single value"); + if (!SvNIOKp(*PL_stack_sp)) + Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); + result = SvIV(*PL_stack_sp); + while (PL_scopestack_ix > oldscopeix) { + LEAVE; + } + leave_scope(oldsaveix); + return result; +} + static I32 sv_ncmp(pTHXo_ SV *a, SV *b) diff --git a/t/op/sort.t b/t/op/sort.t index 9abc410..6e3d2ca 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -4,12 +4,13 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..38\n"; +print "1..49\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -40,96 +41,107 @@ $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; print "# 2: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); +$x = join('', sort( backwards_stacked @harry)); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); + $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 3\n":"not ok 3\n"); +print "# 4: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 4\n":"not ok 4\n"); @a = (); @b = reverse @a; -print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); +print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); @a = (1); @b = reverse @a; -print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); +print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); @a = (1,2); @b = reverse @a; -print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); +print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); @a = (1,2,3); @b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); +print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); @a = (1,2,3,4); @b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); +print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); +print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); $sub = 'backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 10: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); +print "# 11: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); + +$sub = 'backwards_stacked'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 12: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); # literals, combinations @b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); print "# x = '@b'\n"; @b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; @b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; $^W = 0; # redefining sort sub inside the sort sub should fail sub twoface { *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); +print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); # redefining sort subs outside the sort should not fail eval { *twoface = sub { &backwards } }; -print $@ ? "not ok 16\n" : "ok 16\n"; +print $@ ? "not ok 18\n" : "ok 18\n"; eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); +print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); *twoface = sub { *twoface = *backwards; $a <=> $b }; eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); +print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 19\n"; +print $@ ? "$@" : "not ok 21\n"; eval <<'CODE'; my @result = sort main'backwards 'one', 'two'; CODE -print $@ ? "not ok 20\n# $@" : "ok 20\n"; +print $@ ? "not ok 22\n# $@" : "ok 22\n"; eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE -print $@ ? "not ok 21\n# $@" : "ok 21\n"; +print $@ ? "not ok 23\n# $@" : "ok 23\n"; { my $sortsub = \&backwards; @@ -137,13 +149,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $sortglobr = \*backwards; my $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); +} + +{ + my $sortsub = \&backwards_stacked; + my $sortglob = *backwards_stacked; + my $sortglobr = \*backwards_stacked; + my $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n"); } { @@ -152,13 +179,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; local $sortglobr = \*backwards; local $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); +} + +{ + local $sortsub = \&backwards_stacked; + local $sortglob = *backwards_stacked; + local $sortglobr = \*backwards_stacked; + local $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); } ## exercise sort builtins... ($a <=> $b already tested) @@ -167,42 +209,46 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $dummy; # force blockness return $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; -print ($x eq $expected ? "ok 31\n" : "not ok 31\n"); +print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print ($x eq $expected ? "ok 32\n" : "not ok 32\n"); +print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); print "# x = '$x'; expected = '$expected'\n"; { use integer; @b = sort { $a <=> $b } @a; - print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n"); + print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); print "# x = '@b'\n"; @b = sort { $b <=> $a } @a; - print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n"); + print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - print ($x eq $expected ? "ok 35\n" : "not ok 35\n"); + print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - print ($x eq $expected ? "ok 36\n" : "not ok 36\n"); + print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); print "# x = '$x'; expected = '$expected'\n"; } # test that an optimized-away comparison block doesn't take any other # arguments away with it $x = join('', sort { $a <=> $b } 3, 1, 2); -print $x eq "123" ? "ok 37\n" : "not ok 37\n"; +print $x eq "123" ? "ok 47\n" : "not ok 47\n"; # test sorting in non-main package package Foo; @a = ( 5, 19, 1996, 255, 90 ); @b = sort { $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); +print "# x = '@b'\n"; + +@b = sort main::backwards_stacked @a; +print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); print "# x = '@b'\n";