From: Nick Ing-Simmons Date: Sun, 3 Sep 2000 21:54:46 +0000 (+0000) Subject: Hash lookup of constant strings optimization: X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1c846c1f6d96d2ca4dfccdcfc0ff050c1474993e;p=p5sagit%2Fp5-mst-13.2.git Hash lookup of constant strings optimization: Introduce SvREADONLY && SvFAKE to flag an SV which has SvPVX pointing to string table (as per sharepvn). Add newSV_pvn_share to create such a thing. Make hv.c compare addresses of strings and skip string compare if equal. Make method_named and helem ops use these shared-string SVs when arg is constant. Make keys op return shared-string SVs (less clearly a win). p4raw-id: //depot/perl@7016 --- diff --git a/embed.h b/embed.h index ced6e9d..9bd72ad 100644 --- a/embed.h +++ b/embed.h @@ -1,4 +1,4 @@ -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -481,6 +481,7 @@ #define newSVnv Perl_newSVnv #define newSVpv Perl_newSVpv #define newSVpvn Perl_newSVpvn +#define newSVpvn_share Perl_newSVpvn_share #define newSVpvf Perl_newSVpvf #define vnewSVpvf Perl_vnewSVpvf #define newSVrv Perl_newSVrv @@ -1940,6 +1941,7 @@ #define newSVnv(a) Perl_newSVnv(aTHX_ a) #define newSVpv(a,b) Perl_newSVpv(aTHX_ a,b) #define newSVpvn(a,b) Perl_newSVpvn(aTHX_ a,b) +#define newSVpvn_share(a,b,c) Perl_newSVpvn_share(aTHX_ a,b,c) #define vnewSVpvf(a,b) Perl_vnewSVpvf(aTHX_ a,b) #define newSVrv(a,b) Perl_newSVrv(aTHX_ a,b) #define newSVsv(a) Perl_newSVsv(aTHX_ a) @@ -3795,6 +3797,8 @@ #define newSVpv Perl_newSVpv #define Perl_newSVpvn CPerlObj::Perl_newSVpvn #define newSVpvn Perl_newSVpvn +#define Perl_newSVpvn_share CPerlObj::Perl_newSVpvn_share +#define newSVpvn_share Perl_newSVpvn_share #define Perl_newSVpvf CPerlObj::Perl_newSVpvf #define newSVpvf Perl_newSVpvf #define Perl_vnewSVpvf CPerlObj::Perl_vnewSVpvf diff --git a/embed.pl b/embed.pl index b99a59f..c8e83f8 100755 --- a/embed.pl +++ b/embed.pl @@ -135,12 +135,12 @@ sub write_protos { } $ret .= ")"; $ret .= " __attribute__((noreturn))" if $flags =~ /r/; - if( $flags =~ /f/ ) { + if( $flags =~ /f/ ) { my $prefix = $flags =~ /n/ ? '' : 'pTHX_'; - my $args = scalar @args; + my $args = scalar @args; $ret .= "\n#ifdef CHECK_FORMAT\n"; $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))", - $prefix, $args - 1, $prefix, $args; + $prefix, $args - 1, $prefix, $args; $ret .= "\n#endif\n"; } $ret .= ";\n"; @@ -185,11 +185,11 @@ EOT # hints # copline my @extvars = qw(sv_undef sv_yes sv_no na dowarn - curcop compiling + curcop compiling tainting tainted stack_base stack_sp sv_arenaroot no_modify curstash DBsub DBsingle debstash - rsfp + rsfp stdingv defgv errgv @@ -280,7 +280,7 @@ unlink 'embed.h'; open(EM, '> embed.h') or die "Can't create embed.h: $!\n"; print EM <<'END'; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -542,7 +542,7 @@ open(EM, '> embedvar.h') or die "Can't create embedvar.h: $!\n"; print EM <<'END'; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -708,7 +708,7 @@ open(OBX, '> objXSUB.h') or die "Can't create objXSUB.h: $!\n"; print OBX <<'EOT'; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -766,7 +766,7 @@ open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n"; open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n"; print CAPIH <<'EOT'; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -873,7 +873,7 @@ EOT close CAPIH; print CAPI <<'EOT'; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -1132,7 +1132,7 @@ sub docout ($$$) { # output the docs for one function $docs .= "NOTE: this function is experimental and may change or be removed without notice.\n\n" if $flags =~ /x/; - $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n" + $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n" if $flags =~ /p/; print $fh "=item $name\n$docs"; @@ -1159,7 +1159,7 @@ for $file (glob('*.c'), glob('*.h')) { } unlink "pod/perlapi.pod"; -open (DOC, ">pod/perlapi.pod") or +open (DOC, ">pod/perlapi.pod") or die "Can't create pod/perlapi.pod: $!\n"; walk_table { # load documented functions into approriate hash @@ -1184,7 +1184,7 @@ walk_table { # load documented functions into approriate hash } \*DOC; for (sort keys %docfuncs) { - # Have you used a full for apidoc or just a func name? + # Have you used a full for apidoc or just a func name? # Have you used Ap instead of Am in the for apidoc? warn "Unable to place $_!\n"; } @@ -1196,9 +1196,9 @@ perlapi - autogenerated documentation for the perl public API =head1 DESCRIPTION -This file contains the documentation of the perl public API generated by -embed.pl, specifically a listing of functions, macros, flags, and variables -that may be used by extension writers. The interfaces of any functions that +This file contains the documentation of the perl public API generated by +embed.pl, specifically a listing of functions, macros, flags, and variables +that may be used by extension writers. The interfaces of any functions that are not listed here are subject to change without notice. For this reason, blindly using functions listed in proto.h is to be avoided when writing extensions. @@ -1244,19 +1244,19 @@ _EOE_ close(DOC); -open(GUTS, ">pod/perlintern.pod") or +open(GUTS, ">pod/perlintern.pod") or die "Unable to create pod/perlintern.pod: $!\n"; print GUTS <<'END'; =head1 NAME -perlintern - autogenerated documentation of purely B +perlintern - autogenerated documentation of purely B Perl functions =head1 DESCRIPTION -This file is the autogenerated documentation of functions in the +This file is the autogenerated documentation of functions in the Perl interpreter that are documented using Perl's internal documentation -format but are not marked as part of the Perl API. In other words, +format but are not marked as part of the Perl API. In other words, B! =over 8 @@ -1272,8 +1272,8 @@ print GUTS <<'END'; =head1 AUTHORS -The autodocumentation system was originally added to the Perl core by -Benjamin Stuhl. Documentation is by whoever was kind enough to +The autodocumentation system was originally added to the Perl core by +Benjamin Stuhl. Documentation is by whoever was kind enough to document their functions. =head1 SEE ALSO @@ -1801,6 +1801,7 @@ Apd |SV* |newSVuv |UV u Apd |SV* |newSVnv |NV n Apd |SV* |newSVpv |const char* s|STRLEN len Apd |SV* |newSVpvn |const char* s|STRLEN len +Apd |SV* |newSVpvn_share |const char* s|STRLEN len|U32 hash Afpd |SV* |newSVpvf |const char* pat|... Ap |SV* |vnewSVpvf |const char* pat|va_list* args Apd |SV* |newSVrv |SV* rv|const char* classname diff --git a/embedvar.h b/embedvar.h index f6488c6..729389c 100644 --- a/embedvar.h +++ b/embedvar.h @@ -1,4 +1,4 @@ -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ diff --git a/global.sym b/global.sym index 047a710..080d78c 100644 --- a/global.sym +++ b/global.sym @@ -279,6 +279,7 @@ Perl_newSVuv Perl_newSVnv Perl_newSVpv Perl_newSVpvn +Perl_newSVpvn_share Perl_newSVpvf Perl_vnewSVpvf Perl_newSVrv diff --git a/hv.c b/hv.c index 6a07615..8a43a19 100644 --- a/hv.c +++ b/hv.c @@ -15,6 +15,7 @@ #define PERL_IN_HV_C #include "perl.h" + STATIC HE* S_new_he(pTHX) { @@ -74,7 +75,7 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash) { char *k; register HEK *hek; - + New(54, k, HEK_BASESIZE + len + 1, char); hek = (HEK*)k; Copy(str, HEK_KEY(hek), len, char); @@ -128,7 +129,7 @@ Perl_he_dup(pTHX_ HE *e, bool shared) Returns the SV which corresponds to the specified key in the hash. The C is the length of the key. If C is set then the fetch will be part of a store. Check that the return value is non-null before -dereferencing it to a C. +dereferencing it to a C. See L for more information on how to use this function on tied hashes. @@ -172,7 +173,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) { - if (lval + if (lval #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) #endif @@ -191,7 +192,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return &HeVAL(entry); } @@ -224,7 +225,7 @@ if you want the function to compute it. IF C is set then the fetch will be part of a store. Make sure the return value is non-null before accessing it. The return value when C is a tied hash is a pointer to a static location, so be sure to make a copy of the structure if you need to -store it somewhere. +store it somewhere. See L for more information on how to use this function on tied hashes. @@ -278,7 +279,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) { - if (lval + if (lval #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) #endif @@ -290,7 +291,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) } key = SvPV(keysv, klen); - + if (!hash) PERL_HASH(hash, key, klen); @@ -300,7 +301,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return entry; } @@ -351,7 +352,7 @@ NULL if the operation failed or if the value did not need to be actually stored within the hash (as in the case of tied hashes). Otherwise it can be dereferenced to get the original C. Note that the caller is responsible for suitably incrementing the reference count of C before -the call, and decrementing it if the function returned NULL. +the call, and decrementing it if the function returned NULL. See L for more information on how to use this function on tied hashes. @@ -403,7 +404,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; @@ -440,7 +441,7 @@ stored within the hash (as in the case of tied hashes). Otherwise the contents of the return value can be accessed using the C macros described here. Note that the caller is responsible for suitably incrementing the reference count of C before the call, and -decrementing it if the function returned NULL. +decrementing it if the function returned NULL. See L for more information on how to use this function on tied hashes. @@ -504,7 +505,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = val; @@ -534,7 +535,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) =for apidoc hv_delete Deletes a key/value pair in the hash. The value SV is removed from the -hash and returned to the caller. The C is the length of the key. +hash and returned to the caller. The C is the length of the key. The C value will normally be zero; if set to G_DISCARD then NULL will be returned. @@ -591,7 +592,7 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; *oentry = HeNEXT(entry); if (i && !*oentry) @@ -633,7 +634,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) register HE *entry; register HE **oentry; SV *sv; - + if (!hv) return Nullsv; if (SvRMAGICAL(hv)) { @@ -656,7 +657,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) key = SvPV(keysv, klen); keysv = sv_2mortal(newSVpvn(key,klen)); (void)strupr(SvPVX(keysv)); - hash = 0; + hash = 0; } #endif } @@ -666,7 +667,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return Nullsv; key = SvPV(keysv, klen); - + if (!hash) PERL_HASH(hash, key, klen); @@ -678,7 +679,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; *oentry = HeNEXT(entry); if (i && !*oentry) @@ -723,7 +724,7 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) if (mg_find((SV*)hv,'P')) { dTHR; sv = sv_newmortal(); - mg_copy((SV*)hv, sv, key, klen); + mg_copy((SV*)hv, sv, key, klen); magic_existspack(sv, mg_find(sv, 'p')); return SvTRUE(sv); } @@ -738,7 +739,7 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) xhv = (XPVHV*)SvANY(hv); #ifndef DYNAMIC_ENV_FETCH if (!xhv->xhv_array) - return 0; + return 0; #endif PERL_HASH(hash, key, klen); @@ -753,7 +754,7 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return TRUE; } @@ -800,7 +801,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) dTHR; /* just for SvTRUE */ sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); - mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); + mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); magic_existspack(sv, mg_find(sv, 'p')); return SvTRUE(sv); } @@ -809,7 +810,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) key = SvPV(keysv, klen); keysv = sv_2mortal(newSVpvn(key,klen)); (void)strupr(SvPVX(keysv)); - hash = 0; + hash = 0; } #endif } @@ -817,7 +818,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) xhv = (XPVHV*)SvANY(hv); #ifndef DYNAMIC_ENV_FETCH if (!xhv->xhv_array) - return 0; + return 0; #endif key = SvPV(keysv, klen); @@ -834,7 +835,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) continue; if (HeKLEN(entry) != klen) continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; return TRUE; } @@ -1012,9 +1013,9 @@ Perl_newHV(pTHX) xhv = (XPVHV*)SvANY(hv); SvPOK_off(hv); SvNOK_off(hv); -#ifndef NODEFAULT_SHAREKEYS +#ifndef NODEFAULT_SHAREKEYS HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif +#endif xhv->xhv_max = 7; /* start with 8 buckets */ xhv->xhv_fill = 0; xhv->xhv_pmroot = 0; @@ -1039,8 +1040,8 @@ Perl_newHVhv(pTHX_ HV *ohv) #if 0 if (! SvTIED_mg((SV*)ohv, 'P')) { /* Quick way ???*/ - } - else + } + else #endif { HE *entry; @@ -1050,13 +1051,13 @@ Perl_newHVhv(pTHX_ HV *ohv) /* Slow way */ hv_iterinit(ohv); while ((entry = hv_iternext(ohv))) { - hv_store(hv, HeKEY(entry), HeKLEN(entry), + hv_store(hv, HeKEY(entry), HeKLEN(entry), SvREFCNT_inc(HeVAL(entry)), HeHASH(entry)); } HvRITER(ohv) = hv_riter; HvEITER(ohv) = hv_eiter; } - + return hv; } @@ -1123,7 +1124,7 @@ Perl_hv_clear(pTHX_ HV *hv) (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*)); if (SvRMAGICAL(hv)) - mg_clear((SV*)hv); + mg_clear((SV*)hv); } STATIC void @@ -1154,7 +1155,7 @@ S_hfreeentries(pTHX_ HV *hv) if (++riter > max) break; entry = array[riter]; - } + } } (void)hv_iterinit(hv); } @@ -1186,7 +1187,7 @@ Perl_hv_undef(pTHX_ HV *hv) xhv->xhv_keys = 0; if (SvRMAGICAL(hv)) - mg_clear((SV*)hv); + mg_clear((SV*)hv); } /* @@ -1194,7 +1195,7 @@ Perl_hv_undef(pTHX_ HV *hv) Prepares a starting point to traverse a hash table. Returns the number of keys in the hash (i.e. the same as C). The return value is -currently only meaningful for hashes without tie magic. +currently only meaningful for hashes without tie magic. NOTE: Before version 5.004_65, C used to return the number of hash buckets that happen to be in use. If you still need that esoteric @@ -1341,9 +1342,10 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry) { if (HeKLEN(entry) == HEf_SVKEY) return sv_mortalcopy(HeKEY_sv(entry)); - else - return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""), - HeKLEN(entry))); + else { + return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""), + HeKLEN(entry), HeHASH(entry))); + } } /* @@ -1420,7 +1422,7 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) register HE **oentry; register I32 i = 1; I32 found = 0; - + /* what follows is the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { if (--*Svp == Nullsv) @@ -1435,7 +1437,7 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) continue; if (HeKLEN(entry) != len) continue; - if (memNE(HeKEY(entry),str,len)) /* is this it? */ + if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; found = 1; if (--HeVAL(entry) == Nullsv) { @@ -1449,11 +1451,11 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) break; } UNLOCK_STRTAB_MUTEX; - + { dTHR; if (!found && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string"); + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str); } } @@ -1471,7 +1473,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) I32 found = 0; /* what follows is the moral equivalent of: - + if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) hv_store(PL_strtab, str, len, Nullsv, hash); */ @@ -1484,7 +1486,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) continue; if (HeKLEN(entry) != len) continue; - if (memNE(HeKEY(entry),str,len)) /* is this it? */ + if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ continue; found = 1; break; diff --git a/objXSUB.h b/objXSUB.h index 3e0ccce..00184c9 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -1,4 +1,4 @@ -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -1101,6 +1101,10 @@ #define Perl_newSVpvn pPerl->Perl_newSVpvn #undef newSVpvn #define newSVpvn Perl_newSVpvn +#undef Perl_newSVpvn_share +#define Perl_newSVpvn_share pPerl->Perl_newSVpvn_share +#undef newSVpvn_share +#define newSVpvn_share Perl_newSVpvn_share #undef Perl_newSVpvf #define Perl_newSVpvf pPerl->Perl_newSVpvf #undef newSVpvf diff --git a/op.c b/op.c index 263f784..1203802 100644 --- a/op.c +++ b/op.c @@ -22,7 +22,7 @@ /* #define PL_OP_SLAB_ALLOC */ -#ifdef PL_OP_SLAB_ALLOC +#ifdef PL_OP_SLAB_ALLOC #define SLAB_SIZE 8192 static char *PL_OpPtr = NULL; static int PL_OpSpace = 0; @@ -32,15 +32,15 @@ static int PL_OpSpace = 0; var = (type *) Slab_Alloc(m,c*sizeof(type)); \ } while (0) -STATIC void * +STATIC void * S_Slab_Alloc(pTHX_ int m, size_t sz) -{ +{ Newz(m,PL_OpPtr,SLAB_SIZE,char); PL_OpSpace = SLAB_SIZE - sz; return PL_OpPtr += PL_OpSpace; } -#else +#else #define NewOp(m, var, c, type) Newz(m, var, c, type) #endif /* @@ -150,7 +150,7 @@ Perl_pad_allocmy(pTHX_ char *name) && strEQ(name, SvPVX(sv))) { Perl_warner(aTHX_ WARN_MISC, - "\"%s\" variable %s masks earlier declaration in same %s", + "\"%s\" variable %s masks earlier declaration in same %s", (PL_in_my == KEY_our ? "our" : "my"), name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); @@ -651,7 +651,7 @@ Perl_find_threadsv(pTHX_ const char *name) break; case ';': sv_setpv(sv, "\034"); - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, 0, name, 1); break; case '&': case '`': @@ -675,7 +675,7 @@ Perl_find_threadsv(pTHX_ const char *name) /* case '!': */ default: - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, 0, name, 1); } DEBUG_S(PerlIO_printf(Perl_error_log, "find_threadsv: new SV %p for $%s%c\n", @@ -1022,7 +1022,7 @@ Perl_scalarvoid(pTHX_ OP *o) { return scalar(o); /* As if inside SASSIGN */ } - + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { @@ -1229,7 +1229,7 @@ Perl_list(pTHX_ OP *o) { return o; /* As if inside SASSIGN */ } - + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (o->op_type) { @@ -1341,7 +1341,7 @@ Perl_mod(pTHX_ OP *o, I32 type) { return o; } - + switch (o->op_type) { case OP_UNDEF: PL_modcount++; @@ -1419,7 +1419,7 @@ Perl_mod(pTHX_ OP *o, I32 type) newop->op_private |= OPpLVAL_INTRO; break; } - + if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " @@ -1455,7 +1455,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } cv = GvCV(kGVOP_gv); - if (!cv) + if (!cv) goto restore_2cv; if (CvLVALUE(cv)) break; @@ -1749,7 +1749,7 @@ Perl_ref(pTHX_ OP *o, I32 type) o->op_flags |= OPf_MOD; } break; - + case OP_THREADSV: o->op_flags |= OPf_MOD; /* XXX ??? */ break; @@ -1979,7 +1979,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) left->op_type == OP_PADAV) ? "@array" : "%hash"); Perl_warner(aTHX_ WARN_MISC, - "Applying %s to %s will act on scalar(%s)", + "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } @@ -2069,7 +2069,7 @@ Perl_block_start(pTHX_ int full) PL_pad_reset_pending = FALSE; SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; - SAVESPTR(PL_compiling.cop_warnings); + SAVESPTR(PL_compiling.cop_warnings); if (! specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; @@ -2415,10 +2415,10 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) first->op_children += last->op_children; if (first->op_children) first->op_flags |= OPf_KIDS; - + #ifdef PL_OP_SLAB_ALLOC #else - Safefree(last); + Safefree(last); #endif return (OP*)first; } @@ -2608,11 +2608,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) complement = o->op_private & OPpTRANS_COMPLEMENT; del = o->op_private & OPpTRANS_DELETE; squash = o->op_private & OPpTRANS_SQUASH; - + if (SvUTF8(tstr)) o->op_private |= OPpTRANS_FROM_UTF; - - if (SvUTF8(rstr)) + + if (SvUTF8(rstr)) o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { @@ -2907,7 +2907,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (PL_hints & HINT_UTF8) pm->op_pmdynflags |= PMdf_UTF8; if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) - expr = newUNOP((!(PL_hints & HINT_RE_EVAL) + expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); @@ -2915,7 +2915,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) rcop->op_type = OP_REGCOMP; rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; rcop->op_first = scalar(expr); - rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) + rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? (OPf_SPECIAL | OPf_KIDS) : OPf_KIDS); rcop->op_private = 1; @@ -2994,8 +2994,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) } } if (curop == repl - && !(repl_has_vars - && (!pm->op_pmregexp + && !(repl_has_vars + && (!pm->op_pmregexp || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ @@ -3524,7 +3524,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_arybase = PL_curcop->cop_arybase; if (specialWARN(PL_curcop->cop_warnings)) cop->cop_warnings = PL_curcop->cop_warnings ; - else + else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; @@ -3611,7 +3611,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } if (first->op_type == OP_CONST) { if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) - Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); *firstp = Nullop; @@ -3638,7 +3638,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { warnop = k2->op_type; } @@ -3814,12 +3814,12 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP *k1 = ((UNOP*)expr)->op_first; OP *k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { - case OP_NULL: + case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); - break; + break; case OP_SASSIGN: if (k1->op_type == OP_READDIR @@ -3869,12 +3869,12 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP *k1 = ((UNOP*)expr)->op_first; OP *k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { - case OP_NULL: + case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); - break; + break; case OP_SASSIGN: if (k1->op_type == OP_READDIR @@ -4037,7 +4037,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo } #else Renew(loop, 1, LOOP); -#endif +#endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); PL_copline = forline; @@ -4360,14 +4360,14 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) if (!o) return Nullsv; - - if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) + + if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { OPCODE type = o->op_type; - if (sv && o->op_next == o) + if (sv && o->op_next == o) return sv; if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) continue; @@ -4989,7 +4989,7 @@ OP * Perl_oopsHV(pTHX_ OP *o) { dTHR; - + switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -5349,7 +5349,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) break; } if (badthing) - Perl_croak(aTHX_ + Perl_croak(aTHX_ "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", name, badthing); } @@ -5767,7 +5767,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ if (defined %stash::) to work. Do not break Tk. */ - break; /* Globals via GV can be undef */ + break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_warner(aTHX_ WARN_DEPRECATED, @@ -5780,7 +5780,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ if (defined %stash::) to work. Do not break Tk. */ - break; /* Globals via GV can be undef */ + break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, "defined(%%hash) is deprecated"); @@ -5911,11 +5911,13 @@ Perl_ck_method(pTHX_ OP *o) SV* sv = kSVOP->op_sv; if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { OP *cmop; - (void)SvUPGRADE(sv, SVt_PVIV); - (void)SvIOK_on(sv); - PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv)); + if (!SvREADONLY(sv) || !SvFAKE(sv)) { + sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0); + } + else { + kSVOP->op_sv = Nullsv; + } cmop = newSVOP(OP_METHOD_NAMED, 0, sv); - kSVOP->op_sv = Nullsv; op_free(o); return cmop; } @@ -6135,8 +6137,8 @@ S_simplify_sort(pTHX_ OP *o) GV *gv; if (!(o->op_flags & OPf_STACKED)) return; - GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); - GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); + GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); + GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); kid = kUNOP->op_first; /* get past null */ if (kid->op_type != OP_SCOPE) return; @@ -6243,7 +6245,7 @@ Perl_ck_split(pTHX_ OP *o) } OP * -Perl_ck_join(pTHX_ OP *o) +Perl_ck_join(pTHX_ OP *o) { if (ckWARN(WARN_SYNTAX)) { OP *kid = cLISTOPo->op_first->op_sibling; @@ -6637,7 +6639,7 @@ Perl_peep(pTHX_ register OP *o) case OP_EXEC: o->op_seq = PL_op_seqmax++; - if (ckWARN(WARN_SYNTAX) && o->op_next + if (ckWARN(WARN_SYNTAX) && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_EXIT && @@ -6661,13 +6663,26 @@ Perl_peep(pTHX_ register OP *o) GV **fields; SV **svp, **indsvp, *sv; I32 ind; - char *key; + char *key = NULL; STRLEN keylen; o->op_seq = PL_op_seqmax++; - if ((o->op_private & (OPpLVAL_INTRO)) - || ((BINOP*)o)->op_last->op_type != OP_CONST) + + if (((BINOP*)o)->op_last->op_type != OP_CONST) break; + + /* Make the CONST have a shared SV */ + svp = cSVOPx_svp(((BINOP*)o)->op_last); + if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { + key = SvPV(sv, keylen); + lexname = newSVpvn_share(key, keylen, 0); + SvREFCNT_dec(sv); + *svp = lexname; + } + + if ((o->op_private & (OPpLVAL_INTRO))) + break; + rop = (UNOP*)((BINOP*)o)->op_first; if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) break; @@ -6677,7 +6692,6 @@ Perl_peep(pTHX_ register OP *o) fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) break; - svp = cSVOPx_svp(((BINOP*)o)->op_last); key = SvPV(*svp, keylen); indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { @@ -6787,7 +6801,7 @@ Perl_peep(pTHX_ register OP *o) while (r->op_sibling) r = r->op_sibling; - if (r->op_next == o + if (r->op_next == o || (r->op_next->op_type == OP_LIST && r->op_next->op_next == o)) { diff --git a/perlapi.c b/perlapi.c index 3257fec..496fcc9 100644 --- a/perlapi.c +++ b/perlapi.c @@ -1,4 +1,4 @@ -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ @@ -2015,6 +2015,13 @@ Perl_newSVpvn(pTHXo_ const char* s, STRLEN len) return ((CPerlObj*)pPerl)->Perl_newSVpvn(s, len); } +#undef Perl_newSVpvn_share +SV* +Perl_newSVpvn_share(pTHXo_ const char* s, STRLEN len, U32 hash) +{ + return ((CPerlObj*)pPerl)->Perl_newSVpvn_share(s, len, hash); +} + #undef Perl_newSVpvf SV* Perl_newSVpvf(pTHXo_ const char* pat, ...) diff --git a/perlapi.h b/perlapi.h index 4a95fbb..2d210ee 100644 --- a/perlapi.h +++ b/perlapi.h @@ -1,4 +1,4 @@ -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h, perlvars.h and thrdvar.h. Any changes made here will be lost! */ diff --git a/pod/perlapi.pod b/pod/perlapi.pod index b6dab89..ccb159d 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -4,9 +4,9 @@ perlapi - autogenerated documentation for the perl public API =head1 DESCRIPTION -This file contains the documentation of the perl public API generated by -embed.pl, specifically a listing of functions, macros, flags, and variables -that may be used by extension writers. The interfaces of any functions that +This file contains the documentation of the perl public API generated by +embed.pl, specifically a listing of functions, macros, flags, and variables +that may be used by extension writers. The interfaces of any functions that are not listed here are subject to change without notice. For this reason, blindly using functions listed in proto.h is to be avoided when writing extensions. @@ -499,18 +499,18 @@ Found in file gv.h Returns the glob with the given C and a defined subroutine or C. The glob lives in the given C, or in the stashes -accessible via @ISA and @UNIVERSAL. +accessible via @ISA and @UNIVERSAL. The argument C should be either 0 or -1. If C, as a side-effect creates a glob with the given C in the given C which in the case of success contains an alias for the subroutine, and sets -up caching info for this glob. Similarly for all the searched stashes. +up caching info for this glob. Similarly for all the searched stashes. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C may be a method cache entry, which is not visible to Perl code. So when calling C, you should not use the GV directly; instead, you should use the method's CV, which can be -obtained from the GV with the C macro. +obtained from the GV with the C macro. GV* gv_fetchmeth(HV* stash, const char* name, STRLEN len, I32 level) @@ -531,24 +531,24 @@ Found in file gv.c Returns the glob which contains the subroutine to call to invoke the method on the C. In fact in the presence of autoloading this may be the glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is -already setup. +already setup. The third parameter of C determines whether AUTOLOAD lookup is performed if the given method is not present: non-zero -means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. +means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling C is equivalent to calling C -with a non-zero C parameter. +with a non-zero C parameter. These functions grant C<"SUPER"> token as a prefix of the method name. Note that if you want to keep the returned glob for a long time, you need to check for it being "AUTOLOAD", since at the later time the call may load a different subroutine due to $AUTOLOAD changing its value. Use the glob -created via a side effect to do this. +created via a side effect to do this. These functions have the same side-effects and as C with C. C should be writable if contains C<':'> or C<' ''>. The warning against passing the GV returned by C to -C apply equally to these functions. +C apply equally to these functions. GV* gv_fetchmethod_autoload(HV* stash, const char* name, I32 autoload) @@ -744,7 +744,7 @@ Found in file hv.c =item hv_delete Deletes a key/value pair in the hash. The value SV is removed from the -hash and returned to the caller. The C is the length of the key. +hash and returned to the caller. The C is the length of the key. The C value will normally be zero; if set to G_DISCARD then NULL will be returned. @@ -791,7 +791,7 @@ Found in file hv.c Returns the SV which corresponds to the specified key in the hash. The C is the length of the key. If C is set then the fetch will be part of a store. Check that the return value is non-null before -dereferencing it to a C. +dereferencing it to a C. See L for more information on how to use this function on tied hashes. @@ -809,7 +809,7 @@ if you want the function to compute it. IF C is set then the fetch will be part of a store. Make sure the return value is non-null before accessing it. The return value when C is a tied hash is a pointer to a static location, so be sure to make a copy of the structure if you need to -store it somewhere. +store it somewhere. See L for more information on how to use this function on tied hashes. @@ -823,7 +823,7 @@ Found in file hv.c Prepares a starting point to traverse a hash table. Returns the number of keys in the hash (i.e. the same as C). The return value is -currently only meaningful for hashes without tie magic. +currently only meaningful for hashes without tie magic. NOTE: Before version 5.004_65, C used to return the number of hash buckets that happen to be in use. If you still need that esoteric @@ -902,7 +902,7 @@ NULL if the operation failed or if the value did not need to be actually stored within the hash (as in the case of tied hashes). Otherwise it can be dereferenced to get the original C. Note that the caller is responsible for suitably incrementing the reference count of C before -the call, and decrementing it if the function returned NULL. +the call, and decrementing it if the function returned NULL. See L for more information on how to use this function on tied hashes. @@ -922,7 +922,7 @@ stored within the hash (as in the case of tied hashes). Otherwise the contents of the return value can be accessed using the C macros described here. Note that the caller is responsible for suitably incrementing the reference count of C before the call, and -decrementing it if the function returned NULL. +decrementing it if the function returned NULL. See L for more information on how to use this function on tied hashes. @@ -1253,7 +1253,7 @@ Found in file sv.c =item newSVpvn Creates a new SV and copies a string into it. The reference count for the -SV is set to 1. Note that if C is zero, Perl will create a zero length +SV is set to 1. Note that if C is zero, Perl will create a zero length string. You are responsible for ensuring that the source string is at least C bytes long. @@ -1262,6 +1262,19 @@ C bytes long. =for hackers Found in file sv.c +=item newSVpvn_share + +Creates a new SV and populates it with a string from +the string table. Turns on READONLY and FAKE. +The idea here is that as string table is used for shared hash +keys these strings will have SvPVX == HeKEY and hash lookup +will avoid string compare. + + SV* newSVpvn_share(const char* s, STRLEN len, U32 hash) + +=for hackers +Found in file sv.c + =item newSVrv Creates a new SV for the RV, C, to point to. If C is not an RV then @@ -1601,7 +1614,7 @@ Found in file pp.h =item PUSHs -Push an SV onto the stack. The stack must have room for this element. +Push an SV onto the stack. The stack must have room for this element. Does not handle 'set' magic. See C. void PUSHs(SV* sv) @@ -2501,7 +2514,7 @@ Found in file sv.c =item sv_chop -Efficient removal of characters from the beginning of the string buffer. +Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside the string buffer. The C becomes the first character of the adjusted string. @@ -2993,7 +3006,7 @@ Found in file sv.c =item sv_usepvn Tells an SV to use C to find its string value. Normally the string is -stored inside the SV but sv_usepvn allows the SV to use an outside string. +stored inside the SV but sv_usepvn allows the SV to use an outside string. The C should point to memory that was allocated by C. The string length, C, must be supplied. This function will realloc the memory pointed to by C, so that pointer should not be freed or used by @@ -3032,7 +3045,7 @@ Found in file sv.c =item sv_utf8_encode Convert the PV of an SV to UTF8-encoded, but then turn off the C -flag so that it looks like bytes again. Nothing calls this. +flag so that it looks like bytes again. Nothing calls this. NOTE: this function is experimental and may change or be removed without notice. @@ -3179,7 +3192,7 @@ Found in file pp.h =item XPUSHu -Push an unsigned integer onto the stack, extending the stack if necessary. +Push an unsigned integer onto the stack, extending the stack if necessary. See C. void XPUSHu(UV uv) diff --git a/pod/perlintern.pod b/pod/perlintern.pod index 8afabd9..11d9385 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -1,13 +1,13 @@ =head1 NAME -perlintern - autogenerated documentation of purely B +perlintern - autogenerated documentation of purely B Perl functions =head1 DESCRIPTION -This file is the autogenerated documentation of functions in the +This file is the autogenerated documentation of functions in the Perl interpreter that are documented using Perl's internal documentation -format but are not marked as part of the Perl API. In other words, +format but are not marked as part of the Perl API. In other words, B! =over 8 @@ -31,8 +31,8 @@ Found in file gv.c =head1 AUTHORS -The autodocumentation system was originally added to the Perl core by -Benjamin Stuhl. Documentation is by whoever was kind enough to +The autodocumentation system was originally added to the Perl core by +Benjamin Stuhl. Documentation is by whoever was kind enough to document their functions. =head1 SEE ALSO diff --git a/pp_hot.c b/pp_hot.c index 0a0c084..4192f55 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -253,7 +253,7 @@ PP(pp_readline) tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { - if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) + if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); else { dSP; @@ -268,7 +268,7 @@ PP(pp_readline) PP(pp_eq) { - djSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPnv; SETs(boolSV(TOPn == value)); @@ -306,7 +306,7 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPnnrl_ul; SETn( left + right ); @@ -374,7 +374,7 @@ PP(pp_print) gv = PL_defoutgv; if ((mg = SvTIED_mg((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { - /* If using default handle then we need to make space to + /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... */ MEXTEND(SP, 1); @@ -495,7 +495,7 @@ PP(pp_rv2av) } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -551,14 +551,14 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; (void)POPs; /* XXXX May be optimized away? */ - EXTEND(SP, maxarg); + EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { - U32 i; + U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } - } + } else { Copy(AvARRAY(av), SP+1, maxarg, SV*); } @@ -599,7 +599,7 @@ PP(pp_rv2hv) } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -1034,10 +1034,10 @@ PP(pp_match) MAGIC* mg = mg_find(TARG, 'g'); if (mg && mg->mg_len >= 0) { if (!(rx->reganch & ROPT_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->endp[0] = rx->startp[0] = mg->mg_len; else if (rx->reganch & ROPT_ANCH_GPOS) { r_flags |= REXEC_IGNOREPOS; - rx->endp[0] = rx->startp[0] = mg->mg_len; + rx->endp[0] = rx->startp[0] = mg->mg_len; } minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; @@ -1047,7 +1047,7 @@ PP(pp_match) if ((gimme != G_ARRAY && !global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; - if (SvSCREAM(TARG)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { @@ -1069,7 +1069,7 @@ play_it_again: if (!s) goto nope; if ( (rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand + && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) @@ -1165,7 +1165,7 @@ yup: /* Confirmed by INTUIT */ rx->endp[0] = s - truebase + rx->minlen; rx->sublen = strend - truebase; goto gotcha; - } + } if (PL_sawampersand) { I32 off; @@ -1541,15 +1541,16 @@ PP(pp_helem) U32 lval = PL_op->op_flags & OPf_MOD; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; + U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; if (SvTYPE(hv) == SVt_PVHV) { - he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + he = hv_fetch_ent(hv, keysv, lval && !defer, hash); svp = he ? &HeVAL(he) : 0; } else if (SvTYPE(hv) == SVt_PVAV) { if (PL_op->op_private & OPpLVAL_INTRO) DIE(aTHX_ "Can't localize pseudo-hash element"); - svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0); + svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash); } else { RETPUSHUNDEF; @@ -1678,7 +1679,7 @@ PP(pp_iter) /* safe to reuse old SV */ sv_setsv(*itersvp, cur); } - else + else #endif { /* we need a fresh SV every time so that loop body sees a @@ -1704,7 +1705,7 @@ PP(pp_iter) /* safe to reuse old SV */ sv_setiv(*itersvp, cx->blk_loop.iterix++); } - else + else #endif { /* we need a fresh SV every time so that loop body sees a @@ -1723,7 +1724,7 @@ PP(pp_iter) SvREFCNT_dec(*itersvp); if ((sv = SvMAGICAL(av) - ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) : AvARRAY(av)[++cx->blk_loop.iterix])) SvTEMP_off(sv); else @@ -1783,7 +1784,7 @@ PP(pp_subst) else { TARG = DEFSV; EXTEND(SP,1); - } + } if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) @@ -1804,7 +1805,7 @@ PP(pp_subst) DIE(aTHX_ "panic: do_subst"); strend = s + len; - maxiters = 2*(strend - s) + 10; /* We can match twice at each + maxiters = 2*(strend - s) + 10; /* We can match twice at each position, once with zero-length, second time with non-zero. */ @@ -1828,7 +1829,7 @@ PP(pp_subst) goto nope; /* How to do it in subst? */ /* if ( (rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand + && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) @@ -2006,7 +2007,7 @@ PP(pp_subst) goto ret_no; nope: -ret_no: +ret_no: SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -2065,7 +2066,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; @@ -2101,7 +2102,7 @@ PP(pp_leavesub) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2123,7 +2124,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { @@ -2254,7 +2255,7 @@ PP(pp_leavesublv) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2275,7 +2276,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) save_item(dbsv); if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") + || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) && (gv = (GV*)*svp) ))) { @@ -2553,7 +2554,7 @@ try_autoload: } PL_stack_sp = mark + 1; fp3 = (I32(*)(int,int,int))CvXSUB(cv); - items = (*fp3)(CvXSUBANY(cv).any_i32, + items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); PL_stack_sp = PL_stack_base + items; @@ -2583,7 +2584,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } /* We assume first XSUB in &DB::sub is the called one. */ @@ -2677,7 +2678,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } #endif /* USE_THREADS */ @@ -2725,7 +2726,7 @@ try_autoload: } Copy(MARK,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + while (items--) { if (*MARK) SvTEMP_off(*MARK); @@ -2755,7 +2756,7 @@ Perl_sub_crush_depth(pTHX_ CV *cv) else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } @@ -2888,7 +2889,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || + if (!packname || ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) diff --git a/proto.h b/proto.h index 931997c..ed08b20 100644 --- a/proto.h +++ b/proto.h @@ -551,6 +551,7 @@ PERL_CALLCONV SV* Perl_newSVuv(pTHX_ UV u); PERL_CALLCONV SV* Perl_newSVnv(pTHX_ NV n); PERL_CALLCONV SV* Perl_newSVpv(pTHX_ const char* s, STRLEN len); PERL_CALLCONV SV* Perl_newSVpvn(pTHX_ const char* s, STRLEN len); +PERL_CALLCONV SV* Perl_newSVpvn_share(pTHX_ const char* s, STRLEN len, U32 hash); PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char* pat, ...) #ifdef CHECK_FORMAT __attribute__((format(printf,pTHX_1,pTHX_2))) diff --git a/sv.c b/sv.c index 827bd96..4da49cc 100644 --- a/sv.c +++ b/sv.c @@ -834,7 +834,7 @@ S_more_xpvbm(pTHX) #define new_XPVHV() my_safemalloc(sizeof(XPVHV)) #define del_XPVHV(p) my_safefree(p) - + #define new_XPVMG() my_safemalloc(sizeof(XPVMG)) #define del_XPVMG(p) my_safefree(p) @@ -872,7 +872,7 @@ S_more_xpvbm(pTHX) #define new_XPVHV() (void*)new_xpvhv() #define del_XPVHV(p) del_xpvhv((XPVHV *)p) - + #define new_XPVMG() (void*)new_xpvmg() #define del_XPVMG(p) del_xpvmg((XPVMG *)p) @@ -886,10 +886,10 @@ S_more_xpvbm(pTHX) #define new_XPVGV() my_safemalloc(sizeof(XPVGV)) #define del_XPVGV(p) my_safefree(p) - + #define new_XPVFM() my_safemalloc(sizeof(XPVFM)) #define del_XPVFM(p) my_safefree(p) - + #define new_XPVIO() my_safemalloc(sizeof(XPVIO)) #define del_XPVIO(p) my_safefree(p) @@ -1523,7 +1523,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) SvUVX(sv) = U_V(SvNVX(sv)); SvIsUV_on(sv); ret_iv_max: - DEBUG_c(PerlIO_printf(Perl_debug_log, + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", PTR2UV(sv), SvUVX(sv), @@ -1537,7 +1537,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) /* We want to avoid a possible problem when we cache an IV which may be later translated to an NV, and the resulting NV is not the translation of the initial data. - + This means that if we cache such an IV, we need to cache the NV as well. Moreover, we trade speed for space, and do not cache the NV if not needed. @@ -1652,7 +1652,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) else { SvIVX(sv) = I_V(SvNVX(sv)); ret_zero: - DEBUG_c(PerlIO_printf(Perl_debug_log, + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n", PTR2UV(sv), SvIVX(sv), @@ -1666,7 +1666,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) /* We want to avoid a possible problem when we cache a UV which may be later translated to an NV, and the resulting NV is not the translation of the initial data. - + This means that if we cache such a UV, we need to cache the NV as well. Moreover, we trade speed for space, and do not cache the NV if not needed. @@ -1768,7 +1768,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) return Atof(SvPVX(sv)); } if (SvIOKp(sv)) { - if (SvIsUV(sv)) + if (SvIsUV(sv)) return (NV)SvUVX(sv); else return (NV)SvIVX(sv); @@ -1928,7 +1928,7 @@ Perl_looks_like_number(pTHX_ SV *sv) STRLEN len; if (SvPOK(sv)) { - sbegin = SvPVX(sv); + sbegin = SvPVX(sv); len = SvCUR(sv); } else if (SvPOKp(sv)) @@ -1966,7 +1966,7 @@ Perl_looks_like_number(pTHX_ SV *sv) numtype |= IS_NUMBER_TO_INT_BY_ATOL; if (*s == '.' -#ifdef USE_LOCALE_NUMERIC +#ifdef USE_LOCALE_NUMERIC || IS_NUMERIC_RADIX(*s) #endif ) { @@ -1977,7 +1977,7 @@ Perl_looks_like_number(pTHX_ SV *sv) } } else if (*s == '.' -#ifdef USE_LOCALE_NUMERIC +#ifdef USE_LOCALE_NUMERIC || IS_NUMERIC_RADIX(*s) #endif ) { @@ -2087,7 +2087,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) return SvPVX(sv); } if (SvIOKp(sv)) { - if (SvIsUV(sv)) + if (SvIsUV(sv)) (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)); else (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); @@ -2123,7 +2123,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) switch (SvTYPE(sv)) { case SVt_PVMG: if ( ((SvFLAGS(sv) & - (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_RMG)) && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") && (mg = mg_find(sv, 'r'))) { @@ -2212,7 +2212,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) * --jhi Sep 1999 */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - /* The +20 is pure guesswork. Configure test needed. --jhi */ + /* The +20 is pure guesswork. Configure test needed. --jhi */ SvGROW(sv, NV_DIG + 20); s = SvPVX(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ @@ -2346,7 +2346,7 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) sv_utf8_upgrade(sv); return sv_2pv(sv,lp); } - + /* This function is only called on magical items */ bool Perl_sv_2bool(pTHX_ register SV *sv) @@ -2498,7 +2498,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) =for apidoc sv_utf8_encode Convert the PV of an SV to UTF8-encoded, but then turn off the C -flag so that it looks like bytes again. Nothing calls this. +flag so that it looks like bytes again. Nothing calls this. =cut */ @@ -2787,22 +2787,22 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) (CvROOT(cv) || CvXSUB(cv))) { SV *const_sv = cv_const_sv(cv); - bool const_changed = TRUE; + bool const_changed = TRUE; if(const_sv) - const_changed = sv_cmp(const_sv, - op_const_sv(CvSTART((CV*)sref), + const_changed = sv_cmp(const_sv, + op_const_sv(CvSTART((CV*)sref), (CV*)sref)); /* ahem, death to those who redefine * active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) - Perl_croak(aTHX_ + Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE)) - Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? + Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", + : "Subroutine %s redefined", GvENAME((GV*)dstr)); } cv_ckproto(cv, (GV*)dstr, @@ -2888,7 +2888,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (SvTEMP(sstr) && /* slated for free anyway? */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ - !(sflags & SVf_OOK)) /* and not involved in OOK hack? */ + !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ + SvLEN(sstr)) /* and really is a string */ { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { @@ -3070,7 +3071,7 @@ Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) =for apidoc sv_usepvn Tells an SV to use C to find its string value. Normally the string is -stored inside the SV but sv_usepvn allows the SV to use an outside string. +stored inside the SV but sv_usepvn allows the SV to use an outside string. The C should point to memory that was allocated by C. The string length, C, must be supplied. This function will realloc the memory pointed to by C, so that pointer should not be freed or used by @@ -3121,7 +3122,18 @@ Perl_sv_force_normal(pTHX_ register SV *sv) { if (SvREADONLY(sv)) { dTHR; - if (PL_curcop != &PL_compiling) + if (SvFAKE(sv)) { + char *pvx = SvPVX(sv); + STRLEN len = SvCUR(sv); + U32 hash = SvUVX(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + SvFAKE_off(sv); + SvREADONLY_off(sv); + unsharepvn(pvx,len,hash); + } + else if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } if (SvROK(sv)) @@ -3129,11 +3141,11 @@ Perl_sv_force_normal(pTHX_ register SV *sv) else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); } - + /* =for apidoc sv_chop -Efficient removal of characters from the beginning of the string buffer. +Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside the string buffer. The C becomes the first character of the adjusted string. @@ -3143,8 +3155,8 @@ string. void Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ - - + + { register STRLEN delta; @@ -3305,7 +3317,7 @@ SV * Perl_newSV(pTHX_ STRLEN len) { register SV *sv; - + new_SV(sv); if (len) { sv_upgrade(sv, SVt_PV); @@ -3328,7 +3340,7 @@ void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { MAGIC* mg; - + if (SvREADONLY(sv)) { dTHR; if (PL_curcop != &PL_compiling && !strchr("gBf", how)) @@ -3362,7 +3374,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam mg->mg_ptr = savepvn(name, namlen); else if (namlen == HEf_SVKEY) mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); - + switch (how) { case 0: mg->mg_virtual = &PL_vtbl_sv; @@ -3548,7 +3560,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv) tsv = SvRV(sv); sv_add_backref(tsv, sv); SvWEAKREF_on(sv); - SvREFCNT_dec(tsv); + SvREFCNT_dec(tsv); return sv; } @@ -3567,7 +3579,7 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) av_push(av,sv); } -STATIC void +STATIC void S_sv_del_backref(pTHX_ SV *sv) { AV *av; @@ -3606,7 +3618,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN register char *bigend; register I32 i; STRLEN curlen; - + if (!bigstr) Perl_croak(aTHX_ "Can't modify non-existent substring"); @@ -3843,6 +3855,10 @@ Perl_sv_clear(pTHX_ register SV *sv) } else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); + else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { + unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv)); + SvFAKE_off(sv); + } break; /* case SVt_NV: @@ -4081,7 +4097,7 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) } if (s != send) { dTHR; - if (ckWARN_d(WARN_UTF8)) + if (ckWARN_d(WARN_UTF8)) Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); --len; } @@ -4161,7 +4177,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; char *pv1, *pv2; - I32 cmp; + I32 cmp; bool pv1tmp = FALSE; bool pv2tmp = FALSE; @@ -4400,7 +4416,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) /* See if we know enough about I/O mechanism to cheat it ! */ /* This used to be #ifdef test - it is made run-time test for ease - of abstracting out stdio interface. One call should be cheap + of abstracting out stdio interface. One call should be cheap enough here - and may even be a macro allowing compile time optimization. */ @@ -4448,7 +4464,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: @@ -4461,8 +4477,8 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) } } else { - Copy(ptr, bp, cnt, char); /* this | eat */ - bp += cnt; /* screams | dust */ + Copy(ptr, bp, cnt, char); /* this | eat */ + bp += cnt; /* screams | dust */ ptr += cnt; /* louder | sed :-) */ cnt = 0; } @@ -4484,15 +4500,15 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); - /* This used to call 'filbuf' in stdio form, but as that behaves like + /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid introducing another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ @@ -4525,7 +4541,7 @@ thats_really_all_folks: PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ @@ -4589,7 +4605,7 @@ screamer2: } } - if (RsPARA(PL_rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ i = PerlIO_getc(fp); if (i != '\n') { @@ -4655,7 +4671,7 @@ Perl_sv_inc(pTHX_ register SV *sv) else { (void)SvIOK_only(sv); ++SvIVX(sv); - } + } } return; } @@ -4685,7 +4701,7 @@ Perl_sv_inc(pTHX_ register SV *sv) /* MKS: The original code here died if letters weren't consecutive. * at least it didn't have to worry about non-C locales. The * new code assumes that ('z'-'a')==('Z'-'A'), letters are - * arranged in order (although not consecutively) and that only + * arranged in order (although not consecutively) and that only * [A-Za-z] are accepted by isALPHA in the C locale. */ if (*d != 'z' && *d != 'Z') { @@ -4759,14 +4775,14 @@ Perl_sv_dec(pTHX_ register SV *sv) else { (void)SvIOK_only_UV(sv); --SvUVX(sv); - } + } } else { if (SvIVX(sv) == IV_MIN) sv_setnv(sv, (NV)IV_MIN - 1.0); else { (void)SvIOK_only(sv); --SvIVX(sv); - } + } } return; } @@ -4880,7 +4896,7 @@ Perl_newSVpv(pTHX_ const char *s, STRLEN len) =for apidoc newSVpvn Creates a new SV and copies a string into it. The reference count for the -SV is set to 1. Note that if C is zero, Perl will create a zero length +SV is set to 1. Note that if C is zero, Perl will create a zero length string. You are responsible for ensuring that the source string is at least C bytes long. @@ -4897,6 +4913,36 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) return sv; } +/* +=for apidoc newSVpvn_share + +Creates a new SV and populates it with a string from +the string table. Turns on READONLY and FAKE. +The idea here is that as string table is used for shared hash +keys these strings will have SvPVX == HeKEY and hash lookup +will avoid string compare. + +=cut +*/ + +SV * +Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash) +{ + register SV *sv; + if (!hash) + PERL_HASH(hash, src, len); + new_SV(sv); + sv_upgrade(sv, SVt_PVIV); + SvPVX(sv) = sharepvn(src, len, hash); + SvCUR(sv) = len; + SvUVX(sv) = hash; + SvLEN(sv) = 0; + SvREADONLY_on(sv); + SvFAKE_on(sv); + SvPOK_on(sv); + return sv; +} + #if defined(PERL_IMPLICIT_CONTEXT) SV * Perl_newSVpvf_nocontext(const char* pat, ...) @@ -5341,7 +5387,7 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) if (SvTHINKFIRST(sv) && !SvROK(sv)) sv_force_normal(sv); - + if (SvPOK(sv)) { *lp = SvCUR(sv); } @@ -5355,7 +5401,7 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) s = sv_2pv(sv, lp); if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ STRLEN len = *lp; - + if (SvROK(sv)) sv_unref(sv); (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */ @@ -6622,7 +6668,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); if (c) { if (isPRINT(c)) - Perl_sv_catpvf(aTHX_ msg, + Perl_sv_catpvf(aTHX_ msg, "\"%%%c\"", c & 0xFF); else Perl_sv_catpvf(aTHX_ msg,