perl 5.0 alpha 3
[perl.git] / dolist.c
1 /* $RCSfile: dolist.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:51 $
2  *
3  *    Copyright (c) 1991, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  * $Log:        dolist.c,v $
9  * Revision 4.1  92/08/07  17:19:51  lwall
10  * Stage 6 Snapshot
11  * 
12  * Revision 4.0.1.5  92/06/08  13:13:27  lwall
13  * patch20: g pattern modifer sometimes returned extra values
14  * patch20: m/$pattern/g didn't work
15  * patch20: pattern modifiers i and o didn't interact right
16  * patch20: @ in unpack failed too often
17  * patch20: Perl now distinguishes overlapped copies from non-overlapped
18  * patch20: slice on null list in scalar context returned random value
19  * patch20: splice with negative offset didn't work with $[ = 1
20  * patch20: fixed some memory leaks in splice
21  * patch20: scalar keys %array now counts keys for you
22  * 
23  * Revision 4.0.1.4  91/11/11  16:33:19  lwall
24  * patch19: added little-endian pack/unpack options
25  * patch19: sort $subname was busted by changes in 4.018
26  * 
27  * Revision 4.0.1.3  91/11/05  17:07:02  lwall
28  * patch11: prepared for ctype implementations that don't define isascii()
29  * patch11: /$foo/o optimizer could access deallocated data
30  * patch11: certain optimizations of //g in array context returned too many values
31  * patch11: regexp with no parens in array context returned wacky $`, $& and $'
32  * patch11: $' not set right on some //g
33  * patch11: added some support for 64-bit integers
34  * patch11: grep of a split lost its values
35  * patch11: added sort {} LIST
36  * patch11: multiple reallocations now avoided in 1 .. 100000
37  * 
38  * Revision 4.0.1.2  91/06/10  01:22:15  lwall
39  * patch10: //g only worked first time through
40  * 
41  * Revision 4.0.1.1  91/06/07  10:58:28  lwall
42  * patch4: new copyright notice
43  * patch4: added global modifier for pattern matches
44  * patch4: // wouldn't use previous pattern if it started with a null character
45  * patch4: //o and s///o now optimize themselves fully at runtime
46  * patch4: $` was busted inside s///
47  * patch4: caller($arg) didn't work except under debugger
48  * 
49  * Revision 4.0  91/03/20  01:08:03  lwall
50  * 4.0 baseline.
51  * 
52  */
53
54 #include "EXTERN.h"
55 #include "perl.h"
56
57 #ifdef BUGGY_MSC
58  #pragma function(memcmp)
59 #endif /* BUGGY_MSC */
60
61 #ifdef BUGGY_MSC
62  #pragma intrinsic(memcmp)
63 #endif /* BUGGY_MSC */
64
65 OP *
66 do_kv(ARGS)
67 dARGS
68 {
69     dSP;
70     HV *hash = (HV*)POPs;
71     register AV *ary = stack;
72     I32 i;
73     register HE *entry;
74     char *tmps;
75     SV *tmpstr;
76     I32 dokeys =   (op->op_type == OP_KEYS   || op->op_type == OP_RV2HV);
77     I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
78
79     if (!hash)
80         RETURN;
81     if (GIMME != G_ARRAY) {
82         dTARGET;
83
84         i = 0;
85         (void)hv_iterinit(hash);
86         /*SUPPRESS 560*/
87         while (entry = hv_iternext(hash)) {
88             i++;
89         }
90         PUSHn( (double)i );
91         RETURN;
92     }
93     /* Guess how much room we need.  hv_max may be a few too many.  Oh well. */
94     EXTEND(sp, HvMAX(hash) * (dokeys + dovalues));
95     (void)hv_iterinit(hash);
96     /*SUPPRESS 560*/
97     while (entry = hv_iternext(hash)) {
98         if (dokeys) {
99             tmps = hv_iterkey(entry,&i);
100             if (!i)
101                 tmps = "";
102             XPUSHs(sv_2mortal(newSVpv(tmps,i)));
103         }
104         if (dovalues) {
105             tmpstr = NEWSV(45,0);
106             sv_setsv(tmpstr,hv_iterval(hash,entry));
107             DEBUG_H( {
108                 sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
109                     HvMAX(hash)+1,entry->hent_hash & HvMAX(hash));
110                 sv_setpv(tmpstr,buf);
111             } )
112             XPUSHs(sv_2mortal(tmpstr));
113         }
114     }
115     RETURN;
116 }
117