1 /* -*- Mode: C -*- */
2
3 #define PERL_NO_GET_CONTEXT 1
4
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #include "ppport.h"
10
11 #if (PERL_VERSION < 7)
12 #include "sort.h"
13 #endif
14
15 static I32
ix_sv_cmp(pTHX_ SV ** a,SV ** b)16 ix_sv_cmp(pTHX_ SV **a, SV **b) {
17 return sv_cmp(*a, *b);
18 }
19
20 static I32
ix_rsv_cmp(pTHX_ SV ** a,SV ** b)21 ix_rsv_cmp(pTHX_ SV **a, SV **b) {
22 return sv_cmp(*b, *a);
23 }
24
25 static I32
ix_lsv_cmp(pTHX_ SV ** a,SV ** b)26 ix_lsv_cmp(pTHX_ SV **a, SV **b) {
27 return sv_cmp_locale(*a, *b);
28 }
29
30 static I32
ix_rlsv_cmp(pTHX_ SV ** a,SV ** b)31 ix_rlsv_cmp(pTHX_ SV **a, SV **b) {
32 return sv_cmp_locale(*b, *a);
33 }
34
35 static I32
ix_n_cmp(pTHX_ NV * a,NV * b)36 ix_n_cmp(pTHX_ NV *a, NV *b) {
37 NV nv1 = *a;
38 NV nv2 = *b;
39 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
40 }
41
42 static I32
ix_rn_cmp(pTHX_ NV * a,NV * b)43 ix_rn_cmp(pTHX_ NV *a, NV *b) {
44 NV nv1 = *b;
45 NV nv2 = *a;
46 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
47 }
48
49 static I32
ix_i_cmp(pTHX_ IV * a,IV * b)50 ix_i_cmp(pTHX_ IV *a, IV *b) {
51 IV iv1 = *a;
52 IV iv2 = *b;
53 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
54 }
55
56 static I32
ix_ri_cmp(pTHX_ IV * a,IV * b)57 ix_ri_cmp(pTHX_ IV *a, IV *b) {
58 IV iv1 = *b;
59 IV iv2 = *a;
60 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
61 }
62
63 static I32
ix_u_cmp(pTHX_ UV * a,UV * b)64 ix_u_cmp(pTHX_ UV *a, UV *b) {
65 UV uv1 = *a;
66 UV uv2 = *b;
67 return uv1 < uv2 ? -1 : uv1 > uv2 ? 1 : 0;
68 }
69
70 static I32
ix_ru_cmp(pTHX_ UV * a,UV * b)71 ix_ru_cmp(pTHX_ UV *a, UV *b) {
72 UV uv1 = *b;
73 UV uv2 = *a;
74 return uv1 < uv2 ? -1 : uv1 > uv2 ? 1 : 0;
75 }
76
v_alloc(pTHX_ IV n,IV lsize)77 static void *v_alloc(pTHX_ IV n, IV lsize) {
78 void *r;
79 Newxc(r, n<<lsize, char, void);
80 SAVEFREEPV(r);
81 return r;
82 }
83
av_alloc(pTHX_ IV n,IV lsize)84 static void *av_alloc(pTHX_ IV n, IV lsize) {
85 AV *av=(AV*)sv_2mortal((SV*)newAV());
86 av_fill(av, n-1);
87 return AvARRAY(av);
88 }
89
i_store(pTHX_ SV * v,void * to)90 static void i_store(pTHX_ SV *v, void *to) {
91 *((IV*)to)=SvIV(v);
92 }
93
u_store(pTHX_ SV * v,void * to)94 static void u_store(pTHX_ SV *v, void *to) {
95 *((UV*)to)=SvUV(v);
96 }
97
n_store(pTHX_ SV * v,void * to)98 static void n_store(pTHX_ SV *v, void *to) {
99 *((NV*)to)=SvNV(v);
100 }
101
sv_store(pTHX_ SV * v,void * to)102 static void sv_store(pTHX_ SV *v, void *to) {
103 *((SV**)to)=SvREFCNT_inc(v);
104 }
105
106 #define lsizeof(A) (ilog2(sizeof(A)))
107
108
ilog2(int i)109 static int ilog2(int i) {
110 if (i>256) croak("internal error");
111 if (i>128) return 8;
112 if (i>64) return 7;
113 if (i>32) return 6;
114 if (i>16) return 5;
115 if (i>8) return 4;
116 if (i>4) return 3;
117 if (i>2) return 2;
118 if (i>1) return 1;
119 return 0;
120 }
121
122 /* sorting types:
123
124 0 => string
125 1 => locale
126 2 => number
127 3 => integer
128 4 => unsigned_integer
129 5 => single precission float - not implemented
130
131 128 => reverse string
132 129 => reverse locale
133 130 => reverse number
134 131 => reverse integer
135 132 => reverse unsigned_integer
136 133 => reverse s. p. float - not implemented
137
138 */
139
140 typedef I32 (*COMPARE_t)(pTHX_ void*, void*);
141 typedef void (*STORE_t)(pTHX_ SV*, void*);
142
143 static void
_keysort(pTHX_ IV type,SV * keygen,SV ** values,I32 offset,I32 ax,IV len)144 _keysort(pTHX_ IV type, SV *keygen, SV **values, I32 offset, I32 ax, IV len) {
145 dSP;
146 if (len) {
147 void *keys;
148 void **ixkeys;
149 IV i;
150 SV **from, **to;
151
152 IV lsize;
153 COMPARE_t cmp;
154 STORE_t store;
155
156 #if (PERL_VERSION < 9)
157 int hints = PL_curcop->op_private;
158 #else
159 int hints = CopHINTS_get(PL_curcop);
160 #endif
161
162 /* fprintf (stderr, "hints=0x%x, int=0x%x, loc=0x%x\n", hints, HINT_INTEGER, HINT_LOCALE );fflush(stderr); */
163
164 switch(type) {
165 case 0:
166 case 128:
167 if (hints & HINT_LOCALE) type = type | 128;
168 break;
169 case 2:
170 case 130:
171 if (hints & HINT_INTEGER) type = type | 1;
172 break;
173 }
174
175 switch(type) {
176 case 0:
177 cmp = (COMPARE_t)&ix_sv_cmp;
178 lsize = lsizeof(SV*);
179 keys = av_alloc(aTHX_ len, lsize);
180 store = &sv_store;
181 break;
182 case 1:
183 cmp = (COMPARE_t)&ix_lsv_cmp;
184 lsize = lsizeof(SV*);
185 keys = av_alloc(aTHX_ len, lsize);
186 store = &sv_store;
187 break;
188 case 2:
189 cmp = (COMPARE_t)&ix_n_cmp;
190 lsize = lsizeof(NV);
191 keys = v_alloc(aTHX_ len, lsize);
192 store = &n_store;
193 break;
194 case 3:
195 cmp = (COMPARE_t)&ix_i_cmp;
196 lsize = lsizeof(IV);
197 keys = v_alloc(aTHX_ len, lsize);
198 store = &i_store;
199 break;
200 case 4:
201 cmp = (COMPARE_t)&ix_u_cmp;
202 lsize = lsizeof(UV);
203 keys = v_alloc(aTHX_ len, lsize);
204 store = &u_store;
205 break;
206 case 128:
207 cmp = (COMPARE_t)&ix_rsv_cmp;
208 lsize = lsizeof(SV*);
209 keys = av_alloc(aTHX_ len, lsize);
210 store = &sv_store;
211 break;
212 case 129:
213 cmp = (COMPARE_t)&ix_rlsv_cmp;
214 lsize = lsizeof(SV*);
215 keys = av_alloc(aTHX_ len, lsize);
216 store = &sv_store;
217 break;
218 case 130:
219 cmp = (COMPARE_t)&ix_rn_cmp;
220 lsize = lsizeof(NV);
221 keys = v_alloc(aTHX_ len, lsize);
222 store = &n_store;
223 break;
224 case 131:
225 cmp = (COMPARE_t)&ix_ri_cmp;
226 lsize = lsizeof(IV);
227 keys = v_alloc(aTHX_ len, lsize);
228 store = &i_store;
229 break;
230 case 132:
231 cmp = (COMPARE_t)&ix_ru_cmp;
232 lsize = lsizeof(UV);
233 keys = v_alloc(aTHX_ len, lsize);
234 store = &u_store;
235 break;
236 default:
237 croak("unsupported sort type %d", type);
238 }
239
240 Newx(ixkeys, len, void*);
241 SAVEFREEPV(ixkeys);
242 if (keygen) {
243 for (i=0; i<len; i++) {
244 IV count;
245 SV *current;
246 SV *result;
247 void *target;
248 /* warn("values=%p SP=%p SP-len=%p, &ST(0)=%p\n", values, SP, SP-len, &ST(0)); */
249 ENTER;
250 SAVETMPS;
251 SAVE_DEFSV;
252 current = values ? values[i] : ST(i + offset);
253 DEFSV = sv_2mortal(current ? SvREFCNT_inc(current) : newSV(0));
254 PUSHMARK(SP);
255 PUTBACK;
256 count = call_sv(keygen, G_SCALAR);
257 SPAGAIN;
258 if (count != 1)
259 croak("wrong number of results returned from key generation sub");
260 result = POPs;
261 /* warn("key: %_\n", result); */
262 ixkeys[i] = target = ((char*)keys) + (i << lsize);
263 (*store)(aTHX_ result, target);
264 FREETMPS;
265 LEAVE;
266 }
267 }
268 else {
269 for (i = 0; i < len; i++) {
270 void *target;
271 SV *current = values ? values[i] : ST(i + offset);
272 ixkeys[i] = target = ((char*)keys) + (i << lsize);
273
274 (*store)(aTHX_
275 current ? current : sv_2mortal(newSV(0)),
276 target);
277 }
278 }
279 sortsv((SV**)ixkeys, len, (SVCOMPARE_t)cmp);
280 if (values) {
281 from = to = values;
282 }
283 else {
284 from = &ST(offset);
285 to = &ST(0);
286 }
287 for(i = 0; i < len; i++) {
288 IV j = ( ((char*)(ixkeys[i])) - ((char*)keys) )>>lsize;
289 ixkeys[i] = from[j];
290 }
291 for(i = 0; i < len; i++) {
292 to[i] = (SV*)ixkeys[i];
293 }
294 }
295 }
296
297 typedef struct multikey {
298 COMPARE_t cmp;
299 void *data;
300 IV lsize;
301 } MK;
302
303
_multikeycmp(pTHX_ void * a,void * b)304 static I32 _multikeycmp(pTHX_ void *a, void *b) {
305 MK *keys = (MK*)PL_sortcop;
306 IV r = (*(keys->cmp))(aTHX_ a, b);
307 if (r)
308 return r;
309 else {
310 IV ixa = ( ((char*)a) - ((char*)(keys->data)) ) >> keys->lsize;
311 IV ixb = ( ((char*)b) - ((char*)(keys->data)) ) >> keys->lsize;
312 COMPARE_t cmp;
313 while(1) {
314 keys++;
315 cmp=keys->cmp;
316 if (!cmp)
317 return 0;
318 a = ((char*)(keys->data))+(ixa<<keys->lsize);
319 b = ((char*)(keys->data))+(ixb<<keys->lsize);
320 r = (*cmp)(aTHX_ a, b);
321 if (r)
322 return r;
323 }
324 }
325 return 0; /* dead code just to remove warnings from some
326 * compilers */
327 }
328
_secondkeycmp(pTHX_ void * a,void * b)329 static I32 _secondkeycmp(pTHX_ void *a, void *b) {
330 MK *keys = (MK*)PL_sortcop;
331 IV ixa = ( ((char*)a) - ((char*)(keys->data)) ) >> keys->lsize;
332 IV ixb = ( ((char*)b) - ((char*)(keys->data)) ) >> keys->lsize;
333 COMPARE_t cmp;
334 while(1) {
335 I32 r;
336 keys++;
337 cmp=keys->cmp;
338 if (!cmp)
339 return 0;
340 a = ((char*)(keys->data))+(ixa<<keys->lsize);
341 b = ((char*)(keys->data))+(ixb<<keys->lsize);
342 r = (*cmp)(aTHX_ a, b);
343 if (r)
344 return r;
345 }
346 return 0; /* dead code just to remove warnings from some
347 * compilers */
348 }
349
350 static I32
ix_sv_mcmp(pTHX_ SV ** a,SV ** b)351 ix_sv_mcmp(pTHX_ SV **a, SV **b) {
352 I32 r = sv_cmp(*a, *b);
353 if (r) return r;
354 return _secondkeycmp(aTHX_ a, b);
355 }
356
357 static I32
ix_rsv_mcmp(pTHX_ SV ** a,SV ** b)358 ix_rsv_mcmp(pTHX_ SV **a, SV **b) {
359 I32 r = sv_cmp(*b, *a);
360 if (r) return r;
361 return _secondkeycmp(aTHX_ a, b);
362 }
363
364 static I32
ix_lsv_mcmp(pTHX_ SV ** a,SV ** b)365 ix_lsv_mcmp(pTHX_ SV **a, SV **b) {
366 I32 r = sv_cmp_locale(*a, *b);
367 if (r) return r;
368 return _secondkeycmp(aTHX_ a, b);
369 }
370
371 static I32
ix_rlsv_mcmp(pTHX_ SV ** a,SV ** b)372 ix_rlsv_mcmp(pTHX_ SV **a, SV **b) {
373 I32 r = sv_cmp_locale(*b, *a);
374 if (r) return r;
375 return _secondkeycmp(aTHX_ a, b);
376 }
377
378 static I32
ix_n_mcmp(pTHX_ NV * a,NV * b)379 ix_n_mcmp(pTHX_ NV *a, NV *b) {
380 NV nv1 = *a;
381 NV nv2 = *b;
382 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : _secondkeycmp(aTHX_ a, b);
383 }
384
385 static I32
ix_rn_mcmp(pTHX_ NV * a,NV * b)386 ix_rn_mcmp(pTHX_ NV *a, NV *b) {
387 NV nv1 = *b;
388 NV nv2 = *a;
389 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : _secondkeycmp(aTHX_ a, b);
390 }
391
392 static I32
ix_i_mcmp(pTHX_ IV * a,IV * b)393 ix_i_mcmp(pTHX_ IV *a, IV *b) {
394 IV iv1 = *a;
395 IV iv2 = *b;
396 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : _secondkeycmp(aTHX_ a, b);
397 }
398
399 static I32
ix_ri_mcmp(pTHX_ IV * a,IV * b)400 ix_ri_mcmp(pTHX_ IV *a, IV *b) {
401 IV iv1 = *b;
402 IV iv2 = *a;
403 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : _secondkeycmp(aTHX_ a, b);
404 }
405
406 static I32
ix_u_mcmp(pTHX_ UV * a,UV * b)407 ix_u_mcmp(pTHX_ UV *a, UV *b) {
408 UV uv1 = *a;
409 UV uv2 = *b;
410 return uv1 < uv2 ? -1 : uv1 > uv2 ? 1 : _secondkeycmp(aTHX_ a, b);
411 }
412
413 static I32
ix_ru_mcmp(pTHX_ UV * a,UV * b)414 ix_ru_mcmp(pTHX_ UV *a, UV *b) {
415 UV uv1 = *b;
416 UV uv2 = *a;
417 return uv1 < uv2 ? -1 : uv1 > uv2 ? 1 : _secondkeycmp(aTHX_ a, b);
418 }
419
420 static void
_multikeysort(pTHX_ SV * keytypes,SV * keygen,SV * post,SV ** values,I32 from_offset,I32 ax,I32 len)421 _multikeysort(pTHX_ SV *keytypes, SV *keygen, SV *post,
422 SV**values, I32 from_offset, I32 ax, I32 len) {
423 dSP;
424 STRLEN nkeys;
425 unsigned char *types=(unsigned char *)SvPV(keytypes, nkeys);
426
427 if (nkeys<1)
428 croak("empty multikey type list passed");
429
430 if (len) {
431 IV i;
432 MK *keys;
433 STORE_t *store;
434 void **ixkeys;
435 SV **from, **to;
436 COMPARE_t cmp = (COMPARE_t)&_multikeycmp;
437
438 Newx(keys, nkeys+1, MK);
439 SAVEFREEPV(keys);
440 Newx(store, nkeys, STORE_t);
441 SAVEFREEPV(store);
442
443 for(i=0; i<nkeys; i++) {
444 MK *key = keys+i;
445 switch(types[i]) {
446 case 0:
447 if (i==0) cmp = (COMPARE_t)&ix_sv_mcmp;
448 key->cmp = (COMPARE_t)&ix_sv_cmp;
449 key->lsize = lsizeof(SV*);
450 key->data = av_alloc(aTHX_ len, key->lsize);
451 store[i] = &sv_store;
452 break;
453 case 1:
454 if (i==0) cmp = (COMPARE_t)&ix_lsv_mcmp;
455 key->cmp = (COMPARE_t)&ix_lsv_cmp;
456 key->lsize = lsizeof(SV*);
457 key->data = av_alloc(aTHX_ len, key->lsize);
458 store[i] = &sv_store;
459 break;
460 case 2:
461 if (i==0) cmp = (COMPARE_t)&ix_n_mcmp;
462 key->cmp = (COMPARE_t)&ix_n_cmp;
463 key->lsize = lsizeof(NV);
464 key->data = v_alloc(aTHX_ len, key->lsize);
465 store[i] = &n_store;
466 break;
467 case 3:
468 if (i==0) cmp = (COMPARE_t)&ix_i_mcmp;
469 key->cmp = (COMPARE_t)&ix_i_cmp;
470 key->lsize = lsizeof(IV);
471 key->data = v_alloc(aTHX_ len, key->lsize);
472 store[i] = &i_store;
473 break;
474 case 4:
475 if (i==0) cmp = (COMPARE_t)&ix_u_mcmp;
476 key->cmp = (COMPARE_t)&ix_u_cmp;
477 key->lsize = lsizeof(UV);
478 key->data = v_alloc(aTHX_ len, key->lsize);
479 store[i] = &u_store;
480 break;
481 case 128:
482 if (i==0) cmp = (COMPARE_t)&ix_rsv_mcmp;
483 key->cmp = (COMPARE_t)&ix_rsv_cmp;
484 key->lsize = lsizeof(SV*);
485 key->data = av_alloc(aTHX_ len, key->lsize);
486 store[i] = &sv_store;
487 break;
488 case 129:
489 if (i==0) cmp = (COMPARE_t)&ix_rlsv_mcmp;
490 key->cmp = (COMPARE_t)&ix_rlsv_cmp;
491 key->lsize = lsizeof(SV*);
492 key->data = av_alloc(aTHX_ len, key->lsize);
493 store[i] = &sv_store;
494 break;
495 case 130:
496 if (i==0) cmp = (COMPARE_t)&ix_rn_mcmp;
497 key->cmp = (COMPARE_t)&ix_rn_cmp;
498 key->lsize = lsizeof(NV);
499 key->data = v_alloc(aTHX_ len, key->lsize);
500 store[i] = &n_store;
501 break;
502 case 131:
503 if (i==0) cmp = (COMPARE_t)&ix_ri_mcmp;
504 key->cmp = (COMPARE_t)&ix_ri_cmp;
505 key->lsize = lsizeof(IV);
506 key->data = v_alloc(aTHX_ len, key->lsize);
507 store[i] = &i_store;
508 break;
509 case 132:
510 if (i==0) cmp = (COMPARE_t)&ix_ru_mcmp;
511 key->cmp = (COMPARE_t)&ix_ru_cmp;
512 key->lsize = lsizeof(UV);
513 key->data = v_alloc(aTHX_ len, key->lsize);
514 store[i] = &u_store;
515 break;
516 default:
517 croak("unsupported sort type %d", types[i]);
518 }
519 }
520
521 keys[nkeys].cmp = 0;
522 keys[nkeys].data = 0;
523 keys[nkeys].lsize = 0;
524
525 Newx(ixkeys, len, void*);
526 SAVEFREEPV(ixkeys);
527 for (i=0; i<len; i++) {
528 IV count;
529 SV *current;
530 void *target;
531 ENTER;
532 SAVETMPS;
533 SAVE_DEFSV;
534 current = values ? values[i] : ST(i+from_offset);
535 DEFSV = sv_2mortal(current ? SvREFCNT_inc(current) : newSV(0));
536 PUSHMARK(SP);
537 PUTBACK;
538 count = call_sv(keygen, G_ARRAY);
539 SPAGAIN;
540 if (post) {
541 PUSHMARK(SP-count);
542 PUTBACK;
543 count = call_sv(post, G_ARRAY);
544 SPAGAIN;
545 }
546 if (count != nkeys)
547 croak("wrong number of results returned "
548 "from multikey generation sub "
549 "(%d expected, %d returned)",
550 nkeys, count);
551 while(count-- > 0) {
552 SV *result = POPs;
553 MK *key = keys+count;
554 target = ((char*)(key->data)) + (i<<key->lsize);
555 (*(store[count]))(aTHX_ result, target);
556 }
557 ixkeys[i] = target;
558 FREETMPS;
559 LEAVE;
560 }
561 SAVEVPTR(PL_sortcop);
562 PL_sortcop = (OP*)keys;
563 sortsv((SV**)ixkeys, len, (SVCOMPARE_t)cmp);
564 if (values) {
565 from = to = values;
566 }
567 else {
568 from = &ST(from_offset);
569 to = &ST(0);
570 }
571 for(i=0; i<len; i++) {
572 IV j = ( ((char*)(ixkeys[i])) - ((char*)(keys->data)) )>>keys->lsize;
573 ixkeys[i] = from[j];
574 }
575 for(i=0; i<len; i++) {
576 to[i] = (SV*)ixkeys[i];
577 }
578 }
579 }
580
581 static AV *
_xclosure_defaults(pTHX_ CV * cv)582 _xclosure_defaults(pTHX_ CV *cv) {
583 MAGIC *magic = mg_find((SV*)cv, '~');
584 if (magic) {
585 if ( magic->mg_obj
586 && SvTYPE((SV*)(magic->mg_obj)) == SVt_PVAV )
587 return (AV*)(magic->mg_obj);
588 croak("internal error: bad XSUB closure");
589 }
590 return NULL;
591 }
592
593 static void
_xclosure_make(pTHX_ CV * cv,AV * defaults)594 _xclosure_make(pTHX_ CV *cv, AV *defaults) {
595 sv_magic((SV*)cv, (SV*)defaults, '~', "XCLOSURE", 0);
596 }
597
598 XS(XS_Sort__Key__multikeysort);
XS(XS_Sort__Key__multikeysort)599 XS(XS_Sort__Key__multikeysort)
600 {
601 dXSARGS;
602 SV *gen=0;
603 SV *post=0;
604 SV *types=0;
605 IV offset=0;
606
607 AV *defaults = _xclosure_defaults(aTHX_ cv);
608
609 if (defaults) {
610 types = *(av_fetch(defaults, 0, 1));
611 gen = *(av_fetch(defaults, 1, 1));
612 post = *(av_fetch(defaults, 2, 1));
613 if (!SvOK(post))
614 post = 0;
615 }
616
617 if (!types || !SvOK(types)) {
618 if (items--)
619 types = ST(offset++);
620 else
621 croak("not enough arguments");
622
623 }
624 if (!gen || !SvOK(gen)) {
625 if (items--)
626 gen = ST(offset++);
627 else
628 croak("not enough arguments");
629 }
630
631 _multikeysort(aTHX_ types, gen, post, 0, offset, ax, items);
632 SP=&ST(items-1);
633 PUTBACK;
634 return;
635 }
636
637
638 XS(XS_Sort__Key__multikeysort_inplace);
XS(XS_Sort__Key__multikeysort_inplace)639 XS(XS_Sort__Key__multikeysort_inplace)
640 {
641 dXSARGS;
642 SV *gen = 0;
643 SV *post = 0;
644 SV *types = 0;
645 AV *values;
646
647 AV *magic_values=0;
648 I32 len;
649 I32 offset=0;
650
651 AV *defaults = _xclosure_defaults(aTHX_ cv);
652
653 if (defaults) {
654 types = *(av_fetch(defaults, 0, 1));
655 gen = *(av_fetch(defaults, 1, 1));
656 post = *(av_fetch(defaults, 2, 1));
657 if (!SvOK(post))
658 post = 0;
659 }
660
661 SP-=items;
662
663 if (!types || !SvOK(types)) {
664 if (items--)
665 types = ST(offset++);
666 else
667 croak("not enough arguments, packed multikey type descriptor required");
668 }
669 if (!gen || !SvOK(gen)) {
670 if (items--)
671 gen = ST(offset++);
672 else
673 croak("not enough arguments, reference to multikey generation subroutine required");
674 }
675
676 if(!(SvROK(gen) && SvTYPE(SvRV(gen))==SVt_PVCV))
677 croak("wrong argument type, subroutine reference required");
678
679 if (items != 1)
680 croak("not enough arguments, array reference required");
681
682 if (SvROK(ST(offset)) && SvTYPE(SvRV(ST(offset)))==SVt_PVAV)
683 values = (AV*)SvRV(ST(offset));
684 else croak("wrong argument type, array reference required");
685
686 if ((len=av_len(values)+1)) {
687 /* warn("ix=%d\n", ix); */
688 if (SvMAGICAL(values) || AvREIFY(values)) {
689 int i;
690 magic_values = values;
691 values = (AV*)sv_2mortal((SV*)newAV());
692 av_extend(values, len-1);
693 for (i=0; i<len; i++) {
694 SV **currentp = av_fetch(magic_values, i, 0);
695 av_store( values, i,
696 ( currentp
697 ? SvREFCNT_inc(*currentp)
698 : newSV(0) ) );
699 }
700 }
701
702 _multikeysort(aTHX_ types, gen, post, AvARRAY(values), 0, 0, len);
703
704 if (magic_values) {
705 int i;
706 SV **values_array = AvARRAY(values);
707 for(i=0; i<len; i++) {
708 SV *current = values_array[i];
709 if (!current) current = &PL_sv_undef;
710 if (!av_store(magic_values, i, SvREFCNT_inc(current)))
711 SvREFCNT_dec(current);
712 }
713 }
714 }
715 PUTBACK;
716 }
717
718
719 MODULE = Sort::Key PACKAGE = Sort::Key
720 PROTOTYPES: ENABLE
721
722 void
723 keysort(SV *keygen, ...)
724 PROTOTYPE: &@
725 ALIAS:
726 lkeysort = 1
727 nkeysort = 2
728 ikeysort = 3
729 ukeysort = 4
730 rkeysort = 128
731 rlkeysort = 129
732 rnkeysort = 130
733 rikeysort = 131
734 rukeysort = 132
735 PPCODE:
736 items--;
737 if (items) {
738 _keysort(aTHX_ ix, keygen, 0, 1, ax, items);
739 SPAGAIN;
740 SP = &ST(items-1);
741 }
742
743
744 void
745 keysort_inplace(SV *keygen, AV *values)
746 PROTOTYPE: &\@
747 PREINIT:
748 AV *magic_values=0;
749 int len;
750 ALIAS:
751 lkeysort_inplace = 1
752 nkeysort_inplace = 2
753 ikeysort_inplace = 3
754 ukeysort_inplace = 4
755 rkeysort_inplace = 128
756 rlkeysort_inplace = 129
757 rnkeysort_inplace = 130
758 rikeysort_inplace = 131
759 rukeysort_inplace = 132
760 PPCODE:
761 if ((len=av_len(values)+1)) {
762 /* warn("ix=%d\n", ix); */
763 if (SvMAGICAL(values) || AvREIFY(values)) {
764 int i;
765 magic_values = values;
766 values = (AV*)sv_2mortal((SV*)newAV());
767 av_extend(values, len-1);
768 for (i=0; i<len; i++) {
769 SV **currentp = av_fetch(magic_values, i, 0);
770 av_store( values, i,
771 ( currentp
772 ? SvREFCNT_inc(*currentp)
773 : newSV(0) ) );
774 }
775 }
776 _keysort(aTHX_ ix, keygen, AvARRAY(values), 0, 0, len);
777 SPAGAIN;
778 if (magic_values) {
779 int i;
780 SV **values_array = AvARRAY(values);
781 for(i=0; i<len; i++) {
782 SV *current = values_array[i];
783 if (!current) current = &PL_sv_undef;
784 if (!av_store(magic_values, i, SvREFCNT_inc(current)))
785 SvREFCNT_dec(current);
786 }
787 }
788 }
789
790 void
791 _sort(...)
792 PROTOTYPE: @
793 ALIAS:
794 lsort = 1
795 nsort = 2
796 isort = 3
797 usort = 4
798 rsort = 128
799 rlsort = 129
800 rnsort = 130
801 risort = 131
802 rusort = 132
803 PPCODE:
804 if (items) {
805 _keysort(aTHX_ ix, 0, 0, 0, ax, items);
806 SPAGAIN;
807 SP = &ST(items-1);
808 }
809
810 void
811 _sort_inplace(AV *values)
812 PROTOTYPE: \@
813 PREINIT:
814 AV *magic_values=0;
815 int len;
816 ALIAS:
817 lsort_inplace = 1
818 nsort_inplace = 2
819 isort_inplace = 3
820 usort_inplace = 4
821 rsort_inplace = 128
822 rlsort_inplace = 129
823 rnsort_inplace = 130
824 risort_inplace = 131
825 rusort_inplace = 132
826 PPCODE:
827 if ((len=av_len(values)+1)) {
828 /* warn("ix=%d\n", ix); */
829 if (SvMAGICAL(values) || AvREIFY(values)) {
830 int i;
831 magic_values = values;
832 values = (AV*)sv_2mortal((SV*)newAV());
833 av_extend(values, len-1);
834 for (i=0; i<len; i++) {
835 SV **currentp = av_fetch(magic_values, i, 0);
836 av_store( values, i,
837 ( currentp
838 ? SvREFCNT_inc(*currentp)
839 : newSV(0) ) );
840 }
841 }
842
843 _keysort(aTHX_ ix, 0, AvARRAY(values), 0, 0, len);
844 SPAGAIN;
845 if (magic_values) {
846 int i;
847 SV **values_array = AvARRAY(values);
848 for(i=0; i<len; i++) {
849 SV *current = values_array[i];
850 if (!current) current = &PL_sv_undef;
851 if (!av_store(magic_values, i, SvREFCNT_inc(current)))
852 SvREFCNT_dec(current);
853 }
854 }
855 }
856
857
858 PROTOTYPES: DISABLE
859
860 CV *
861 _multikeysorter(SV *types, SV *gen, SV *post)
862 PREINIT:
863 AV *defaults;
864 CODE:
865 if (!SvOK(types) || sv_len(types)<1)
866 croak("invalid packed types argument");
867 RETVAL = newXS(0, &XS_Sort__Key__multikeysort, __FILE__);
868 defaults = (AV*)sv_2mortal((SV*)newAV());
869 av_store(defaults, 0, newSVsv(types));
870 av_store(defaults, 1, newSVsv(gen));
871 av_store(defaults, 2, newSVsv(post));
872 _xclosure_make(aTHX_ RETVAL, defaults);
873 if (!SvOK(gen))
874 sv_setpv((SV*)RETVAL, "&@");
875 OUTPUT:
876 RETVAL
877
878 CV *
879 _multikeysorter_inplace(SV *types, SV *gen, SV *post)
880 PREINIT:
881 AV *defaults;
882 CODE:
883 if (!SvOK(types) || sv_len(types)<1)
884 croak("invalid packed types argument");
885 RETVAL = newXS(0, &XS_Sort__Key__multikeysort_inplace, __FILE__);
886 defaults = (AV*)sv_2mortal((SV*)newAV());
887 av_store(defaults, 0, newSVsv(types));
888 av_store(defaults, 1, newSVsv(gen));
889 av_store(defaults, 2, newSVsv(post));
890 _xclosure_make(aTHX_ RETVAL, defaults);
891 if (!SvOK(gen))
892 sv_setpv((SV*)RETVAL, "&\\@");
893 else
894 sv_setpv((SV*)RETVAL, "\\@");
895 OUTPUT:
896 RETVAL
897
898
899