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
|
/* $RCSfile: dolist.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:51 $
*
* Copyright (c) 1991, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* $Log: dolist.c,v $
* Revision 4.1 92/08/07 17:19:51 lwall
* Stage 6 Snapshot
*
* Revision 4.0.1.5 92/06/08 13:13:27 lwall
* patch20: g pattern modifer sometimes returned extra values
* patch20: m/$pattern/g didn't work
* patch20: pattern modifiers i and o didn't interact right
* patch20: @ in unpack failed too often
* patch20: Perl now distinguishes overlapped copies from non-overlapped
* patch20: slice on null list in scalar context returned random value
* patch20: splice with negative offset didn't work with $[ = 1
* patch20: fixed some memory leaks in splice
* patch20: scalar keys %array now counts keys for you
*
* Revision 4.0.1.4 91/11/11 16:33:19 lwall
* patch19: added little-endian pack/unpack options
* patch19: sort $subname was busted by changes in 4.018
*
* Revision 4.0.1.3 91/11/05 17:07:02 lwall
* patch11: prepared for ctype implementations that don't define isascii()
* patch11: /$foo/o optimizer could access deallocated data
* patch11: certain optimizations of //g in array context returned too many values
* patch11: regexp with no parens in array context returned wacky $`, $& and $'
* patch11: $' not set right on some //g
* patch11: added some support for 64-bit integers
* patch11: grep of a split lost its values
* patch11: added sort {} LIST
* patch11: multiple reallocations now avoided in 1 .. 100000
*
* Revision 4.0.1.2 91/06/10 01:22:15 lwall
* patch10: //g only worked first time through
*
* Revision 4.0.1.1 91/06/07 10:58:28 lwall
* patch4: new copyright notice
* patch4: added global modifier for pattern matches
* patch4: // wouldn't use previous pattern if it started with a null character
* patch4: //o and s///o now optimize themselves fully at runtime
* patch4: $` was busted inside s///
* patch4: caller($arg) didn't work except under debugger
*
* Revision 4.0 91/03/20 01:08:03 lwall
* 4.0 baseline.
*
*/
#include "EXTERN.h"
#include "perl.h"
#ifdef BUGGY_MSC
#pragma function(memcmp)
#endif /* BUGGY_MSC */
#ifdef BUGGY_MSC
#pragma intrinsic(memcmp)
#endif /* BUGGY_MSC */
OP *
do_kv(ARGS)
dARGS
{
dSP;
HV *hash = (HV*)POPs;
register AV *ary = stack;
I32 i;
register HE *entry;
char *tmps;
SV *tmpstr;
I32 dokeys = (op->op_type == OP_KEYS || op->op_type == OP_RV2HV);
I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
if (!hash)
RETURN;
if (GIMME != G_ARRAY) {
dTARGET;
i = 0;
(void)hv_iterinit(hash);
/*SUPPRESS 560*/
while (entry = hv_iternext(hash)) {
i++;
}
PUSHn( (double)i );
RETURN;
}
/* Guess how much room we need. hv_max may be a few too many. Oh well. */
EXTEND(sp, HvMAX(hash) * (dokeys + dovalues));
(void)hv_iterinit(hash);
/*SUPPRESS 560*/
while (entry = hv_iternext(hash)) {
if (dokeys) {
tmps = hv_iterkey(entry,&i);
if (!i)
tmps = "";
XPUSHs(sv_2mortal(newSVpv(tmps,i)));
}
if (dovalues) {
tmpstr = NEWSV(45,0);
sv_setsv(tmpstr,hv_iterval(hash,entry));
DEBUG_H( {
sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
HvMAX(hash)+1,entry->hent_hash & HvMAX(hash));
sv_setpv(tmpstr,buf);
} )
XPUSHs(sv_2mortal(tmpstr));
}
}
RETURN;
}
|
