home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / hv.c < prev    next >
C/C++ Source or Header  |  2000-03-04  |  35KB  |  1,508 lines
  1. /*    hv.c
  2.  *
  3.  *    Copyright (c) 1991-2000, 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.  */
  9.  
  10. /*
  11.  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  12.  */
  13.  
  14. #include "EXTERN.h"
  15. #define PERL_IN_HV_C
  16. #include "perl.h"
  17.  
  18. STATIC HE*
  19. S_new_he(pTHX)
  20. {
  21.     HE* he;
  22.     LOCK_SV_MUTEX;
  23.     if (!PL_he_root)
  24.         more_he();
  25.     he = PL_he_root;
  26.     PL_he_root = HeNEXT(he);
  27.     UNLOCK_SV_MUTEX;
  28.     return he;
  29. }
  30.  
  31. STATIC void
  32. S_del_he(pTHX_ HE *p)
  33. {
  34.     LOCK_SV_MUTEX;
  35.     HeNEXT(p) = (HE*)PL_he_root;
  36.     PL_he_root = p;
  37.     UNLOCK_SV_MUTEX;
  38. }
  39.  
  40. STATIC void
  41. S_more_he(pTHX)
  42. {
  43.     register HE* he;
  44.     register HE* heend;
  45.     New(54, PL_he_root, 1008/sizeof(HE), HE);
  46.     he = PL_he_root;
  47.     heend = &he[1008 / sizeof(HE) - 1];
  48.     while (he < heend) {
  49.         HeNEXT(he) = (HE*)(he + 1);
  50.         he++;
  51.     }
  52.     HeNEXT(he) = 0;
  53. }
  54.  
  55. #ifdef PURIFY
  56.  
  57. #define new_HE() (HE*)safemalloc(sizeof(HE))
  58. #define del_HE(p) safefree((char*)p)
  59.  
  60. #else
  61.  
  62. #define new_HE() new_he()
  63. #define del_HE(p) del_he(p)
  64.  
  65. #endif
  66.  
  67. STATIC HEK *
  68. S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
  69. {
  70.     char *k;
  71.     register HEK *hek;
  72.     
  73.     New(54, k, HEK_BASESIZE + len + 1, char);
  74.     hek = (HEK*)k;
  75.     Copy(str, HEK_KEY(hek), len, char);
  76.     *(HEK_KEY(hek) + len) = '\0';
  77.     HEK_LEN(hek) = len;
  78.     HEK_HASH(hek) = hash;
  79.     return hek;
  80. }
  81.  
  82. void
  83. Perl_unshare_hek(pTHX_ HEK *hek)
  84. {
  85.     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
  86. }
  87.  
  88. #if defined(USE_ITHREADS)
  89. HE *
  90. Perl_he_dup(pTHX_ HE *e, bool shared)
  91. {
  92.     HE *ret;
  93.  
  94.     if (!e)
  95.     return Nullhe;
  96.     /* look for it in the table first */
  97.     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
  98.     if (ret)
  99.     return ret;
  100.  
  101.     /* create anew and remember what it is */
  102.     ret = new_HE();
  103.     ptr_table_store(PL_ptr_table, e, ret);
  104.  
  105.     HeNEXT(ret) = he_dup(HeNEXT(e),shared);
  106.     if (HeKLEN(e) == HEf_SVKEY)
  107.     HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
  108.     else if (shared)
  109.     HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
  110.     else
  111.     HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
  112.     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
  113.     return ret;
  114. }
  115. #endif    /* USE_ITHREADS */
  116.  
  117. /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
  118.  * contains an SV* */
  119.  
  120. /*
  121. =for apidoc hv_fetch
  122.  
  123. Returns the SV which corresponds to the specified key in the hash.  The
  124. C<klen> is the length of the key.  If C<lval> is set then the fetch will be
  125. part of a store.  Check that the return value is non-null before
  126. dereferencing it to a C<SV*>. 
  127.  
  128. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
  129. information on how to use this function on tied hashes.
  130.  
  131. =cut
  132. */
  133.  
  134. SV**
  135. Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
  136. {
  137.     register XPVHV* xhv;
  138.     register U32 hash;
  139.     register HE *entry;
  140.     SV *sv;
  141.  
  142.     if (!hv)
  143.     return 0;
  144.  
  145.     if (SvRMAGICAL(hv)) {
  146.     if (mg_find((SV*)hv,'P')) {
  147.         dTHR;
  148.         sv = sv_newmortal();
  149.         mg_copy((SV*)hv, sv, key, klen);
  150.         PL_hv_fetch_sv = sv;
  151.         return &PL_hv_fetch_sv;
  152.     }
  153. #ifdef ENV_IS_CASELESS
  154.     else if (mg_find((SV*)hv,'E')) {
  155.         U32 i;
  156.         for (i = 0; i < klen; ++i)
  157.         if (isLOWER(key[i])) {
  158.             char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
  159.             SV **ret = hv_fetch(hv, nkey, klen, 0);
  160.             if (!ret && lval)
  161.             ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
  162.             return ret;
  163.         }
  164.     }
  165. #endif
  166.     }
  167.  
  168.     xhv = (XPVHV*)SvANY(hv);
  169.     if (!xhv->xhv_array) {
  170.     if (lval 
  171. #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
  172.              || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
  173. #endif
  174.                                                               )
  175.         Newz(503, xhv->xhv_array,
  176.          PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
  177.     else
  178.         return 0;
  179.     }
  180.  
  181.     PERL_HASH(hash, key, klen);
  182.  
  183.     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  184.     for (; entry; entry = HeNEXT(entry)) {
  185.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  186.         continue;
  187.     if (HeKLEN(entry) != klen)
  188.         continue;
  189.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  190.         continue;
  191.     return &HeVAL(entry);
  192.     }
  193. #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
  194.     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
  195.     unsigned long len;
  196.     char *env = PerlEnv_ENVgetenv_len(key,&len);
  197.     if (env) {
  198.         sv = newSVpvn(env,len);
  199.         SvTAINTED_on(sv);
  200.         return hv_store(hv,key,klen,sv,hash);
  201.     }
  202.     }
  203. #endif
  204.     if (lval) {        /* gonna assign to this, so it better be there */
  205.     sv = NEWSV(61,0);
  206.     return hv_store(hv,key,klen,sv,hash);
  207.     }
  208.     return 0;
  209. }
  210.  
  211. /* returns a HE * structure with the all fields set */
  212. /* note that hent_val will be a mortal sv for MAGICAL hashes */
  213. /*
  214. =for apidoc hv_fetch_ent
  215.  
  216. Returns the hash entry which corresponds to the specified key in the hash.
  217. C<hash> must be a valid precomputed hash number for the given C<key>, or 0
  218. if you want the function to compute it.  IF C<lval> is set then the fetch
  219. will be part of a store.  Make sure the return value is non-null before
  220. accessing it.  The return value when C<tb> is a tied hash is a pointer to a
  221. static location, so be sure to make a copy of the structure if you need to
  222. store it somewhere. 
  223.  
  224. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
  225. information on how to use this function on tied hashes.
  226.  
  227. =cut
  228. */
  229.  
  230. HE *
  231. Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
  232. {
  233.     register XPVHV* xhv;
  234.     register char *key;
  235.     STRLEN klen;
  236.     register HE *entry;
  237.     SV *sv;
  238.  
  239.     if (!hv)
  240.     return 0;
  241.  
  242.     if (SvRMAGICAL(hv)) {
  243.     if (mg_find((SV*)hv,'P')) {
  244.         dTHR;
  245.         sv = sv_newmortal();
  246.         keysv = sv_2mortal(newSVsv(keysv));
  247.         mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
  248.         if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
  249.         char *k;
  250.         New(54, k, HEK_BASESIZE + sizeof(SV*), char);
  251.         HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
  252.         }
  253.         HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
  254.         HeVAL(&PL_hv_fetch_ent_mh) = sv;
  255.         return &PL_hv_fetch_ent_mh;
  256.     }
  257. #ifdef ENV_IS_CASELESS
  258.     else if (mg_find((SV*)hv,'E')) {
  259.         U32 i;
  260.         key = SvPV(keysv, klen);
  261.         for (i = 0; i < klen; ++i)
  262.         if (isLOWER(key[i])) {
  263.             SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
  264.             (void)strupr(SvPVX(nkeysv));
  265.             entry = hv_fetch_ent(hv, nkeysv, 0, 0);
  266.             if (!entry && lval)
  267.             entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
  268.             return entry;
  269.         }
  270.     }
  271. #endif
  272.     }
  273.  
  274.     xhv = (XPVHV*)SvANY(hv);
  275.     if (!xhv->xhv_array) {
  276.     if (lval 
  277. #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
  278.              || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
  279. #endif
  280.                                                               )
  281.         Newz(503, xhv->xhv_array,
  282.          PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
  283.     else
  284.         return 0;
  285.     }
  286.  
  287.     key = SvPV(keysv, klen);
  288.     
  289.     if (!hash)
  290.     PERL_HASH(hash, key, klen);
  291.  
  292.     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  293.     for (; entry; entry = HeNEXT(entry)) {
  294.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  295.         continue;
  296.     if (HeKLEN(entry) != klen)
  297.         continue;
  298.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  299.         continue;
  300.     return entry;
  301.     }
  302. #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
  303.     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
  304.     unsigned long len;
  305.     char *env = PerlEnv_ENVgetenv_len(key,&len);
  306.     if (env) {
  307.         sv = newSVpvn(env,len);
  308.         SvTAINTED_on(sv);
  309.         return hv_store_ent(hv,keysv,sv,hash);
  310.     }
  311.     }
  312. #endif
  313.     if (lval) {        /* gonna assign to this, so it better be there */
  314.     sv = NEWSV(61,0);
  315.     return hv_store_ent(hv,keysv,sv,hash);
  316.     }
  317.     return 0;
  318. }
  319.  
  320. STATIC void
  321. S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
  322. {
  323.     MAGIC *mg = SvMAGIC(hv);
  324.     *needs_copy = FALSE;
  325.     *needs_store = TRUE;
  326.     while (mg) {
  327.     if (isUPPER(mg->mg_type)) {
  328.         *needs_copy = TRUE;
  329.         switch (mg->mg_type) {
  330.         case 'P':
  331.         case 'S':
  332.         *needs_store = FALSE;
  333.         }
  334.     }
  335.     mg = mg->mg_moremagic;
  336.     }
  337. }
  338.  
  339. /*
  340. =for apidoc hv_store
  341.  
  342. Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
  343. the length of the key.  The C<hash> parameter is the precomputed hash
  344. value; if it is zero then Perl will compute it.  The return value will be
  345. NULL if the operation failed or if the value did not need to be actually
  346. stored within the hash (as in the case of tied hashes).  Otherwise it can
  347. be dereferenced to get the original C<SV*>.  Note that the caller is
  348. responsible for suitably incrementing the reference count of C<val> before
  349. the call, and decrementing it if the function returned NULL.  
  350.  
  351. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
  352. information on how to use this function on tied hashes.
  353.  
  354. =cut
  355. */
  356.  
  357. SV**
  358. Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
  359. {
  360.     register XPVHV* xhv;
  361.     register I32 i;
  362.     register HE *entry;
  363.     register HE **oentry;
  364.  
  365.     if (!hv)
  366.     return 0;
  367.  
  368.     xhv = (XPVHV*)SvANY(hv);
  369.     if (SvMAGICAL(hv)) {
  370.     bool needs_copy;
  371.     bool needs_store;
  372.     hv_magic_check (hv, &needs_copy, &needs_store);
  373.     if (needs_copy) {
  374.         mg_copy((SV*)hv, val, key, klen);
  375.         if (!xhv->xhv_array && !needs_store)
  376.         return 0;
  377. #ifdef ENV_IS_CASELESS
  378.         else if (mg_find((SV*)hv,'E')) {
  379.         SV *sv = sv_2mortal(newSVpvn(key,klen));
  380.         key = strupr(SvPVX(sv));
  381.         hash = 0;
  382.         }
  383. #endif
  384.     }
  385.     }
  386.     if (!hash)
  387.     PERL_HASH(hash, key, klen);
  388.  
  389.     if (!xhv->xhv_array)
  390.     Newz(505, xhv->xhv_array,
  391.          PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
  392.  
  393.     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  394.     i = 1;
  395.  
  396.     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
  397.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  398.         continue;
  399.     if (HeKLEN(entry) != klen)
  400.         continue;
  401.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  402.         continue;
  403.     SvREFCNT_dec(HeVAL(entry));
  404.     HeVAL(entry) = val;
  405.     return &HeVAL(entry);
  406.     }
  407.  
  408.     entry = new_HE();
  409.     if (HvSHAREKEYS(hv))
  410.     HeKEY_hek(entry) = share_hek(key, klen, hash);
  411.     else                                       /* gotta do the real thing */
  412.     HeKEY_hek(entry) = save_hek(key, klen, hash);
  413.     HeVAL(entry) = val;
  414.     HeNEXT(entry) = *oentry;
  415.     *oentry = entry;
  416.  
  417.     xhv->xhv_keys++;
  418.     if (i) {                /* initial entry? */
  419.     ++xhv->xhv_fill;
  420.     if (xhv->xhv_keys > xhv->xhv_max)
  421.         hsplit(hv);
  422.     }
  423.  
  424.     return &HeVAL(entry);
  425. }
  426.  
  427. /*
  428. =for apidoc hv_store_ent
  429.  
  430. Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
  431. parameter is the precomputed hash value; if it is zero then Perl will
  432. compute it.  The return value is the new hash entry so created.  It will be
  433. NULL if the operation failed or if the value did not need to be actually
  434. stored within the hash (as in the case of tied hashes).  Otherwise the
  435. contents of the return value can be accessed using the C<He???> macros
  436. described here.  Note that the caller is responsible for suitably
  437. incrementing the reference count of C<val> before the call, and
  438. decrementing it if the function returned NULL. 
  439.  
  440. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
  441. information on how to use this function on tied hashes.
  442.  
  443. =cut
  444. */
  445.  
  446. HE *
  447. Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
  448. {
  449.     register XPVHV* xhv;
  450.     register char *key;
  451.     STRLEN klen;
  452.     register I32 i;
  453.     register HE *entry;
  454.     register HE **oentry;
  455.  
  456.     if (!hv)
  457.     return 0;
  458.  
  459.     xhv = (XPVHV*)SvANY(hv);
  460.     if (SvMAGICAL(hv)) {
  461.     dTHR;
  462.      bool needs_copy;
  463.      bool needs_store;
  464.      hv_magic_check (hv, &needs_copy, &needs_store);
  465.      if (needs_copy) {
  466.          bool save_taint = PL_tainted;
  467.          if (PL_tainting)
  468.          PL_tainted = SvTAINTED(keysv);
  469.          keysv = sv_2mortal(newSVsv(keysv));
  470.          mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
  471.          TAINT_IF(save_taint);
  472.          if (!xhv->xhv_array && !needs_store)
  473.          return Nullhe;
  474. #ifdef ENV_IS_CASELESS
  475.         else if (mg_find((SV*)hv,'E')) {
  476.         key = SvPV(keysv, klen);
  477.         keysv = sv_2mortal(newSVpvn(key,klen));
  478.         (void)strupr(SvPVX(keysv));
  479.         hash = 0;
  480.         }
  481. #endif
  482.     }
  483.     }
  484.  
  485.     key = SvPV(keysv, klen);
  486.  
  487.     if (!hash)
  488.     PERL_HASH(hash, key, klen);
  489.  
  490.     if (!xhv->xhv_array)
  491.     Newz(505, xhv->xhv_array,
  492.          PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
  493.  
  494.     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  495.     i = 1;
  496.  
  497.     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
  498.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  499.         continue;
  500.     if (HeKLEN(entry) != klen)
  501.         continue;
  502.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  503.         continue;
  504.     SvREFCNT_dec(HeVAL(entry));
  505.     HeVAL(entry) = val;
  506.     return entry;
  507.     }
  508.  
  509.     entry = new_HE();
  510.     if (HvSHAREKEYS(hv))
  511.     HeKEY_hek(entry) = share_hek(key, klen, hash);
  512.     else                                       /* gotta do the real thing */
  513.     HeKEY_hek(entry) = save_hek(key, klen, hash);
  514.     HeVAL(entry) = val;
  515.     HeNEXT(entry) = *oentry;
  516.     *oentry = entry;
  517.  
  518.     xhv->xhv_keys++;
  519.     if (i) {                /* initial entry? */
  520.     ++xhv->xhv_fill;
  521.     if (xhv->xhv_keys > xhv->xhv_max)
  522.         hsplit(hv);
  523.     }
  524.  
  525.     return entry;
  526. }
  527.  
  528. /*
  529. =for apidoc hv_delete
  530.  
  531. Deletes a key/value pair in the hash.  The value SV is removed from the
  532. hash and returned to the caller.  The C<klen> is the length of the key. 
  533. The C<flags> value will normally be zero; if set to G_DISCARD then NULL
  534. will be returned.
  535.  
  536. =cut
  537. */
  538.  
  539. SV *
  540. Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
  541. {
  542.     register XPVHV* xhv;
  543.     register I32 i;
  544.     register U32 hash;
  545.     register HE *entry;
  546.     register HE **oentry;
  547.     SV **svp;
  548.     SV *sv;
  549.  
  550.     if (!hv)
  551.     return Nullsv;
  552.     if (SvRMAGICAL(hv)) {
  553.     bool needs_copy;
  554.     bool needs_store;
  555.     hv_magic_check (hv, &needs_copy, &needs_store);
  556.  
  557.     if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
  558.         sv = *svp;
  559.         mg_clear(sv);
  560.         if (!needs_store) {
  561.         if (mg_find(sv, 'p')) {
  562.             sv_unmagic(sv, 'p');        /* No longer an element */
  563.             return sv;
  564.         }
  565.         return Nullsv;          /* element cannot be deleted */
  566.         }
  567. #ifdef ENV_IS_CASELESS
  568.         else if (mg_find((SV*)hv,'E')) {
  569.         sv = sv_2mortal(newSVpvn(key,klen));
  570.         key = strupr(SvPVX(sv));
  571.         }
  572. #endif
  573.         }
  574.     }
  575.     xhv = (XPVHV*)SvANY(hv);
  576.     if (!xhv->xhv_array)
  577.     return Nullsv;
  578.  
  579.     PERL_HASH(hash, key, klen);
  580.  
  581.     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  582.     entry = *oentry;
  583.     i = 1;
  584.     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
  585.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  586.         continue;
  587.     if (HeKLEN(entry) != klen)
  588.         continue;
  589.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  590.         continue;
  591.     *oentry = HeNEXT(entry);
  592.     if (i && !*oentry)
  593.         xhv->xhv_fill--;
  594.     if (flags & G_DISCARD)
  595.         sv = Nullsv;
  596.     else {
  597.         sv = sv_2mortal(HeVAL(entry));
  598.         HeVAL(entry) = &PL_sv_undef;
  599.     }
  600.     if (entry == xhv->xhv_eiter)
  601.         HvLAZYDEL_on(hv);
  602.     else
  603.         hv_free_ent(hv, entry);
  604.     --xhv->xhv_keys;
  605.     return sv;
  606.     }
  607.     return Nullsv;
  608. }
  609.  
  610. /*
  611. =for apidoc hv_delete_ent
  612.  
  613. Deletes a key/value pair in the hash.  The value SV is removed from the
  614. hash and returned to the caller.  The C<flags> value will normally be zero;
  615. if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
  616. precomputed hash value, or 0 to ask for it to be computed.
  617.  
  618. =cut
  619. */
  620.  
  621. SV *
  622. Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
  623. {
  624.     register XPVHV* xhv;
  625.     register I32 i;
  626.     register char *key;
  627.     STRLEN klen;
  628.     register HE *entry;
  629.     register HE **oentry;
  630.     SV *sv;
  631.     
  632.     if (!hv)
  633.     return Nullsv;
  634.     if (SvRMAGICAL(hv)) {
  635.     bool needs_copy;
  636.     bool needs_store;
  637.     hv_magic_check (hv, &needs_copy, &needs_store);
  638.  
  639.     if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
  640.         sv = HeVAL(entry);
  641.         mg_clear(sv);
  642.         if (!needs_store) {
  643.         if (mg_find(sv, 'p')) {
  644.             sv_unmagic(sv, 'p');    /* No longer an element */
  645.             return sv;
  646.         }        
  647.         return Nullsv;        /* element cannot be deleted */
  648.         }
  649. #ifdef ENV_IS_CASELESS
  650.         else if (mg_find((SV*)hv,'E')) {
  651.         key = SvPV(keysv, klen);
  652.         keysv = sv_2mortal(newSVpvn(key,klen));
  653.         (void)strupr(SvPVX(keysv));
  654.         hash = 0; 
  655.         }
  656. #endif
  657.     }
  658.     }
  659.     xhv = (XPVHV*)SvANY(hv);
  660.     if (!xhv->xhv_array)
  661.     return Nullsv;
  662.  
  663.     key = SvPV(keysv, klen);
  664.     
  665.     if (!hash)
  666.     PERL_HASH(hash, key, klen);
  667.  
  668.     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  669.     entry = *oentry;
  670.     i = 1;
  671.     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
  672.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  673.         continue;
  674.     if (HeKLEN(entry) != klen)
  675.         continue;
  676.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  677.         continue;
  678.     *oentry = HeNEXT(entry);
  679.     if (i && !*oentry)
  680.         xhv->xhv_fill--;
  681.     if (flags & G_DISCARD)
  682.         sv = Nullsv;
  683.     else {
  684.         sv = sv_2mortal(HeVAL(entry));
  685.         HeVAL(entry) = &PL_sv_undef;
  686.     }
  687.     if (entry == xhv->xhv_eiter)
  688.         HvLAZYDEL_on(hv);
  689.     else
  690.         hv_free_ent(hv, entry);
  691.     --xhv->xhv_keys;
  692.     return sv;
  693.     }
  694.     return Nullsv;
  695. }
  696.  
  697. /*
  698. =for apidoc hv_exists
  699.  
  700. Returns a boolean indicating whether the specified hash key exists.  The
  701. C<klen> is the length of the key.
  702.  
  703. =cut
  704. */
  705.  
  706. bool
  707. Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
  708. {
  709.     register XPVHV* xhv;
  710.     register U32 hash;
  711.     register HE *entry;
  712.     SV *sv;
  713.  
  714.     if (!hv)
  715.     return 0;
  716.  
  717.     if (SvRMAGICAL(hv)) {
  718.     if (mg_find((SV*)hv,'P')) {
  719.         dTHR;
  720.         sv = sv_newmortal();
  721.         mg_copy((SV*)hv, sv, key, klen); 
  722.         magic_existspack(sv, mg_find(sv, 'p'));
  723.         return SvTRUE(sv);
  724.     }
  725. #ifdef ENV_IS_CASELESS
  726.     else if (mg_find((SV*)hv,'E')) {
  727.         sv = sv_2mortal(newSVpvn(key,klen));
  728.         key = strupr(SvPVX(sv));
  729.     }
  730. #endif
  731.     }
  732.  
  733.     xhv = (XPVHV*)SvANY(hv);
  734. #ifndef DYNAMIC_ENV_FETCH
  735.     if (!xhv->xhv_array)
  736.     return 0; 
  737. #endif
  738.  
  739.     PERL_HASH(hash, key, klen);
  740.  
  741. #ifdef DYNAMIC_ENV_FETCH
  742.     if (!xhv->xhv_array) entry = Null(HE*);
  743.     else
  744. #endif
  745.     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  746.     for (; entry; entry = HeNEXT(entry)) {
  747.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  748.         continue;
  749.     if (HeKLEN(entry) != klen)
  750.         continue;
  751.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  752.         continue;
  753.     return TRUE;
  754.     }
  755. #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
  756.     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
  757.     unsigned long len;
  758.     char *env = PerlEnv_ENVgetenv_len(key,&len);
  759.     if (env) {
  760.         sv = newSVpvn(env,len);
  761.         SvTAINTED_on(sv);
  762.         (void)hv_store(hv,key,klen,sv,hash);
  763.         return TRUE;
  764.     }
  765.     }
  766. #endif
  767.     return FALSE;
  768. }
  769.  
  770.  
  771. /*
  772. =for apidoc hv_exists_ent
  773.  
  774. Returns a boolean indicating whether the specified hash key exists. C<hash>
  775. can be a valid precomputed hash value, or 0 to ask for it to be
  776. computed.
  777.  
  778. =cut
  779. */
  780.  
  781. bool
  782. Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
  783. {
  784.     register XPVHV* xhv;
  785.     register char *key;
  786.     STRLEN klen;
  787.     register HE *entry;
  788.     SV *sv;
  789.  
  790.     if (!hv)
  791.     return 0;
  792.  
  793.     if (SvRMAGICAL(hv)) {
  794.     if (mg_find((SV*)hv,'P')) {
  795.         dTHR;        /* just for SvTRUE */
  796.         sv = sv_newmortal();
  797.         keysv = sv_2mortal(newSVsv(keysv));
  798.         mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); 
  799.         magic_existspack(sv, mg_find(sv, 'p'));
  800.         return SvTRUE(sv);
  801.     }
  802. #ifdef ENV_IS_CASELESS
  803.     else if (mg_find((SV*)hv,'E')) {
  804.         key = SvPV(keysv, klen);
  805.         keysv = sv_2mortal(newSVpvn(key,klen));
  806.         (void)strupr(SvPVX(keysv));
  807.         hash = 0; 
  808.     }
  809. #endif
  810.     }
  811.  
  812.     xhv = (XPVHV*)SvANY(hv);
  813. #ifndef DYNAMIC_ENV_FETCH
  814.     if (!xhv->xhv_array)
  815.     return 0; 
  816. #endif
  817.  
  818.     key = SvPV(keysv, klen);
  819.     if (!hash)
  820.     PERL_HASH(hash, key, klen);
  821.  
  822. #ifdef DYNAMIC_ENV_FETCH
  823.     if (!xhv->xhv_array) entry = Null(HE*);
  824.     else
  825. #endif
  826.     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  827.     for (; entry; entry = HeNEXT(entry)) {
  828.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  829.         continue;
  830.     if (HeKLEN(entry) != klen)
  831.         continue;
  832.     if (memNE(HeKEY(entry),key,klen))    /* is this it? */
  833.         continue;
  834.     return TRUE;
  835.     }
  836. #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
  837.     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
  838.     unsigned long len;
  839.     char *env = PerlEnv_ENVgetenv_len(key,&len);
  840.     if (env) {
  841.         sv = newSVpvn(env,len);
  842.         SvTAINTED_on(sv);
  843.         (void)hv_store_ent(hv,keysv,sv,hash);
  844.         return TRUE;
  845.     }
  846.     }
  847. #endif
  848.     return FALSE;
  849. }
  850.  
  851. STATIC void
  852. S_hsplit(pTHX_ HV *hv)
  853. {
  854.     register XPVHV* xhv = (XPVHV*)SvANY(hv);
  855.     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
  856.     register I32 newsize = oldsize * 2;
  857.     register I32 i;
  858.     register char *a = xhv->xhv_array;
  859.     register HE **aep;
  860.     register HE **bep;
  861.     register HE *entry;
  862.     register HE **oentry;
  863.  
  864.     PL_nomemok = TRUE;
  865. #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
  866.     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
  867.     if (!a) {
  868.       PL_nomemok = FALSE;
  869.       return;
  870.     }
  871. #else
  872. #define MALLOC_OVERHEAD 16
  873.     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
  874.     if (!a) {
  875.       PL_nomemok = FALSE;
  876.       return;
  877.     }
  878.     Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
  879.     if (oldsize >= 64) {
  880.     offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
  881.     }
  882.     else
  883.     Safefree(xhv->xhv_array);
  884. #endif
  885.  
  886.     PL_nomemok = FALSE;
  887.     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);    /* zero 2nd half*/
  888.     xhv->xhv_max = --newsize;
  889.     xhv->xhv_array = a;
  890.     aep = (HE**)a;
  891.  
  892.     for (i=0; i<oldsize; i++,aep++) {
  893.     if (!*aep)                /* non-existent */
  894.         continue;
  895.     bep = aep+oldsize;
  896.     for (oentry = aep, entry = *aep; entry; entry = *oentry) {
  897.         if ((HeHASH(entry) & newsize) != i) {
  898.         *oentry = HeNEXT(entry);
  899.         HeNEXT(entry) = *bep;
  900.         if (!*bep)
  901.             xhv->xhv_fill++;
  902.         *bep = entry;
  903.         continue;
  904.         }
  905.         else
  906.         oentry = &HeNEXT(entry);
  907.     }
  908.     if (!*aep)                /* everything moved */
  909.         xhv->xhv_fill--;
  910.     }
  911. }
  912.  
  913. void
  914. Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
  915. {
  916.     register XPVHV* xhv = (XPVHV*)SvANY(hv);
  917.     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
  918.     register I32 newsize;
  919.     register I32 i;
  920.     register I32 j;
  921.     register char *a;
  922.     register HE **aep;
  923.     register HE *entry;
  924.     register HE **oentry;
  925.  
  926.     newsize = (I32) newmax;            /* possible truncation here */
  927.     if (newsize != newmax || newmax <= oldsize)
  928.     return;
  929.     while ((newsize & (1 + ~newsize)) != newsize) {
  930.     newsize &= ~(newsize & (1 + ~newsize));    /* get proper power of 2 */
  931.     }
  932.     if (newsize < newmax)
  933.     newsize *= 2;
  934.     if (newsize < newmax)
  935.     return;                    /* overflow detection */
  936.  
  937.     a = xhv->xhv_array;
  938.     if (a) {
  939.     PL_nomemok = TRUE;
  940. #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
  941.     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
  942.         if (!a) {
  943.       PL_nomemok = FALSE;
  944.       return;
  945.     }
  946. #else
  947.     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
  948.         if (!a) {
  949.       PL_nomemok = FALSE;
  950.       return;
  951.     }
  952.     Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
  953.     if (oldsize >= 64) {
  954.         offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
  955.     }
  956.     else
  957.         Safefree(xhv->xhv_array);
  958. #endif
  959.     PL_nomemok = FALSE;
  960.     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
  961.     }
  962.     else {
  963.     Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
  964.     }
  965.     xhv->xhv_max = --newsize;
  966.     xhv->xhv_array = a;
  967.     if (!xhv->xhv_fill)                /* skip rest if no entries */
  968.     return;
  969.  
  970.     aep = (HE**)a;
  971.     for (i=0; i<oldsize; i++,aep++) {
  972.     if (!*aep)                /* non-existent */
  973.         continue;
  974.     for (oentry = aep, entry = *aep; entry; entry = *oentry) {
  975.         if ((j = (HeHASH(entry) & newsize)) != i) {
  976.         j -= i;
  977.         *oentry = HeNEXT(entry);
  978.         if (!(HeNEXT(entry) = aep[j]))
  979.             xhv->xhv_fill++;
  980.         aep[j] = entry;
  981.         continue;
  982.         }
  983.         else
  984.         oentry = &HeNEXT(entry);
  985.     }
  986.     if (!*aep)                /* everything moved */
  987.         xhv->xhv_fill--;
  988.     }
  989. }
  990.  
  991. /*
  992. =for apidoc newHV
  993.  
  994. Creates a new HV.  The reference count is set to 1.
  995.  
  996. =cut
  997. */
  998.  
  999. HV *
  1000. Perl_newHV(pTHX)
  1001. {
  1002.     register HV *hv;
  1003.     register XPVHV* xhv;
  1004.  
  1005.     hv = (HV*)NEWSV(502,0);
  1006.     sv_upgrade((SV *)hv, SVt_PVHV);
  1007.     xhv = (XPVHV*)SvANY(hv);
  1008.     SvPOK_off(hv);
  1009.     SvNOK_off(hv);
  1010. #ifndef NODEFAULT_SHAREKEYS    
  1011.     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
  1012. #endif    
  1013.     xhv->xhv_max = 7;        /* start with 8 buckets */
  1014.     xhv->xhv_fill = 0;
  1015.     xhv->xhv_pmroot = 0;
  1016.     (void)hv_iterinit(hv);    /* so each() will start off right */
  1017.     return hv;
  1018. }
  1019.  
  1020. HV *
  1021. Perl_newHVhv(pTHX_ HV *ohv)
  1022. {
  1023.     register HV *hv;
  1024.     STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
  1025.     STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
  1026.  
  1027.     hv = newHV();
  1028.     while (hv_max && hv_max + 1 >= hv_fill * 2)
  1029.     hv_max = hv_max / 2;    /* Is always 2^n-1 */
  1030.     HvMAX(hv) = hv_max;
  1031.     if (!hv_fill)
  1032.     return hv;
  1033.  
  1034. #if 0
  1035.     if (! SvTIED_mg((SV*)ohv, 'P')) {
  1036.     /* Quick way ???*/
  1037.     } 
  1038.     else 
  1039. #endif
  1040.     {
  1041.     HE *entry;
  1042.     I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
  1043.     HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
  1044.     
  1045.     /* Slow way */
  1046.     hv_iterinit(ohv);
  1047.     while ((entry = hv_iternext(ohv))) {
  1048.         hv_store(hv, HeKEY(entry), HeKLEN(entry), 
  1049.              SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
  1050.     }
  1051.     HvRITER(ohv) = hv_riter;
  1052.     HvEITER(ohv) = hv_eiter;
  1053.     }
  1054.     
  1055.     return hv;
  1056. }
  1057.  
  1058. void
  1059. Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
  1060. {
  1061.     SV *val;
  1062.  
  1063.     if (!entry)
  1064.     return;
  1065.     val = HeVAL(entry);
  1066.     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
  1067.     PL_sub_generation++;    /* may be deletion of method from stash */
  1068.     SvREFCNT_dec(val);
  1069.     if (HeKLEN(entry) == HEf_SVKEY) {
  1070.     SvREFCNT_dec(HeKEY_sv(entry));
  1071.         Safefree(HeKEY_hek(entry));
  1072.     }
  1073.     else if (HvSHAREKEYS(hv))
  1074.     unshare_hek(HeKEY_hek(entry));
  1075.     else
  1076.     Safefree(HeKEY_hek(entry));
  1077.     del_HE(entry);
  1078. }
  1079.  
  1080. void
  1081. Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
  1082. {
  1083.     if (!entry)
  1084.     return;
  1085.     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
  1086.     PL_sub_generation++;    /* may be deletion of method from stash */
  1087.     sv_2mortal(HeVAL(entry));    /* free between statements */
  1088.     if (HeKLEN(entry) == HEf_SVKEY) {
  1089.     sv_2mortal(HeKEY_sv(entry));
  1090.     Safefree(HeKEY_hek(entry));
  1091.     }
  1092.     else if (HvSHAREKEYS(hv))
  1093.     unshare_hek(HeKEY_hek(entry));
  1094.     else
  1095.     Safefree(HeKEY_hek(entry));
  1096.     del_HE(entry);
  1097. }
  1098.  
  1099. /*
  1100. =for apidoc hv_clear
  1101.  
  1102. Clears a hash, making it empty.
  1103.  
  1104. =cut
  1105. */
  1106.  
  1107. void
  1108. Perl_hv_clear(pTHX_ HV *hv)
  1109. {
  1110.     register XPVHV* xhv;
  1111.     if (!hv)
  1112.     return;
  1113.     xhv = (XPVHV*)SvANY(hv);
  1114.     hfreeentries(hv);
  1115.     xhv->xhv_fill = 0;
  1116.     xhv->xhv_keys = 0;
  1117.     if (xhv->xhv_array)
  1118.     (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
  1119.  
  1120.     if (SvRMAGICAL(hv))
  1121.     mg_clear((SV*)hv); 
  1122. }
  1123.  
  1124. STATIC void
  1125. S_hfreeentries(pTHX_ HV *hv)
  1126. {
  1127.     register HE **array;
  1128.     register HE *entry;
  1129.     register HE *oentry = Null(HE*);
  1130.     I32 riter;
  1131.     I32 max;
  1132.  
  1133.     if (!hv)
  1134.     return;
  1135.     if (!HvARRAY(hv))
  1136.     return;
  1137.  
  1138.     riter = 0;
  1139.     max = HvMAX(hv);
  1140.     array = HvARRAY(hv);
  1141.     entry = array[0];
  1142.     for (;;) {
  1143.     if (entry) {
  1144.         oentry = entry;
  1145.         entry = HeNEXT(entry);
  1146.         hv_free_ent(hv, oentry);
  1147.     }
  1148.     if (!entry) {
  1149.         if (++riter > max)
  1150.         break;
  1151.         entry = array[riter];
  1152.     } 
  1153.     }
  1154.     (void)hv_iterinit(hv);
  1155. }
  1156.  
  1157. /*
  1158. =for apidoc hv_undef
  1159.  
  1160. Undefines the hash.
  1161.  
  1162. =cut
  1163. */
  1164.  
  1165. void
  1166. Perl_hv_undef(pTHX_ HV *hv)
  1167. {
  1168.     register XPVHV* xhv;
  1169.     if (!hv)
  1170.     return;
  1171.     xhv = (XPVHV*)SvANY(hv);
  1172.     hfreeentries(hv);
  1173.     Safefree(xhv->xhv_array);
  1174.     if (HvNAME(hv)) {
  1175.     Safefree(HvNAME(hv));
  1176.     HvNAME(hv) = 0;
  1177.     }
  1178.     xhv->xhv_array = 0;
  1179.     xhv->xhv_max = 7;        /* it's a normal hash */
  1180.     xhv->xhv_fill = 0;
  1181.     xhv->xhv_keys = 0;
  1182.  
  1183.     if (SvRMAGICAL(hv))
  1184.     mg_clear((SV*)hv); 
  1185. }
  1186.  
  1187. /*
  1188. =for apidoc hv_iterinit
  1189.  
  1190. Prepares a starting point to traverse a hash table.  Returns the number of
  1191. keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
  1192. currently only meaningful for hashes without tie magic. 
  1193.  
  1194. NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
  1195. hash buckets that happen to be in use.  If you still need that esoteric
  1196. value, you can get it through the macro C<HvFILL(tb)>.
  1197.  
  1198. =cut
  1199. */
  1200.  
  1201. I32
  1202. Perl_hv_iterinit(pTHX_ HV *hv)
  1203. {
  1204.     register XPVHV* xhv;
  1205.     HE *entry;
  1206.  
  1207.     if (!hv)
  1208.     Perl_croak(aTHX_ "Bad hash");
  1209.     xhv = (XPVHV*)SvANY(hv);
  1210.     entry = xhv->xhv_eiter;
  1211.     if (entry && HvLAZYDEL(hv)) {    /* was deleted earlier? */
  1212.     HvLAZYDEL_off(hv);
  1213.     hv_free_ent(hv, entry);
  1214.     }
  1215.     xhv->xhv_riter = -1;
  1216.     xhv->xhv_eiter = Null(HE*);
  1217.     return xhv->xhv_keys;    /* used to be xhv->xhv_fill before 5.004_65 */
  1218. }
  1219.  
  1220. /*
  1221. =for apidoc hv_iternext
  1222.  
  1223. Returns entries from a hash iterator.  See C<hv_iterinit>.
  1224.  
  1225. =cut
  1226. */
  1227.  
  1228. HE *
  1229. Perl_hv_iternext(pTHX_ HV *hv)
  1230. {
  1231.     register XPVHV* xhv;
  1232.     register HE *entry;
  1233.     HE *oldentry;
  1234.     MAGIC* mg;
  1235.  
  1236.     if (!hv)
  1237.     Perl_croak(aTHX_ "Bad hash");
  1238.     xhv = (XPVHV*)SvANY(hv);
  1239.     oldentry = entry = xhv->xhv_eiter;
  1240.  
  1241.     if ((mg = SvTIED_mg((SV*)hv, 'P'))) {
  1242.     SV *key = sv_newmortal();
  1243.     if (entry) {
  1244.         sv_setsv(key, HeSVKEY_force(entry));
  1245.         SvREFCNT_dec(HeSVKEY(entry));    /* get rid of previous key */
  1246.     }
  1247.     else {
  1248.         char *k;
  1249.         HEK *hek;
  1250.  
  1251.         xhv->xhv_eiter = entry = new_HE();  /* one HE per MAGICAL hash */
  1252.         Zero(entry, 1, HE);
  1253.         Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
  1254.         hek = (HEK*)k;
  1255.         HeKEY_hek(entry) = hek;
  1256.         HeKLEN(entry) = HEf_SVKEY;
  1257.     }
  1258.     magic_nextpack((SV*) hv,mg,key);
  1259.         if (SvOK(key)) {
  1260.         /* force key to stay around until next time */
  1261.         HeSVKEY_set(entry, SvREFCNT_inc(key));
  1262.         return entry;        /* beware, hent_val is not set */
  1263.         }
  1264.     if (HeVAL(entry))
  1265.         SvREFCNT_dec(HeVAL(entry));
  1266.     Safefree(HeKEY_hek(entry));
  1267.     del_HE(entry);
  1268.     xhv->xhv_eiter = Null(HE*);
  1269.     return Null(HE*);
  1270.     }
  1271. #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
  1272.     if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
  1273.     prime_env_iter();
  1274. #endif
  1275.  
  1276.     if (!xhv->xhv_array)
  1277.     Newz(506, xhv->xhv_array,
  1278.          PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
  1279.     if (entry)
  1280.     entry = HeNEXT(entry);
  1281.     while (!entry) {
  1282.     ++xhv->xhv_riter;
  1283.     if (xhv->xhv_riter > xhv->xhv_max) {
  1284.         xhv->xhv_riter = -1;
  1285.         break;
  1286.     }
  1287.     entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
  1288.     }
  1289.  
  1290.     if (oldentry && HvLAZYDEL(hv)) {        /* was deleted earlier? */
  1291.     HvLAZYDEL_off(hv);
  1292.     hv_free_ent(hv, oldentry);
  1293.     }
  1294.  
  1295.     xhv->xhv_eiter = entry;
  1296.     return entry;
  1297. }
  1298.  
  1299. /*
  1300. =for apidoc hv_iterkey
  1301.  
  1302. Returns the key from the current position of the hash iterator.  See
  1303. C<hv_iterinit>.
  1304.  
  1305. =cut
  1306. */
  1307.  
  1308. char *
  1309. Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
  1310. {
  1311.     if (HeKLEN(entry) == HEf_SVKEY) {
  1312.     STRLEN len;
  1313.     char *p = SvPV(HeKEY_sv(entry), len);
  1314.     *retlen = len;
  1315.     return p;
  1316.     }
  1317.     else {
  1318.     *retlen = HeKLEN(entry);
  1319.     return HeKEY(entry);
  1320.     }
  1321. }
  1322.  
  1323. /* unlike hv_iterval(), this always returns a mortal copy of the key */
  1324. /*
  1325. =for apidoc hv_iterkeysv
  1326.  
  1327. Returns the key as an C<SV*> from the current position of the hash
  1328. iterator.  The return value will always be a mortal copy of the key.  Also
  1329. see C<hv_iterinit>.
  1330.  
  1331. =cut
  1332. */
  1333.  
  1334. SV *
  1335. Perl_hv_iterkeysv(pTHX_ register HE *entry)
  1336. {
  1337.     if (HeKLEN(entry) == HEf_SVKEY)
  1338.     return sv_mortalcopy(HeKEY_sv(entry));
  1339.     else
  1340.     return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
  1341.                   HeKLEN(entry)));
  1342. }
  1343.  
  1344. /*
  1345. =for apidoc hv_iterval
  1346.  
  1347. Returns the value from the current position of the hash iterator.  See
  1348. C<hv_iterkey>.
  1349.  
  1350. =cut
  1351. */
  1352.  
  1353. SV *
  1354. Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
  1355. {
  1356.     if (SvRMAGICAL(hv)) {
  1357.     if (mg_find((SV*)hv,'P')) {
  1358.         SV* sv = sv_newmortal();
  1359.         if (HeKLEN(entry) == HEf_SVKEY)
  1360.         mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
  1361.         else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
  1362.         return sv;
  1363.     }
  1364.     }
  1365.     return HeVAL(entry);
  1366. }
  1367.  
  1368. /*
  1369. =for apidoc hv_iternextsv
  1370.  
  1371. Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
  1372. operation.
  1373.  
  1374. =cut
  1375. */
  1376.  
  1377. SV *
  1378. Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
  1379. {
  1380.     HE *he;
  1381.     if ( (he = hv_iternext(hv)) == NULL)
  1382.     return NULL;
  1383.     *key = hv_iterkey(he, retlen);
  1384.     return hv_iterval(hv, he);
  1385. }
  1386.  
  1387. /*
  1388. =for apidoc hv_magic
  1389.  
  1390. Adds magic to a hash.  See C<sv_magic>.
  1391.  
  1392. =cut
  1393. */
  1394.  
  1395. void
  1396. Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
  1397. {
  1398.     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
  1399. }
  1400.  
  1401. char*    
  1402. Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
  1403. {
  1404.     return HEK_KEY(share_hek(sv, len, hash));
  1405. }
  1406.  
  1407. /* possibly free a shared string if no one has access to it
  1408.  * len and hash must both be valid for str.
  1409.  */
  1410. void
  1411. Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
  1412. {
  1413.     register XPVHV* xhv;
  1414.     register HE *entry;
  1415.     register HE **oentry;
  1416.     register I32 i = 1;
  1417.     I32 found = 0;
  1418.     
  1419.     /* what follows is the moral equivalent of:
  1420.     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
  1421.     if (--*Svp == Nullsv)
  1422.         hv_delete(PL_strtab, str, len, G_DISCARD, hash);
  1423.     } */
  1424.     xhv = (XPVHV*)SvANY(PL_strtab);
  1425.     /* assert(xhv_array != 0) */
  1426.     LOCK_STRTAB_MUTEX;
  1427.     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  1428.     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
  1429.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  1430.         continue;
  1431.     if (HeKLEN(entry) != len)
  1432.         continue;
  1433.     if (memNE(HeKEY(entry),str,len))    /* is this it? */
  1434.         continue;
  1435.     found = 1;
  1436.     if (--HeVAL(entry) == Nullsv) {
  1437.         *oentry = HeNEXT(entry);
  1438.         if (i && !*oentry)
  1439.         xhv->xhv_fill--;
  1440.         Safefree(HeKEY_hek(entry));
  1441.         del_HE(entry);
  1442.         --xhv->xhv_keys;
  1443.     }
  1444.     break;
  1445.     }
  1446.     UNLOCK_STRTAB_MUTEX;
  1447.     
  1448.     {
  1449.         dTHR;
  1450.         if (!found && ckWARN_d(WARN_INTERNAL))
  1451.         Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");    
  1452.     }
  1453. }
  1454.  
  1455. /* get a (constant) string ptr from the global string table
  1456.  * string will get added if it is not already there.
  1457.  * len and hash must both be valid for str.
  1458.  */
  1459. HEK *
  1460. Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
  1461. {
  1462.     register XPVHV* xhv;
  1463.     register HE *entry;
  1464.     register HE **oentry;
  1465.     register I32 i = 1;
  1466.     I32 found = 0;
  1467.  
  1468.     /* what follows is the moral equivalent of:
  1469.        
  1470.     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
  1471.         hv_store(PL_strtab, str, len, Nullsv, hash);
  1472.     */
  1473.     xhv = (XPVHV*)SvANY(PL_strtab);
  1474.     /* assert(xhv_array != 0) */
  1475.     LOCK_STRTAB_MUTEX;
  1476.     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
  1477.     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
  1478.     if (HeHASH(entry) != hash)        /* strings can't be equal */
  1479.         continue;
  1480.     if (HeKLEN(entry) != len)
  1481.         continue;
  1482.     if (memNE(HeKEY(entry),str,len))    /* is this it? */
  1483.         continue;
  1484.     found = 1;
  1485.     break;
  1486.     }
  1487.     if (!found) {
  1488.     entry = new_HE();
  1489.     HeKEY_hek(entry) = save_hek(str, len, hash);
  1490.     HeVAL(entry) = Nullsv;
  1491.     HeNEXT(entry) = *oentry;
  1492.     *oentry = entry;
  1493.     xhv->xhv_keys++;
  1494.     if (i) {                /* initial entry? */
  1495.         ++xhv->xhv_fill;
  1496.         if (xhv->xhv_keys > xhv->xhv_max)
  1497.         hsplit(PL_strtab);
  1498.     }
  1499.     }
  1500.  
  1501.     ++HeVAL(entry);                /* use value slot as REFCNT */
  1502.     UNLOCK_STRTAB_MUTEX;
  1503.     return HeKEY_hek(entry);
  1504. }
  1505.  
  1506.  
  1507.  
  1508.