cvs commit: ponie/perl/t/run switches.t
[email protected] (Nicholas Clark) 7 Apr 2004 10:37:31 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 04/04/07 03:37:30
Modified: perl embed.fnc embed.h embedvar.h global.sym gv.c gv.h
hv.c hv.h intrpvar.h mg.c perl.c perl.h perlapi.h
pp_hot.c proto.h sv.c sv.h util.c
perl/ext/POSIX/t posix.t
perl/lib/ExtUtils MM_Unix.pm
perl/pod perlapi.pod perldelta.pod
perl/t/op grep.t magic.t
perl/t/run switches.t
Log:
Fixup conflicts and problems found with merge of perl 5.9.1
Revision Changes Path
1.15 +24 -12 ponie/perl/embed.fnc
Index: embed.fnc
===================================================================
RCS file: /cvs/public/ponie/perl/embed.fnc,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -w -r1.14 -r1.15
--- embed.fnc 10 Mar 2004 23:07:23 -0000 1.14
+++ embed.fnc 7 Apr 2004 10:37:27 -0000 1.15
@@ -47,7 +47,7 @@
|int argc|char** argv|char** env
Anp |bool |doing_taint |int argc|char** argv|char** env
#if defined(USE_ITHREADS)
-Anod |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
+Anod |PerlInterpreter*|perl_clone|PerlInterpreter* interp|UV flags
# if defined(PERL_IMPLICIT_SYS)
Ano |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \
|struct IPerlMem* m|struct IPerlMem* ms \
@@ -337,6 +337,7 @@
Ap |bool |is_uni_xdigit_lc|UV c
Apd |STRLEN |is_utf8_char |U8 *p
Apd |bool |is_utf8_string |U8 *s|STRLEN len
+Apd |bool |is_utf8_string_loc|U8 *s|STRLEN len|U8 **p
Ap |bool |is_utf8_alnum |U8 *p
Ap |bool |is_utf8_alnumc |U8 *p
Ap |bool |is_utf8_idfirst|U8 *p
@@ -534,7 +535,7 @@
Ap |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
Ap |char* |scan_vstring |char *vstr|SV *sv
-Apd |char* |scan_version |char *vstr|SV *sv
+Apd |char* |scan_version |char *vstr|SV *sv|bool qv
Apd |SV* |new_version |SV *ver
Apd |SV* |upg_version |SV *ver
Apd |SV* |vnumify |SV *vs
@@ -696,14 +697,16 @@
Apd |bool |sv_2bool |SV* sv
Apd |CV* |sv_2cv |SV* sv|HV** st|GV** gvp|I32 lref
Apd |IO* |sv_2io |SV* sv
-Apd |IV |sv_2iv |SV* sv
+Amb |IV |sv_2iv |SV* sv
+Apd |IV |sv_2iv_flags |SV* sv|I32 flags
Apd |SV* |sv_2mortal |SV* sv
Apd |NV |sv_2nv |SV* sv
Amb |char* |sv_2pv |SV* sv|STRLEN* lp
Apd |char* |sv_2pvutf8 |SV* sv|STRLEN* lp
Apd |char* |sv_2pvbyte |SV* sv|STRLEN* lp
Ap |char* |sv_pvn_nomg |SV* sv|STRLEN* lp
-Apd |UV |sv_2uv |SV* sv
+Amb |UV |sv_2uv |SV* sv
+Apd |UV |sv_2uv_flags |SV* sv|I32 flags
Apd |IV |sv_iv |SV* sv
Apd |UV |sv_uv |SV* sv
Apd |NV |sv_nv |SV* sv
@@ -850,9 +853,6 @@
Ap |I32 |whichsig |char* sig
p |void |write_to_stderr|const char* message|int msglen
p |int |yyerror |char* s
-#ifdef USE_PURE_BISON
-p |int |yylex_r |YYSTYPE *lvalp|int *lcharp
-#endif
p |int |yylex
p |int |yyparse
p |int |yywarn |char* s
@@ -1019,6 +1019,11 @@
Ap |short* |macro_IoSUBPROCESS |SV *
Ap |char* |macro_IoTYPE |SV *
Ap |char* |macro_IoFLAGS |SV *
+Ap |GP** |macro_GvGP |GV *
+Ap |char** |macro_GvNAME |GV *
+Ap |STRLEN* |macro_GvNAMELEN |GV *
+Ap |HV** |macro_GvSTASH |GV *
+Ap |U8* |macro_GvFLAGS |GV *
END_EXTERN_C
@@ -1047,8 +1052,6 @@
s |void |hv_magic_check |HV *hv|bool *needs_copy|bool *needs_store
s |void |unshare_hek_or_pvn|HEK* hek|const char* sv|I32 len|U32 hash
s |HEK* |share_hek_flags|const char* sv|I32 len|U32 hash|int flags
-s |SV** |hv_fetch_flags |HV* tb|const char* key|I32 klen|I32 lval \
- |int flags
s |void |hv_notallowed |int flags|const char *key|I32 klen|const char *msg
#endif
@@ -1140,7 +1143,8 @@
s |void* |vdocatch_body |va_list args
#endif
s |OP* |dofindlabel |OP *o|char *label|OP **opstack|OP **oplimit
-s |void |doparseform |SV *sv
+s |OP* |doparseform |SV *sv
+sn |bool |num_overflow |NV value|I32 fldsize|I32 frcsize
s |I32 |dopoptoeval |I32 startingblock
s |I32 |dopoptolabel |char *label
s |I32 |dopoptoloop |I32 startingblock
@@ -1378,7 +1382,7 @@
Ap |char* |my_atof2 |const char *s|NV* value
Apn |int |my_socketpair |int family|int type|int protocol|int fd[2]
#ifdef PERL_COPY_ON_WRITE
-pMX |SV* |sv_setsv_cow |SV* dsv|SV* ssv
+pMXE |SV* |sv_setsv_cow |SV* dsv|SV* ssv
#endif
#if defined(USE_PERLIO) && !defined(USE_SFIO)
@@ -1446,8 +1450,16 @@
p |int |get_debug_opts |char **s
#endif
Ap |void |save_set_svflags|SV* sv|U32 mask|U32 val
+Apod |void |hv_assert |HV* tb
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+sM |SV* |hv_delete_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int k_flags|I32 d_flags|U32 hash
+sM |HE* |hv_fetch_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int flags|int action|SV* val|U32 hash
+#endif
+Apd |void |hv_clear_placeholders|HV* hb
-END_EXTERN_C
+Apd |SV* |hv_scalar |HV* hv|
+p |SV* |magic_scalarpack|HV* hv|MAGIC* mg
+END_EXTERN_C
1.12 +54 -24 ponie/perl/embed.h
Index: embed.h
===================================================================
RCS file: /cvs/public/ponie/perl/embed.h,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- embed.h 10 Mar 2004 23:07:23 -0000 1.11
+++ embed.h 7 Apr 2004 10:37:27 -0000 1.12
@@ -2,7 +2,7 @@
* embed.h
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -409,6 +409,7 @@
#define is_uni_xdigit_lc Perl_is_uni_xdigit_lc
#define is_utf8_char Perl_is_utf8_char
#define is_utf8_string Perl_is_utf8_string
+#define is_utf8_string_loc Perl_is_utf8_string_loc
#define is_utf8_alnum Perl_is_utf8_alnum
#define is_utf8_alnumc Perl_is_utf8_alnumc
#define is_utf8_idfirst Perl_is_utf8_idfirst
@@ -967,13 +968,13 @@
#define sv_2bool Perl_sv_2bool
#define sv_2cv Perl_sv_2cv
#define sv_2io Perl_sv_2io
-#define sv_2iv Perl_sv_2iv
+#define sv_2iv_flags Perl_sv_2iv_flags
#define sv_2mortal Perl_sv_2mortal
#define sv_2nv Perl_sv_2nv
#define sv_2pvutf8 Perl_sv_2pvutf8
#define sv_2pvbyte Perl_sv_2pvbyte
#define sv_pvn_nomg Perl_sv_pvn_nomg
-#define sv_2uv Perl_sv_2uv
+#define sv_2uv_flags Perl_sv_2uv_flags
#define sv_iv Perl_sv_iv
#define sv_uv Perl_sv_uv
#define sv_nv Perl_sv_nv
@@ -1137,11 +1138,6 @@
#ifdef PERL_CORE
#define yyerror Perl_yyerror
#endif
-#ifdef USE_PURE_BISON
-#ifdef PERL_CORE
-#define yylex_r Perl_yylex_r
-#endif
-#endif
#ifdef PERL_CORE
#define yylex Perl_yylex
#endif
@@ -1305,6 +1301,11 @@
#define macro_IoSUBPROCESS Perl_macro_IoSUBPROCESS
#define macro_IoTYPE Perl_macro_IoTYPE
#define macro_IoFLAGS Perl_macro_IoFLAGS
+#define macro_GvGP Perl_macro_GvGP
+#define macro_GvNAME Perl_macro_GvNAME
+#define macro_GvNAMELEN Perl_macro_GvNAMELEN
+#define macro_GvSTASH Perl_macro_GvSTASH
+#define macro_GvFLAGS Perl_macro_GvFLAGS
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define do_trans_simple S_do_trans_simple
@@ -1362,9 +1363,6 @@
#define share_hek_flags S_share_hek_flags
#endif
#ifdef PERL_CORE
-#define hv_fetch_flags S_hv_fetch_flags
-#endif
-#ifdef PERL_CORE
#define hv_notallowed S_hv_notallowed
#endif
#endif
@@ -1576,6 +1574,9 @@
#define doparseform S_doparseform
#endif
#ifdef PERL_CORE
+#define num_overflow S_num_overflow
+#endif
+#ifdef PERL_CORE
#define dopoptoeval S_dopoptoeval
#endif
#ifdef PERL_CORE
@@ -2102,7 +2103,7 @@
#define my_atof2 Perl_my_atof2
#define my_socketpair Perl_my_socketpair
#ifdef PERL_COPY_ON_WRITE
-#ifdef PERL_CORE
+#if defined(PERL_CORE) || defined(PERL_EXT)
#define sv_setsv_cow Perl_sv_setsv_cow
#endif
#endif
@@ -2195,6 +2196,19 @@
#endif
#endif
#define save_set_svflags Perl_save_set_svflags
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define hv_delete_common S_hv_delete_common
+#endif
+#ifdef PERL_CORE
+#define hv_fetch_common S_hv_fetch_common
+#endif
+#endif
+#define hv_clear_placeholders Perl_hv_clear_placeholders
+#define hv_scalar Perl_hv_scalar
+#ifdef PERL_CORE
+#define magic_scalarpack Perl_magic_scalarpack
+#endif
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
@@ -2234,6 +2248,7 @@
#define ck_substr Perl_ck_substr
#define ck_svconst Perl_ck_svconst
#define ck_trunc Perl_ck_trunc
+#define ck_unpack Perl_ck_unpack
#define pp_aassign Perl_pp_aassign
#define pp_abs Perl_pp_abs
#define pp_accept Perl_pp_accept
@@ -2949,6 +2964,7 @@
#define is_uni_xdigit_lc(a) Perl_is_uni_xdigit_lc(aTHX_ a)
#define is_utf8_char(a) Perl_is_utf8_char(aTHX_ a)
#define is_utf8_string(a,b) Perl_is_utf8_string(aTHX_ a,b)
+#define is_utf8_string_loc(a,b,c) Perl_is_utf8_string_loc(aTHX_ a,b,c)
#define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a)
#define is_utf8_alnumc(a) Perl_is_utf8_alnumc(aTHX_ a)
#define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a)
@@ -3270,7 +3286,7 @@
#define newWHILEOP(a,b,c,d,e,f,g) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
#define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b)
#define scan_vstring(a,b) Perl_scan_vstring(aTHX_ a,b)
-#define scan_version(a,b) Perl_scan_version(aTHX_ a,b)
+#define scan_version(a,b,c) Perl_scan_version(aTHX_ a,b,c)
#define new_version(a) Perl_new_version(aTHX_ a)
#define upg_version(a) Perl_upg_version(aTHX_ a)
#define vnumify(a) Perl_vnumify(aTHX_ a)
@@ -3505,13 +3521,13 @@
#define sv_2bool(a) Perl_sv_2bool(aTHX_ a)
#define sv_2cv(a,b,c,d) Perl_sv_2cv(aTHX_ a,b,c,d)
#define sv_2io(a) Perl_sv_2io(aTHX_ a)
-#define sv_2iv(a) Perl_sv_2iv(aTHX_ a)
+#define sv_2iv_flags(a,b) Perl_sv_2iv_flags(aTHX_ a,b)
#define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a)
#define sv_2nv(a) Perl_sv_2nv(aTHX_ a)
#define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b)
#define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b)
#define sv_pvn_nomg(a,b) Perl_sv_pvn_nomg(aTHX_ a,b)
-#define sv_2uv(a) Perl_sv_2uv(aTHX_ a)
+#define sv_2uv_flags(a,b) Perl_sv_2uv_flags(aTHX_ a,b)
#define sv_iv(a) Perl_sv_iv(aTHX_ a)
#define sv_uv(a) Perl_sv_uv(aTHX_ a)
#define sv_nv(a) Perl_sv_nv(aTHX_ a)
@@ -3673,11 +3689,6 @@
#ifdef PERL_CORE
#define yyerror(a) Perl_yyerror(aTHX_ a)
#endif
-#ifdef USE_PURE_BISON
-#ifdef PERL_CORE
-#define yylex_r(a,b) Perl_yylex_r(aTHX_ a,b)
-#endif
-#endif
#ifdef PERL_CORE
#define yylex() Perl_yylex(aTHX)
#endif
@@ -3837,6 +3848,11 @@
#define macro_IoSUBPROCESS(a) Perl_macro_IoSUBPROCESS(aTHX_ a)
#define macro_IoTYPE(a) Perl_macro_IoTYPE(aTHX_ a)
#define macro_IoFLAGS(a) Perl_macro_IoFLAGS(aTHX_ a)
+#define macro_GvGP(a) Perl_macro_GvGP(aTHX_ a)
+#define macro_GvNAME(a) Perl_macro_GvNAME(aTHX_ a)
+#define macro_GvNAMELEN(a) Perl_macro_GvNAMELEN(aTHX_ a)
+#define macro_GvSTASH(a) Perl_macro_GvSTASH(aTHX_ a)
+#define macro_GvFLAGS(a) Perl_macro_GvFLAGS(aTHX_ a)
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define do_trans_simple(a) S_do_trans_simple(aTHX_ a)
@@ -3894,9 +3910,6 @@
#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)
#endif
#ifdef PERL_CORE
-#define hv_fetch_flags(a,b,c,d,e) S_hv_fetch_flags(aTHX_ a,b,c,d,e)
-#endif
-#ifdef PERL_CORE
#define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d)
#endif
#endif
@@ -4108,6 +4121,9 @@
#define doparseform(a) S_doparseform(aTHX_ a)
#endif
#ifdef PERL_CORE
+#define num_overflow S_num_overflow
+#endif
+#ifdef PERL_CORE
#define dopoptoeval(a) S_dopoptoeval(aTHX_ a)
#endif
#ifdef PERL_CORE
@@ -4633,7 +4649,7 @@
#define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b)
#define my_socketpair Perl_my_socketpair
#ifdef PERL_COPY_ON_WRITE
-#ifdef PERL_CORE
+#if defined(PERL_CORE) || defined(PERL_EXT)
#define sv_setsv_cow(a,b) Perl_sv_setsv_cow(aTHX_ a,b)
#endif
#endif
@@ -4726,6 +4742,19 @@
#endif
#endif
#define save_set_svflags(a,b,c) Perl_save_set_svflags(aTHX_ a,b,c)
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define hv_delete_common(a,b,c,d,e,f,g) S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
+#endif
+#ifdef PERL_CORE
+#define hv_fetch_common(a,b,c,d,e,f,g,h) S_hv_fetch_common(aTHX_ a,b,c,d,e,f,g,h)
+#endif
+#endif
+#define hv_clear_placeholders(a) Perl_hv_clear_placeholders(aTHX_ a)
+#define hv_scalar(a) Perl_hv_scalar(aTHX_ a)
+#ifdef PERL_CORE
+#define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b)
+#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
@@ -4765,6 +4794,7 @@
#define ck_substr(a) Perl_ck_substr(aTHX_ a)
#define ck_svconst(a) Perl_ck_svconst(aTHX_ a)
#define ck_trunc(a) Perl_ck_trunc(aTHX_ a)
+#define ck_unpack(a) Perl_ck_unpack(aTHX_ a)
#define pp_aassign() Perl_pp_aassign(aTHX)
#define pp_abs() Perl_pp_abs(aTHX)
#define pp_accept() Perl_pp_accept(aTHX)
1.3 +9 -15 ponie/perl/embedvar.h
Index: embedvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/embedvar.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- embedvar.h 19 Dec 2003 14:38:57 -0000 1.2
+++ embedvar.h 7 Apr 2004 10:37:27 -0000 1.3
@@ -1,7 +1,7 @@
/*
* embedvar.h
*
- * Copyright (C) 1999, 2000, 2001, 2002, 2003, by Larry Wall and others
+ * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -337,7 +337,6 @@
#define PL_oldname (vTHX->Ioldname)
#define PL_oldoldbufptr (vTHX->Ioldoldbufptr)
#define PL_op_mask (vTHX->Iop_mask)
-#define PL_op_seqmax (vTHX->Iop_seqmax)
#define PL_origalen (vTHX->Iorigalen)
#define PL_origargc (vTHX->Iorigargc)
#define PL_origargv (vTHX->Iorigargv)
@@ -367,6 +366,8 @@
#define PL_reentrant_retint (vTHX->Ireentrant_retint)
#define PL_regex_pad (vTHX->Iregex_pad)
#define PL_regex_padav (vTHX->Iregex_padav)
+#define PL_rehash_seed (vTHX->Irehash_seed)
+#define PL_rehash_seed_set (vTHX->Irehash_seed_set)
#define PL_replgv (vTHX->Ireplgv)
#define PL_rsfp (vTHX->Irsfp)
#define PL_rsfp_filters (vTHX->Irsfp_filters)
@@ -457,12 +458,8 @@
#define PL_xpvnv_root (vTHX->Ixpvnv_root)
#define PL_xrv_arenaroot (vTHX->Ixrv_arenaroot)
#define PL_xrv_root (vTHX->Ixrv_root)
-#define PL_yychar (vTHX->Iyychar)
-#define PL_yydebug (vTHX->Iyydebug)
-#define PL_yyerrflag (vTHX->Iyyerrflag)
-#define PL_yylval (vTHX->Iyylval)
-#define PL_yynerrs (vTHX->Iyynerrs)
-#define PL_yyval (vTHX->Iyyval)
+#define PL_yycharp (vTHX->Iyycharp)
+#define PL_yylvalp (vTHX->Iyylvalp)
#else /* !MULTIPLICITY */
@@ -642,7 +639,6 @@
#define PL_Ioldname PL_oldname
#define PL_Ioldoldbufptr PL_oldoldbufptr
#define PL_Iop_mask PL_op_mask
-#define PL_Iop_seqmax PL_op_seqmax
#define PL_Iorigalen PL_origalen
#define PL_Iorigargc PL_origargc
#define PL_Iorigargv PL_origargv
@@ -672,6 +668,8 @@
#define PL_Ireentrant_retint PL_reentrant_retint
#define PL_Iregex_pad PL_regex_pad
#define PL_Iregex_padav PL_regex_padav
+#define PL_Irehash_seed PL_rehash_seed
+#define PL_Irehash_seed_set PL_rehash_seed_set
#define PL_Ireplgv PL_replgv
#define PL_Irsfp PL_rsfp
#define PL_Irsfp_filters PL_rsfp_filters
@@ -762,12 +760,8 @@
#define PL_Ixpvnv_root PL_xpvnv_root
#define PL_Ixrv_arenaroot PL_xrv_arenaroot
#define PL_Ixrv_root PL_xrv_root
-#define PL_Iyychar PL_yychar
-#define PL_Iyydebug PL_yydebug
-#define PL_Iyyerrflag PL_yyerrflag
-#define PL_Iyylval PL_yylval
-#define PL_Iyynerrs PL_yynerrs
-#define PL_Iyyval PL_yyval
+#define PL_Iyycharp PL_yycharp
+#define PL_Iyylvalp PL_yylvalp
#define PL_TSv PL_Sv
#define PL_TXpv PL_Xpv
1.12 +12 -1 ponie/perl/global.sym
Index: global.sym
===================================================================
RCS file: /cvs/public/ponie/perl/global.sym,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- global.sym 10 Mar 2004 23:07:23 -0000 1.11
+++ global.sym 7 Apr 2004 10:37:27 -0000 1.12
@@ -2,7 +2,7 @@
# global.sym
#
# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999,
-# 2000, 2001, 2002, 2003, by Larry Wall and others
+# 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
@@ -204,6 +204,7 @@
Perl_is_uni_xdigit_lc
Perl_is_utf8_char
Perl_is_utf8_string
+Perl_is_utf8_string_loc
Perl_is_utf8_alnum
Perl_is_utf8_alnumc
Perl_is_utf8_idfirst
@@ -425,6 +426,7 @@
Perl_sv_2cv
Perl_sv_2io
Perl_sv_2iv
+Perl_sv_2iv_flags
Perl_sv_2mortal
Perl_sv_2nv
Perl_sv_2pv
@@ -432,6 +434,7 @@
Perl_sv_2pvbyte
Perl_sv_pvn_nomg
Perl_sv_2uv
+Perl_sv_2uv_flags
Perl_sv_iv
Perl_sv_uv
Perl_sv_nv
@@ -678,6 +681,11 @@
Perl_macro_IoSUBPROCESS
Perl_macro_IoTYPE
Perl_macro_IoFLAGS
+Perl_macro_GvGP
+Perl_macro_GvNAME
+Perl_macro_GvNAMELEN
+Perl_macro_GvSTASH
+Perl_macro_GvFLAGS
Perl_Slab_Alloc
Perl_Slab_Free
Perl_sv_setsv_flags
@@ -713,3 +721,6 @@
Perl_PerlIO_stdout
Perl_PerlIO_stderr
Perl_save_set_svflags
+Perl_hv_assert
+Perl_hv_clear_placeholders
+Perl_hv_scalar
1.4 +47 -2 ponie/perl/gv.c
Index: gv.c
===================================================================
RCS file: /cvs/public/ponie/perl/gv.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- gv.c 16 Mar 2004 17:07:25 -0000 1.3
+++ gv.c 7 Apr 2004 10:37:27 -0000 1.4
@@ -1,7 +1,7 @@
/* gv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -24,6 +24,47 @@
#include "EXTERN.h"
#define PERL_IN_GV_C
#include "perl.h"
+#include "parrot/extend.h"
+
+GP** Perl_macro_GvGP (pTHX_ GV *sv) {
+ if(SvPMC(sv)) {
+ XPVGV* data = (XPVGV*) Parrot_PMC_get_pointer(PL_Parrot, SvANY(sv));
+ return &(data->xgv_gp);
+ }
+ return &((XPVGV*)SvANY(sv))->xgv_gp;
+}
+
+char** Perl_macro_GvNAME (pTHX_ GV *sv) {
+ if(SvPMC(sv)) {
+ XPVGV* data = (XPVGV*) Parrot_PMC_get_pointer(PL_Parrot, SvANY(sv));
+ return &(data->xgv_name);
+ }
+ return &((XPVGV*)SvANY(sv))->xgv_name;
+}
+
+STRLEN* Perl_macro_GvNAMELEN (pTHX_ GV *sv) {
+ if(SvPMC(sv)) {
+ XPVGV* data = (XPVGV*) Parrot_PMC_get_pointer(PL_Parrot, SvANY(sv));
+ return &(data->xgv_namelen);
+ }
+ return &((XPVGV*)SvANY(sv))->xgv_namelen;
+}
+
+HV** Perl_macro_GvSTASH (pTHX_ GV *sv) {
+ if(SvPMC(sv)) {
+ XPVGV* data = (XPVGV*) Parrot_PMC_get_pointer(PL_Parrot, SvANY(sv));
+ return &(data->xgv_stash);
+ }
+ return &((XPVGV*)SvANY(sv))->xgv_stash;
+}
+
+U8* Perl_macro_GvFLAGS (pTHX_ GV *sv) {
+ if(SvPMC(sv)) {
+ XPVGV* data = (XPVGV*) Parrot_PMC_get_pointer(PL_Parrot, SvANY(sv));
+ return &(data->xgv_flags);
+ }
+ return &((XPVGV*)SvANY(sv))->xgv_flags;
+}
GV *
Perl_gv_AVadd(pTHX_ register GV *gv)
@@ -693,6 +734,10 @@
}
len = namend - name;
+ /* $_ should always be in main:: even when our'ed */
+ if (*name == '_' && !name[1])
+ stash = PL_defstash;
+
/* No stash in name, so see how we can default */
if (!stash) {
@@ -720,7 +765,7 @@
if (global)
stash = PL_defstash;
- else if ((COP*)PL_curcop == &PL_compiling) {
+ else if (IN_PERL_COMPILETIME) {
stash = PL_curstash;
if (add && (PL_hints & HINT_STRICT_VARS) &&
sv_type != SVt_PVCV &&
1.2 +5 -7 ponie/perl/gv.h
Index: gv.h
===================================================================
RCS file: /cvs/public/ponie/perl/gv.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- gv.h 9 Sep 2003 11:58:49 -0000 1.1
+++ gv.h 7 Apr 2004 10:37:27 -0000 1.2
@@ -23,13 +23,11 @@
char * gp_file; /* file first declared in (for -w) */
};
-#define GvXPVGV(gv) ((XPVGV*)SvANY(gv))
-
-#define GvGP(gv) (GvXPVGV(gv)->xgv_gp)
-#define GvNAME(gv) (GvXPVGV(gv)->xgv_name)
-#define GvNAMELEN(gv) (GvXPVGV(gv)->xgv_namelen)
-#define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash)
-#define GvFLAGS(gv) (GvXPVGV(gv)->xgv_flags)
+#define GvGP(gv) (*Perl_macro_GvGP(aTHX_ (GV *)(gv)))
+#define GvNAME(gv) (*Perl_macro_GvNAME(aTHX_ (GV *)(gv)))
+#define GvNAMELEN(gv) (*Perl_macro_GvNAMELEN(aTHX_ (GV *)(gv)))
+#define GvSTASH(gv) (*Perl_macro_GvSTASH(aTHX_ (GV *)(gv)))
+#define GvFLAGS(gv) (*Perl_macro_GvFLAGS(aTHX_ (GV *)(gv)))
/*
=head1 GV Functions
1.7 +857 -982 ponie/perl/hv.c
Index: hv.c
===================================================================
RCS file: /cvs/public/ponie/perl/hv.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -w -r1.6 -r1.7
--- hv.c 4 Mar 2004 12:13:51 -0000 1.6
+++ hv.c 7 Apr 2004 10:37:27 -0000 1.7
@@ -1,7 +1,7 @@
/* hv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -18,9 +18,12 @@
#include "EXTERN.h"
#define PERL_IN_HV_C
+#define PERL_HASH_INTERNAL_ACCESS
#include "perl.h"
#include "parrot/extend.h"
+#define HV_MAX_LENGTH_BEFORE_SPLIT 14
+
HE*** Perl_macro_HvARRAY (pTHX_ HV *hv) {
XPVHV* data = (XPVHV*) Parrot_PMC_get_pointer(PL_Parrot, SvANY(hv));
return (HE***)&data->xhv_array;
@@ -71,8 +74,6 @@
return &(data->xhv_placeholders);
}
-
-
STATIC HE*
S_new_he(pTHX)
{
@@ -130,6 +131,7 @@
STATIC HEK *
S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
+ int flags_masked = flags & HVhek_MASK;
char *k;
register HEK *hek;
@@ -139,7 +141,10 @@
HEK_KEY(hek)[len] = 0;
HEK_LEN(hek) = len;
HEK_HASH(hek) = hash;
- HEK_FLAGS(hek) = (unsigned char)flags;
+ HEK_FLAGS(hek) = (unsigned char)flags_masked;
+
+ if (flags & HVhek_FREEKEY)
+ Safefree(str);
return hek;
}
@@ -157,6 +162,7 @@
he = HeNEXT(he);
del_HE(ohe);
}
+ PL_hv_fetch_ent_mh = Nullhe;
}
#if defined(USE_ITHREADS)
@@ -217,13 +223,30 @@
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
* contains an SV* */
+#define HV_FETCH_ISSTORE 0x01
+#define HV_FETCH_ISEXISTS 0x02
+#define HV_FETCH_LVALUE 0x04
+#define HV_FETCH_JUST_SV 0x08
+
/*
-=for apidoc hv_fetch
+=for apidoc hv_store
-Returns the SV which corresponds to the specified key in the hash. The
-C<klen> is the length of the key. If C<lval> is set then the fetch will be
-part of a store. Check that the return value is non-null before
-dereferencing it to an C<SV*>.
+Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
+the length of the key. The C<hash> parameter is the precomputed hash
+value; if it is zero then Perl will compute it. The return value will be
+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<SV*>. Note that the caller is
+responsible for suitably incrementing the reference count of C<val> before
+the call, and decrementing it if the function returned NULL. Effectively
+a successful hv_store takes ownership of one reference to C<val>. This is
+usually what you want; a newly created SV has a reference count of one, so
+if all your code does is create SVs then store them in a hash, hv_store
+will own the only reference to the new SV, and your code doesn't need to do
+anything further to tidy up. hv_store is not implemented as a call to
+hv_store_ent, and does not create a temporary SV for the key, so if your
+key data is not already in SV form then use hv_store in preference to
+hv_store_ent.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
@@ -231,172 +254,144 @@
=cut
*/
-
SV**
-Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
+Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
{
- bool is_utf8 = FALSE;
- const char *keysave = key;
- int flags = 0;
-
- if (klen < 0) {
- klen = -klen;
- is_utf8 = TRUE;
- }
+ HE *hek;
+ STRLEN klen;
+ int flags;
- if (is_utf8) {
- STRLEN tmplen = klen;
- /* Just casting the &klen to (STRLEN) won't work well
- * if STRLEN and I32 are of different widths. --jhi */
- key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
- klen = tmplen;
- /* If we were able to downgrade here, then than means that we were
- passed in a key which only had chars 0-255, but was utf8 encoded. */
- if (is_utf8)
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
flags = HVhek_UTF8;
- /* If we found we were able to downgrade the string to bytes, then
- we should flag that it needs upgrading on keys or each. */
- if (key != keysave)
- flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ } else {
+ klen = klen_i32;
+ flags = 0;
}
-
- return hv_fetch_flags (hv, key, klen, lval, flags);
+ hek = hv_fetch_common (hv, NULL, key, klen, flags,
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0);
+ return hek ? &HeVAL(hek) : NULL;
}
-STATIC SV**
-S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
+SV**
+Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
+ register U32 hash, int flags)
{
- register XPVHV* xhv;
- register U32 hash;
- register HE *entry;
- SV *sv;
+ HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+ return hek ? &HeVAL(hek) : NULL;
+}
- if (!hv)
- return 0;
+/*
+=for apidoc hv_store_ent
- if (SvRMAGICAL(hv)) {
- /* All this clause seems to be utf8 unaware.
- By moving the utf8 stuff out to hv_fetch_flags I need to ensure
- key doesn't leak. I've not tried solving the utf8-ness.
- NWC.
+Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
+parameter is the precomputed hash value; if it is zero then Perl will
+compute it. The return value is the new hash entry so created. It will be
+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 the
+contents of the return value can be accessed using the C<He?> macros
+described here. Note that the caller is responsible for suitably
+incrementing the reference count of C<val> before the call, and
+decrementing it if the function returned NULL. Effectively a successful
+hv_store_ent takes ownership of one reference to C<val>. This is
+usually what you want; a newly created SV has a reference count of one, so
+if all your code does is create SVs then store them in a hash, hv_store
+will own the only reference to the new SV, and your code doesn't need to do
+anything further to tidy up. Note that hv_store_ent only reads the C<key>;
+unlike C<val> it does not take ownership of it, so maintaining the correct
+reference count on C<key> is entirely the caller's responsibility. hv_store
+is not implemented as a call to hv_store_ent, and does not create a temporary
+SV for the key, so if your key data is not already in SV form then use
+hv_store in preference to hv_store_ent.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
+information on how to use this function on tied hashes.
+
+=cut
*/
- if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
- sv = sv_newmortal();
- sv_upgrade(sv, SVt_PVLV);
- mg_copy((SV*)hv, sv, key, klen);
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- LvTYPE(sv) = 't';
- LvTARG(sv) = sv; /* fake (SV**) */
- return &(LvTARG(sv));
- }
-#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- I32 i;
- for (i = 0; i < klen; ++i)
- if (isLOWER(key[i])) {
- char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
- SV **ret = hv_fetch(hv, nkey, klen, 0);
- if (!ret && lval) {
- ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
- flags);
- } else if (flags & HVhek_FREEKEY)
- Safefree(key);
- return ret;
- }
- }
-#endif
- }
- /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
- avoid unnecessary pointer dereferencing. */
- xhv = (XPVHV*)HvDATA(hv);
- if (!xhv->xhv_array /* !HvARRAY(hv) */) {
- if (lval
-#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
- || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
-#endif
- )
- Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
- char);
- else {
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- return 0;
- }
+HE *
+Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
+{
+ return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
}
- PERL_HASH(hash, key, klen);
+/*
+=for apidoc hv_exists
- /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- for (; entry; entry = HeNEXT(entry)) {
- if (!HeKEY_hek(entry))
- continue;
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != (I32)klen)
- continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
- continue;
- /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
- flags is 1 if utf8. need HeKFLAGS(entry) also 1.
- xor is true if bits differ, in which case this isn't a match. */
- if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
- continue;
- if (lval && HeKFLAGS(entry) != flags) {
- /* We match if HVhek_UTF8 bit in our flags and hash key's match.
- But if entry was set previously with HVhek_WASUTF8 and key now
- doesn't (or vice versa) then we should change the key's flag,
- as this is assignment. */
- if (HvSHAREKEYS(hv)) {
- /* Need to swap the key we have for a key with the flags we
- need. As keys are shared we can't just write to the flag,
- so we share the new one, unshare the old one. */
- int flags_nofree = flags & ~HVhek_FREEKEY;
- HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
- unshare_hek (HeKEY_hek(entry));
- HeKEY_hek(entry) = new_hek;
- }
- else
- HeKFLAGS(entry) = flags;
- if (flags)
- HvHASKFLAGS_on(hv);
- }
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- /* if we find a placeholder, we pretend we haven't found anything */
- if (HeVAL(entry) == &PL_sv_placeholder)
- break;
- return &HeVAL(entry);
+Returns a boolean indicating whether the specified hash key exists. The
+C<klen> is the length of the key.
+=cut
+*/
+
+bool
+Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
+{
+ STRLEN klen;
+ int flags;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
}
-#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
- if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
- unsigned long len;
- char *env = PerlEnv_ENVgetenv_len(key,&len);
- if (env) {
- sv = newSVpvn(env,len);
- SvTAINTED_on(sv);
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- return hv_store(hv,key,klen,sv,hash);
- }
+ return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
+ ? TRUE : FALSE;
}
-#endif
- if (!entry && SvREADONLY(hv)) {
- S_hv_notallowed(aTHX_ flags, key, klen,
- "access disallowed key '%"SVf"' in"
- );
+
+/*
+=for apidoc hv_fetch
+
+Returns the SV which corresponds to the specified key in the hash. The
+C<klen> is the length of the key. If C<lval> is set then the fetch will be
+part of a store. Check that the return value is non-null before
+dereferencing it to an C<SV*>.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
+information on how to use this function on tied hashes.
+
+=cut
+*/
+
+SV**
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
+{
+ HE *hek;
+ STRLEN klen;
+ int flags;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
}
- if (lval) { /* gonna assign to this, so it better be there */
- sv = NEWSV(61,0);
- return hv_store_flags(hv,key,klen,sv,hash,flags);
+ hek = hv_fetch_common (hv, NULL, key, klen, flags,
+ HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
+ Nullsv, 0);
+ return hek ? &HeVAL(hek) : NULL;
}
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- return 0;
+
+/*
+=for apidoc hv_exists_ent
+
+Returns a boolean indicating whether the specified hash key exists. C<hash>
+can be a valid precomputed hash value, or 0 to ask for it to be
+computed.
+
+=cut
+*/
+
+bool
+Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+{
+ return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
+ ? TRUE : FALSE;
}
/* returns an HE * structure with the all fields set */
@@ -421,23 +416,55 @@
HE *
Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
{
- register XPVHV* xhv;
- register char *key;
- STRLEN klen;
- register HE *entry;
+ return hv_fetch_common(hv, keysv, NULL, 0, 0,
+ (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
+}
+
+STATIC HE *
+S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
+ int flags, int action, SV *val, register U32 hash)
+{
+ XPVHV* xhv;
+ U32 n_links;
+ HE *entry;
+ HE **oentry;
SV *sv;
bool is_utf8;
- int flags = 0;
- char *keysave;
+ int masked_flags;
if (!hv)
return 0;
- if (SvRMAGICAL(hv)) {
+ if (keysv) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ key = SvPV(keysv, klen);
+ flags = 0;
+ is_utf8 = (SvUTF8(keysv) != 0);
+ } else {
+ is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+ }
+
+ xhv = (XPVHV*)HvDATA(hv);
+ if (SvMAGICAL(hv)) {
+ if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
+ {
if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
+
+ /* XXX should be able to skimp on the HE/HEK here when
+ HV_FETCH_JUST_SV is true. */
+
+ if (!keysv) {
+ keysv = newSVpvn(key, klen);
+ if (is_utf8) {
+ SvUTF8_on(keysv);
+ }
+ } else {
keysv = newSVsv(keysv);
+ }
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+
/* grab a fake HE/HEK pair from the pool or make a new one */
entry = PL_hv_fetch_ent_mh;
if (entry)
@@ -453,120 +480,351 @@
HeVAL(entry) = sv;
sv_upgrade(sv, SVt_PVLV);
LvTYPE(sv) = 'T';
- LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
+ /* so we can free entry when freeing sv */
+ LvTARG(sv) = (SV*)entry;
+
+ /* XXX remove at some point? */
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+
return entry;
}
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
U32 i;
- key = SvPV(keysv, klen);
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
- SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
- (void)strupr(SvPVX(nkeysv));
- entry = hv_fetch_ent(hv, nkeysv, 0, 0);
- if (!entry && lval)
- entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
+ /* Would be nice if we had a routine to do the
+ copy and upercase in a single pass through. */
+ char *nkey = strupr(savepvn(key,klen));
+ /* Note that this fetch is for nkey (the uppercased
+ key) whereas the store is for key (the original) */
+ entry = hv_fetch_common(hv, Nullsv, nkey, klen,
+ HVhek_FREEKEY, /* free nkey */
+ 0 /* non-LVAL fetch */,
+ Nullsv /* no value */,
+ 0 /* compute hash */);
+ if (!entry && (action & HV_FETCH_LVALUE)) {
+ /* This call will free key if necessary.
+ Do it this way to encourage compiler to tail
+ call optimise. */
+ entry = hv_fetch_common(hv, keysv, key, klen,
+ flags, HV_FETCH_ISSTORE,
+ NEWSV(61,0), hash);
+ } else {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ }
return entry;
}
}
#endif
- }
+ } /* ISFETCH */
+ else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
+ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
+ SV* svret;
+ /* I don't understand why hv_exists_ent has svret and sv,
+ whereas hv_exists only had one. */
+ svret = sv_newmortal();
+ sv = sv_newmortal();
- keysave = key = SvPV(keysv, klen);
- xhv = (XPVHV*)HvDATA(hv);
- if (!xhv->xhv_array /* !HvARRAY(hv) */) {
- if (lval
-#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
- || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
-#endif
- )
- Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
- char);
- else
- return 0;
+ if (keysv || is_utf8) {
+ if (!keysv) {
+ keysv = newSVpvn(key, klen);
+ SvUTF8_on(keysv);
+ } else {
+ keysv = newSVsv(keysv);
}
+ mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
+ } else {
+ mg_copy((SV*)hv, sv, key, klen);
+ }
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
+ /* This cast somewhat evil, but I'm merely using NULL/
+ not NULL to return the boolean exists.
+ And I know hv is not NULL. */
+ return SvTRUE(svret) ? (HE *)hv : NULL;
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+ /* XXX This code isn't UTF8 clean. */
+ const char *keysave = key;
+ /* Will need to free this, so set FREEKEY flag. */
+ key = savepvn(key,klen);
+ key = (const char*)strupr((char*)key);
+ is_utf8 = 0;
+ hash = 0;
- is_utf8 = (SvUTF8(keysv)!=0);
+ if (flags & HVhek_FREEKEY) {
+ Safefree(keysave);
+ }
+ flags |= HVhek_FREEKEY;
+ }
+#endif
+ } /* ISEXISTS */
+ else if (action & HV_FETCH_ISSTORE) {
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+ if (needs_copy) {
+ bool save_taint = PL_tainted;
+ if (keysv || is_utf8) {
+ if (!keysv) {
+ keysv = newSVpvn(key, klen);
+ SvUTF8_on(keysv);
+ }
+ if (PL_tainting)
+ PL_tainted = SvTAINTED(keysv);
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+ } else {
+ mg_copy((SV*)hv, val, key, klen);
+ }
+
+ TAINT_IF(save_taint);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ return Nullhe;
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+ /* XXX This code isn't UTF8 clean. */
+ const char *keysave = key;
+ /* Will need to free this, so set FREEKEY flag. */
+ key = savepvn(key,klen);
+ key = (const char*)strupr((char*)key);
+ is_utf8 = 0;
+ hash = 0;
+
+ if (flags & HVhek_FREEKEY) {
+ Safefree(keysave);
+ }
+ flags |= HVhek_FREEKEY;
+ }
+#endif
+ }
+ } /* ISSTORE */
+ } /* SvMAGICAL */
+
+ if (!xhv->xhv_array /* !HvARRAY(hv) */) {
+ if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
+#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
+ || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
+#endif
+ )
+ Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
+#ifdef DYNAMIC_ENV_FETCH
+ else if (action & HV_FETCH_ISEXISTS) {
+ /* for an %ENV exists, if we do an insert it's by a recursive
+ store call, so avoid creating HvARRAY(hv) right now. */
+ }
+#endif
+ else {
+ /* XXX remove at some point? */
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+
+ return 0;
+ }
+ }
if (is_utf8) {
+ const char *keysave = key;
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (is_utf8)
- flags = HVhek_UTF8;
- if (key != keysave)
+ flags |= HVhek_UTF8;
+ else
+ flags &= ~HVhek_UTF8;
+ if (key != keysave) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(keysave);
flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
}
+ }
- if (!hash) {
- if SvIsCOW_shared_hash(keysv) {
+ if (HvREHASH(hv)) {
+ PERL_HASH_INTERNAL(hash, key, klen);
+ /* We don't have a pointer to the hv, so we have to replicate the
+ flag into every HEK, so that hv_iterkeysv can see it. */
+ /* And yes, you do need this even though you are not "storing" because
+ you can flip the flags below if doing an lval lookup. (And that
+ was put in to give the semantics Andreas was expecting.) */
+ flags |= HVhek_REHASH;
+ } else if (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
hash = SvUVX(keysv);
} else {
PERL_HASH(hash, key, klen);
}
}
+ masked_flags = (flags & HVhek_MASK);
+ n_links = 0;
+
+#ifdef DYNAMIC_ENV_FETCH
+ if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
+ else
+#endif
+ {
/* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- for (; entry; entry = HeNEXT(entry)) {
+ }
+ for (; entry; ++n_links, entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != (I32)klen)
continue;
if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
+ if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
continue;
- if (lval && HeKFLAGS(entry) != flags) {
- /* We match if HVhek_UTF8 bit in our flags and hash key's match.
- But if entry was set previously with HVhek_WASUTF8 and key now
- doesn't (or vice versa) then we should change the key's flag,
- as this is assignment. */
+
+ if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
+ if (HeKFLAGS(entry) != masked_flags) {
+ /* We match if HVhek_UTF8 bit in our flags and hash key's
+ match. But if entry was set previously with HVhek_WASUTF8
+ and key now doesn't (or vice versa) then we should change
+ the key's flag, as this is assignment. */
if (HvSHAREKEYS(hv)) {
/* Need to swap the key we have for a key with the flags we
- need. As keys are shared we can't just write to the flag,
- so we share the new one, unshare the old one. */
- int flags_nofree = flags & ~HVhek_FREEKEY;
- HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
+ need. As keys are shared we can't just write to the
+ flag, so we share the new one, unshare the old one. */
+ HEK *new_hek = share_hek_flags(key, klen, hash,
+ masked_flags);
unshare_hek (HeKEY_hek(entry));
HeKEY_hek(entry) = new_hek;
}
else
- HeKFLAGS(entry) = flags;
- if (flags)
+ HeKFLAGS(entry) = masked_flags;
+ if (masked_flags & HVhek_ENABLEHVKFLAGS)
HvHASKFLAGS_on(hv);
}
- if (key != keysave)
- Safefree(key);
- /* if we find a placeholder, we pretend we haven't found anything */
- if (HeVAL(entry) == &PL_sv_placeholder)
+ if (HeVAL(entry) == &PL_sv_placeholder) {
+ /* yes, can store into placeholder slot */
+ if (action & HV_FETCH_LVALUE) {
+ if (SvMAGICAL(hv)) {
+ /* This preserves behaviour with the old hv_fetch
+ implementation which at this point would bail out
+ with a break; (at "if we find a placeholder, we
+ pretend we haven't found anything")
+
+ That break mean that if a placeholder were found, it
+ caused a call into hv_store, which in turn would
+ check magic, and if there is no magic end up pretty
+ much back at this point (in hv_store's code). */
+ break;
+ }
+ /* LVAL fetch which actaully needs a store. */
+ val = NEWSV(61,0);
+ xhv->xhv_placeholders--;
+ } else {
+ /* store */
+ if (val != &PL_sv_placeholder)
+ xhv->xhv_placeholders--;
+ }
+ HeVAL(entry) = val;
+ } else if (action & HV_FETCH_ISSTORE) {
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = val;
+ }
+ } else if (HeVAL(entry) == &PL_sv_placeholder) {
+ /* if we find a placeholder, we pretend we haven't found
+ anything */
break;
+ }
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
- if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
+ if (!(action & HV_FETCH_ISSTORE)
+ && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
- return hv_store_ent(hv,keysv,sv,hash);
+ return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
+ hash);
}
}
#endif
- if (!entry && SvREADONLY(hv)) {
+
+ if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
S_hv_notallowed(aTHX_ flags, key, klen,
"access disallowed key '%"SVf"' in"
);
}
+ if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
+ /* Not doing some form of store, so return failure. */
if (flags & HVhek_FREEKEY)
Safefree(key);
- if (lval) { /* gonna assign to this, so it better be there */
- sv = NEWSV(61,0);
- return hv_store_ent(hv,keysv,sv,hash);
- }
return 0;
}
+ if (action & HV_FETCH_LVALUE) {
+ val = NEWSV(61,0);
+ if (SvMAGICAL(hv)) {
+ /* At this point the old hv_fetch code would call to hv_store,
+ which in turn might do some tied magic. So we need to make that
+ magic check happen. */
+ /* gonna assign to this, so it better be there */
+ return hv_fetch_common(hv, keysv, key, klen, flags,
+ HV_FETCH_ISSTORE, val, hash);
+ /* XXX Surely that could leak if the fetch-was-store fails?
+ Just like the hv_fetch. */
+ }
+ }
+
+ /* Welcome to hv_store... */
+
+ if (!xhv->xhv_array) {
+ /* Not sure if we can get here. I think the only case of oentry being
+ NULL is for %ENV with dynamic env fetch. But that should disappear
+ with magic in the previous code. */
+ Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
+ }
+
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+
+ entry = new_HE();
+ /* share_hek_flags will do the free for us. This might be considered
+ bad API design. */
+ if (HvSHAREKEYS(hv))
+ HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
+ else /* gotta do the real thing */
+ HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
+ HeVAL(entry) = val;
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+
+ if (val == &PL_sv_placeholder)
+ xhv->xhv_placeholders++;
+ if (masked_flags & HVhek_ENABLEHVKFLAGS)
+ HvHASKFLAGS_on(hv);
+
+ xhv->xhv_keys++; /* HvKEYS(hv)++ */
+ if (!n_links) { /* initial entry? */
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
+ } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
+ || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
+ /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
+ splits on a rehashed hash, as we're not going to split it again,
+ and if someone is lucky (evil) enough to get all the keys in one
+ list they could exhaust our memory as we repeatedly double the
+ number of buckets on every entry. Linear search feels a less worse
+ thing to do. */
+ hsplit(hv);
+ }
+
+ return entry;
+}
STATIC void
S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
@@ -588,872 +846,244 @@
}
/*
-=for apidoc hv_store
-
-Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
-the length of the key. The C<hash> parameter is the precomputed hash
-value; if it is zero then Perl will compute it. The return value will be
-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<SV*>. Note that the caller is
-responsible for suitably incrementing the reference count of C<val> before
-the call, and decrementing it if the function returned NULL. Effectively
-a successful hv_store takes ownership of one reference to C<val>. This is
-usually what you want; a newly created SV has a reference count of one, so
-if all your code does is create SVs then store them in a hash, hv_store
-will own the only reference to the new SV, and your code doesn't need to do
-anything further to tidy up. hv_store is not implemented as a call to
-hv_store_ent, and does not create a temporary SV for the key, so if your
-key data is not already in SV form then use hv_store in preference to
-hv_store_ent.
+=for apidoc hv_scalar
-See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
-information on how to use this function on tied hashes.
+Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
=cut
*/
-SV**
-Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
-{
- bool is_utf8 = FALSE;
- const char *keysave = key;
- int flags = 0;
-
- if (klen < 0) {
- klen = -klen;
- is_utf8 = TRUE;
- }
-
- if (is_utf8) {
- STRLEN tmplen = klen;
- /* Just casting the &klen to (STRLEN) won't work well
- * if STRLEN and I32 are of different widths. --jhi */
- key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
- klen = tmplen;
- /* If we were able to downgrade here, then than means that we were
- passed in a key which only had chars 0-255, but was utf8 encoded. */
- if (is_utf8)
- flags = HVhek_UTF8;
- /* If we found we were able to downgrade the string to bytes, then
- we should flag that it needs upgrading on keys or each. */
- if (key != keysave)
- flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
- }
-
- return hv_store_flags (hv, key, klen, val, hash, flags);
-}
-
-SV**
-Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
- register U32 hash, int flags)
+SV *
+Perl_hv_scalar(pTHX_ HV *hv)
{
- register XPVHV* xhv;
- register I32 i;
- register HE *entry;
- register HE **oentry;
-
- if (!hv)
- return 0;
+ MAGIC *mg;
+ SV *sv;
- xhv = (XPVHV*)HvDATA(hv);
- if (SvMAGICAL(hv)) {
- bool needs_copy;
- bool needs_store;
- hv_magic_check (hv, &needs_copy, &needs_store);
- if (needs_copy) {
- mg_copy((SV*)hv, val, key, klen);
- if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- return 0;
- }
-#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- key = savepvn(key,klen);
- key = (const char*)strupr((char*)key);
- hash = 0;
- }
-#endif
- }
+ if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
+ sv = magic_scalarpack(hv, mg);
+ return sv;
}
- if (flags)
- HvHASKFLAGS_on((SV*)hv);
-
- if (!hash)
- PERL_HASH(hash, key, klen);
-
- if (!xhv->xhv_array /* !HvARRAY(hv) */)
- Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
- char);
-
- /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- i = 1;
-
- for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != (I32)klen)
- continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
- continue;
- if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
- continue;
- if (HeVAL(entry) == &PL_sv_placeholder)
- xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
- else
- SvREFCNT_dec(HeVAL(entry));
- if (flags & HVhek_PLACEHOLD) {
- /* We have been requested to insert a placeholder. Currently
- only Storable is allowed to do this. */
- xhv->xhv_placeholders++;
- HeVAL(entry) = &PL_sv_placeholder;
- } else
- HeVAL(entry) = val;
-
- if (HeKFLAGS(entry) != flags) {
- /* We match if HVhek_UTF8 bit in our flags and hash key's match.
- But if entry was set previously with HVhek_WASUTF8 and key now
- doesn't (or vice versa) then we should change the key's flag,
- as this is assignment. */
- if (HvSHAREKEYS(hv)) {
- /* Need to swap the key we have for a key with the flags we
- need. As keys are shared we can't just write to the flag,
- so we share the new one, unshare the old one. */
- int flags_nofree = flags & ~HVhek_FREEKEY;
- HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
- unshare_hek (HeKEY_hek(entry));
- HeKEY_hek(entry) = new_hek;
- }
+ sv = sv_newmortal();
+ if (HvFILL((HV*)hv))
+ Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
+ (long)HvFILL(hv), (long)HvMAX(hv) + 1);
else
- HeKFLAGS(entry) = flags;
- }
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- return &HeVAL(entry);
- }
-
- if (SvREADONLY(hv)) {
- S_hv_notallowed(aTHX_ flags, key, klen,
- "access disallowed key '%"SVf"' to"
- );
- }
-
- entry = new_HE();
- /* share_hek_flags will do the free for us. This might be considered
- bad API design. */
- if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
- else /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
- if (flags & HVhek_PLACEHOLD) {
- /* We have been requested to insert a placeholder. Currently
- only Storable is allowed to do this. */
- xhv->xhv_placeholders++;
- HeVAL(entry) = &PL_sv_placeholder;
- } else
- HeVAL(entry) = val;
- HeNEXT(entry) = *oentry;
- *oentry = entry;
-
- xhv->xhv_keys++; /* HvKEYS(hv)++ */
- if (i) { /* initial entry? */
- xhv->xhv_fill++; /* HvFILL(hv)++ */
- } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
- hsplit(hv);
- }
-
- return &HeVAL(entry);
-}
-
-/*
-=for apidoc hv_store_ent
-
-Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
-parameter is the precomputed hash value; if it is zero then Perl will
-compute it. The return value is the new hash entry so created. It will be
-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 the
-contents of the return value can be accessed using the C<He?> macros
-described here. Note that the caller is responsible for suitably
-incrementing the reference count of C<val> before the call, and
-decrementing it if the function returned NULL. Effectively a successful
-hv_store_ent takes ownership of one reference to C<val>. This is
-usually what you want; a newly created SV has a reference count of one, so
-if all your code does is create SVs then store them in a hash, hv_store
-will own the only reference to the new SV, and your code doesn't need to do
-anything further to tidy up. Note that hv_store_ent only reads the C<key>;
-unlike C<val> it does not take ownership of it, so maintaining the correct
-reference count on C<key> is entirely the caller's responsibility. hv_store
-is not implemented as a call to hv_store_ent, and does not create a temporary
-SV for the key, so if your key data is not already in SV form then use
-hv_store in preference to hv_store_ent.
-
-See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
-information on how to use this function on tied hashes.
-
-=cut
-*/
-
-HE *
-Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
-{
- XPVHV* xhv;
- char *key;
- STRLEN klen;
- I32 i;
- HE *entry;
- HE **oentry;
- bool is_utf8;
- int flags = 0;
- char *keysave;
-
- if (!hv)
- return 0;
-
- xhv = (XPVHV*)HvDATA(hv);
- if (SvMAGICAL(hv)) {
- bool needs_copy;
- bool needs_store;
- hv_magic_check (hv, &needs_copy, &needs_store);
- if (needs_copy) {
- bool save_taint = PL_tainted;
- if (PL_tainting)
- PL_tainted = SvTAINTED(keysv);
- keysv = sv_2mortal(newSVsv(keysv));
- mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
- TAINT_IF(save_taint);
- if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
- return Nullhe;
-#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- key = SvPV(keysv, klen);
- keysv = sv_2mortal(newSVpvn(key,klen));
- (void)strupr(SvPVX(keysv));
- hash = 0;
- }
-#endif
- }
- }
-
- keysave = key = SvPV(keysv, klen);
- is_utf8 = (SvUTF8(keysv) != 0);
-
- if (is_utf8) {
- key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
- if (is_utf8)
- flags = HVhek_UTF8;
- if (key != keysave)
- flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
- HvHASKFLAGS_on((SV*)hv);
- }
-
- if (!hash) {
- if SvIsCOW_shared_hash(keysv) {
- hash = SvUVX(keysv);
- } else {
- PERL_HASH(hash, key, klen);
- }
- }
-
- if (!xhv->xhv_array /* !HvARRAY(hv) */)
- Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
- char);
-
- /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- i = 1;
- entry = *oentry;
- for (; entry; i=0, entry = HeNEXT(entry)) {
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != (I32)klen)
- continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
- continue;
- if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
- continue;
- if (HeVAL(entry) == &PL_sv_placeholder)
- xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
- else
- SvREFCNT_dec(HeVAL(entry));
- HeVAL(entry) = val;
- if (HeKFLAGS(entry) != flags) {
- /* We match if HVhek_UTF8 bit in our flags and hash key's match.
- But if entry was set previously with HVhek_WASUTF8 and key now
- doesn't (or vice versa) then we should change the key's flag,
- as this is assignment. */
- if (HvSHAREKEYS(hv)) {
- /* Need to swap the key we have for a key with the flags we
- need. As keys are shared we can't just write to the flag,
- so we share the new one, unshare the old one. */
- int flags_nofree = flags & ~HVhek_FREEKEY;
- HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
- unshare_hek (HeKEY_hek(entry));
- HeKEY_hek(entry) = new_hek;
- }
- else
- HeKFLAGS(entry) = flags;
- }
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- return entry;
- }
-
- if (SvREADONLY(hv)) {
- S_hv_notallowed(aTHX_ flags, key, klen,
- "access disallowed key '%"SVf"' to"
- );
- }
-
- entry = new_HE();
- /* share_hek_flags will do the free for us. This might be considered
- bad API design. */
- if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
- else /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
- HeVAL(entry) = val;
- HeNEXT(entry) = *oentry;
- *oentry = entry;
-
- xhv->xhv_keys++; /* HvKEYS(hv)++ */
- if (i) { /* initial entry? */
- xhv->xhv_fill++; /* HvFILL(hv)++ */
- if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
- hsplit(hv);
- }
-
- return entry;
-}
-
-/*
-=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<klen> is the length of the key.
-The C<flags> value will normally be zero; if set to G_DISCARD then NULL
-will be returned.
-
-=cut
-*/
-
-SV *
-Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
-{
- register XPVHV* xhv;
- register I32 i;
- register U32 hash;
- register HE *entry;
- register HE **oentry;
- SV **svp;
- SV *sv;
- bool is_utf8 = FALSE;
- int k_flags = 0;
- const char *keysave = key;
-
- if (!hv)
- return Nullsv;
- if (klen < 0) {
- klen = -klen;
- is_utf8 = TRUE;
- }
- if (SvRMAGICAL(hv)) {
- bool needs_copy;
- bool needs_store;
- hv_magic_check (hv, &needs_copy, &needs_store);
-
- if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
- sv = *svp;
- if (SvMAGICAL(sv)) {
- mg_clear(sv);
- }
- if (!needs_store) {
- if (mg_find(sv, PERL_MAGIC_tiedelem)) {
- /* No longer an element */
- sv_unmagic(sv, PERL_MAGIC_tiedelem);
- return sv;
- }
- return Nullsv; /* element cannot be deleted */
- }
-#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- sv = sv_2mortal(newSVpvn(key,klen));
- key = strupr(SvPVX(sv));
- }
-#endif
- }
- }
- xhv = (XPVHV*)HvDATA(hv);
- if (!xhv->xhv_array /* !HvARRAY(hv) */)
- return Nullsv;
-
- if (is_utf8) {
- STRLEN tmplen = klen;
- /* See the note in hv_fetch(). --jhi */
- key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
- klen = tmplen;
- if (is_utf8)
- k_flags = HVhek_UTF8;
- if (key != keysave)
- k_flags |= HVhek_FREEKEY;
- }
-
- PERL_HASH(hash, key, klen);
-
- /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- entry = *oentry;
- i = 1;
- for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != (I32)klen)
- continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
- continue;
- if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
- continue;
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- /* if placeholder is here, it's already been deleted.... */
- if (HeVAL(entry) == &PL_sv_placeholder)
- {
- if (SvREADONLY(hv))
- return Nullsv; /* if still SvREADONLY, leave it deleted. */
- else {
- /* okay, really delete the placeholder... */
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
- if (xhv->xhv_keys == 0)
- HvHASKFLAGS_off(hv);
- xhv->xhv_placeholders--;
- return Nullsv;
- }
- }
- else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
- S_hv_notallowed(aTHX_ k_flags, key, klen,
- "delete readonly key '%"SVf"' from"
- );
- }
-
- if (flags & G_DISCARD)
- sv = Nullsv;
- else {
- sv = sv_2mortal(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
- }
-
- /*
- * If a restricted hash, rather than really deleting the entry, put
- * a placeholder there. This marks the key as being "approved", so
- * we can still access via not-really-existing key without raising
- * an error.
- */
- if (SvREADONLY(hv)) {
- HeVAL(entry) = &PL_sv_placeholder;
- /* We'll be saving this slot, so the number of allocated keys
- * doesn't go down, but the number placeholders goes up */
- xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
- } else {
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
- if (xhv->xhv_keys == 0)
- HvHASKFLAGS_off(hv);
- }
- return sv;
- }
- if (SvREADONLY(hv)) {
- S_hv_notallowed(aTHX_ k_flags, key, klen,
- "access disallowed key '%"SVf"' from"
- );
- }
-
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- return Nullsv;
-}
-
-/*
-=for apidoc hv_delete_ent
-
-Deletes a key/value pair in the hash. The value SV is removed from the
-hash and returned to the caller. The C<flags> value will normally be zero;
-if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
-precomputed hash value, or 0 to ask for it to be computed.
-
-=cut
-*/
-
-SV *
-Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
-{
- register XPVHV* xhv;
- register I32 i;
- register char *key;
- STRLEN klen;
- register HE *entry;
- register HE **oentry;
- SV *sv;
- bool is_utf8;
- int k_flags = 0;
- char *keysave;
-
- if (!hv)
- return Nullsv;
- if (SvRMAGICAL(hv)) {
- bool needs_copy;
- bool needs_store;
- hv_magic_check (hv, &needs_copy, &needs_store);
-
- if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
- sv = HeVAL(entry);
- if (SvMAGICAL(sv)) {
- mg_clear(sv);
- }
- if (!needs_store) {
- if (mg_find(sv, PERL_MAGIC_tiedelem)) {
- /* No longer an element */
- sv_unmagic(sv, PERL_MAGIC_tiedelem);
- return sv;
- }
- return Nullsv; /* element cannot be deleted */
- }
-#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- key = SvPV(keysv, klen);
- keysv = sv_2mortal(newSVpvn(key,klen));
- (void)strupr(SvPVX(keysv));
- hash = 0;
- }
-#endif
- }
- }
- xhv = (XPVHV*)HvDATA(hv);
- if (!xhv->xhv_array /* !HvARRAY(hv) */)
- return Nullsv;
-
- keysave = key = SvPV(keysv, klen);
- is_utf8 = (SvUTF8(keysv) != 0);
-
- if (is_utf8) {
- key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
- if (is_utf8)
- k_flags = HVhek_UTF8;
- if (key != keysave)
- k_flags |= HVhek_FREEKEY;
- }
-
- if (!hash)
- PERL_HASH(hash, key, klen);
-
- /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- entry = *oentry;
- i = 1;
- for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != (I32)klen)
- continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
- continue;
- if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
- continue;
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
-
- /* if placeholder is here, it's already been deleted.... */
- if (HeVAL(entry) == &PL_sv_placeholder)
- {
- if (SvREADONLY(hv))
- return Nullsv; /* if still SvREADONLY, leave it deleted. */
-
- /* okay, really delete the placeholder. */
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
- if (xhv->xhv_keys == 0)
- HvHASKFLAGS_off(hv);
- xhv->xhv_placeholders--;
- return Nullsv;
- }
- else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
- S_hv_notallowed(aTHX_ k_flags, key, klen,
- "delete readonly key '%"SVf"' from"
- );
- }
-
- if (flags & G_DISCARD)
- sv = Nullsv;
- else {
- sv = sv_2mortal(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
- }
-
- /*
- * If a restricted hash, rather than really deleting the entry, put
- * a placeholder there. This marks the key as being "approved", so
- * we can still access via not-really-existing key without raising
- * an error.
- */
- if (SvREADONLY(hv)) {
- HeVAL(entry) = &PL_sv_placeholder;
- /* We'll be saving this slot, so the number of allocated keys
- * doesn't go down, but the number placeholders goes up */
- xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
- } else {
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
- if (xhv->xhv_keys == 0)
- HvHASKFLAGS_off(hv);
- }
- return sv;
- }
- if (SvREADONLY(hv)) {
- S_hv_notallowed(aTHX_ k_flags, key, klen,
- "delete disallowed key '%"SVf"' from"
- );
- }
-
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- return Nullsv;
-}
-
-/*
-=for apidoc hv_exists
-
-Returns a boolean indicating whether the specified hash key exists. The
-C<klen> is the length of the key.
-
-=cut
-*/
-
-bool
-Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
-{
- register XPVHV* xhv;
- register U32 hash;
- register HE *entry;
- SV *sv;
- bool is_utf8 = FALSE;
- const char *keysave = key;
- int k_flags = 0;
-
- if (!hv)
- return 0;
-
- if (klen < 0) {
- klen = -klen;
- is_utf8 = TRUE;
- }
-
- if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
- sv = sv_newmortal();
- mg_copy((SV*)hv, sv, key, klen);
- magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
- return (bool)SvTRUE(sv);
- }
-#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- sv = sv_2mortal(newSVpvn(key,klen));
- key = strupr(SvPVX(sv));
- }
-#endif
- }
-
- xhv = (XPVHV*)HvDATA(hv);
-#ifndef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array /* !HvARRAY(hv) */)
- return 0;
-#endif
-
- if (is_utf8) {
- STRLEN tmplen = klen;
- /* See the note in hv_fetch(). --jhi */
- key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
- klen = tmplen;
- if (is_utf8)
- k_flags = HVhek_UTF8;
- if (key != keysave)
- k_flags |= HVhek_FREEKEY;
- }
-
- PERL_HASH(hash, key, klen);
-
-#ifdef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
- else
-#endif
- /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- for (; entry; entry = HeNEXT(entry)) {
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != klen)
- continue;
- if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
- continue;
- if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
- continue;
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- /* If we find the key, but the value is a placeholder, return false. */
- if (HeVAL(entry) == &PL_sv_placeholder)
- return FALSE;
+ sv_setiv(sv, 0);
- return TRUE;
- }
-#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
- if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
- unsigned long len;
- char *env = PerlEnv_ENVgetenv_len(key,&len);
- if (env) {
- sv = newSVpvn(env,len);
- SvTAINTED_on(sv);
- (void)hv_store(hv,key,klen,sv,hash);
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- return TRUE;
+ return sv;
}
+
+/*
+=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<klen> is the length of the key.
+The C<flags> value will normally be zero; if set to G_DISCARD then NULL
+will be returned.
+
+=cut
+*/
+
+SV *
+Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
+{
+ STRLEN klen;
+ int k_flags = 0;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ k_flags |= HVhek_UTF8;
+ } else {
+ klen = klen_i32;
}
-#endif
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- return FALSE;
+ return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
}
-
/*
-=for apidoc hv_exists_ent
+=for apidoc hv_delete_ent
-Returns a boolean indicating whether the specified hash key exists. C<hash>
-can be a valid precomputed hash value, or 0 to ask for it to be
-computed.
+Deletes a key/value pair in the hash. The value SV is removed from the
+hash and returned to the caller. The C<flags> value will normally be zero;
+if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
+precomputed hash value, or 0 to ask for it to be computed.
=cut
*/
-bool
-Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+SV *
+Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
+{
+ return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
+}
+
+STATIC SV *
+S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
+ int k_flags, I32 d_flags, U32 hash)
{
register XPVHV* xhv;
- register char *key;
- STRLEN klen;
+ register I32 i;
register HE *entry;
+ register HE **oentry;
SV *sv;
bool is_utf8;
- char *keysave;
- int k_flags = 0;
+ int masked_flags;
if (!hv)
- return 0;
+ return Nullsv;
+
+ if (keysv) {
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
+ key = SvPV(keysv, klen);
+ k_flags = 0;
+ is_utf8 = (SvUTF8(keysv) != 0);
+ } else {
+ is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
+ }
if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
- SV* svret = sv_newmortal();
- sv = sv_newmortal();
- keysv = sv_2mortal(newSVsv(keysv));
- mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
- magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
- return (bool)SvTRUE(svret);
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+
+ if (needs_copy) {
+ entry = hv_fetch_common(hv, keysv, key, klen,
+ k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
+ Nullsv, hash);
+ sv = entry ? HeVAL(entry) : NULL;
+ if (sv) {
+ if (SvMAGICAL(sv)) {
+ mg_clear(sv);
+ }
+ if (!needs_store) {
+ if (mg_find(sv, PERL_MAGIC_tiedelem)) {
+ /* No longer an element */
+ sv_unmagic(sv, PERL_MAGIC_tiedelem);
+ return sv;
+ }
+ return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- key = SvPV(keysv, klen);
+ /* XXX This code isn't UTF8 clean. */
keysv = sv_2mortal(newSVpvn(key,klen));
- (void)strupr(SvPVX(keysv));
+ if (k_flags & HVhek_FREEKEY) {
+ Safefree(key);
+ }
+ key = strupr(SvPVX(keysv));
+ is_utf8 = 0;
+ k_flags = 0;
hash = 0;
}
#endif
}
-
+ }
+ }
xhv = (XPVHV*)HvDATA(hv);
-#ifndef DYNAMIC_ENV_FETCH
if (!xhv->xhv_array /* !HvARRAY(hv) */)
- return 0;
-#endif
+ return Nullsv;
- keysave = key = SvPV(keysv, klen);
- is_utf8 = (SvUTF8(keysv) != 0);
if (is_utf8) {
+ const char *keysave = key;
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
if (is_utf8)
- k_flags = HVhek_UTF8;
- if (key != keysave)
- k_flags |= HVhek_FREEKEY;
+ k_flags |= HVhek_UTF8;
+ else
+ k_flags &= ~HVhek_UTF8;
+ if (key != keysave) {
+ if (k_flags & HVhek_FREEKEY) {
+ /* This shouldn't happen if our caller does what we expect,
+ but strictly the API allows it. */
+ Safefree(keysave);
+ }
+ k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
}
- if (!hash)
+ HvHASKFLAGS_on((SV*)hv);
+ }
+
+ if (HvREHASH(hv)) {
+ PERL_HASH_INTERNAL(hash, key, klen);
+ } else if (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ hash = SvUVX(keysv);
+ } else {
PERL_HASH(hash, key, klen);
+ }
+ }
-#ifdef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
- else
-#endif
- /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- for (; entry; entry = HeNEXT(entry)) {
+ masked_flags = (k_flags & HVhek_MASK);
+
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ entry = *oentry;
+ i = 1;
+ for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != (I32)klen)
continue;
if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
+ if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
continue;
if (k_flags & HVhek_FREEKEY)
Safefree(key);
- /* If we find the key, but the value is a placeholder, return false. */
+
+ /* if placeholder is here, it's already been deleted.... */
if (HeVAL(entry) == &PL_sv_placeholder)
- return FALSE;
- return TRUE;
+ {
+ return Nullsv;
}
-#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
- if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
- unsigned long len;
- char *env = PerlEnv_ENVgetenv_len(key,&len);
- if (env) {
- sv = newSVpvn(env,len);
- SvTAINTED_on(sv);
- (void)hv_store_ent(hv,keysv,sv,hash);
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- return TRUE;
+ else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ S_hv_notallowed(aTHX_ k_flags, key, klen,
+ "delete readonly key '%"SVf"' from"
+ );
}
+
+ if (d_flags & G_DISCARD)
+ sv = Nullsv;
+ else {
+ sv = sv_2mortal(HeVAL(entry));
+ HeVAL(entry) = &PL_sv_placeholder;
}
-#endif
+
+ /*
+ * If a restricted hash, rather than really deleting the entry, put
+ * a placeholder there. This marks the key as being "approved", so
+ * we can still access via not-really-existing key without raising
+ * an error.
+ */
+ if (SvREADONLY(hv)) {
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = &PL_sv_placeholder;
+ /* We'll be saving this slot, so the number of allocated keys
+ * doesn't go down, but the number placeholders goes up */
+ xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+ } else {
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ if (xhv->xhv_keys == 0)
+ HvHASKFLAGS_off(hv);
+ }
+ return sv;
+ }
+ if (SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ k_flags, key, klen,
+ "delete disallowed key '%"SVf"' from"
+ );
+ }
+
if (k_flags & HVhek_FREEKEY)
Safefree(key);
- return FALSE;
+ return Nullsv;
}
STATIC void
@@ -1468,6 +1098,19 @@
register HE **bep;
register HE *entry;
register HE **oentry;
+ int longest_chain = 0;
+ int was_shared;
+
+ /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
+ hv, (int) oldsize);*/
+
+ if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) {
+ /* Can make this clear any placeholders first for non-restricted hashes,
+ even though Storable rebuilds restricted hashes by putting in all the
+ placeholders (first) before turning on the readonly flag, because
+ Storable always pre-splits the hash. */
+ hv_clear_placeholders(hv);
+ }
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
@@ -1498,6 +1141,9 @@
aep = (HE**)a;
for (i=0; i<oldsize; i++,aep++) {
+ int left_length = 0;
+ int right_length = 0;
+
if (!*aep) /* non-existent */
continue;
bep = aep+oldsize;
@@ -1508,14 +1154,90 @@
if (!*bep)
xhv->xhv_fill++; /* HvFILL(hv)++ */
*bep = entry;
+ right_length++;
continue;
}
- else
+ else {
oentry = &HeNEXT(entry);
+ left_length++;
+ }
}
if (!*aep) /* everything moved */
xhv->xhv_fill--; /* HvFILL(hv)-- */
+ /* I think we don't actually need to keep track of the longest length,
+ merely flag if anything is too long. But for the moment while
+ developing this code I'll track it. */
+ if (left_length > longest_chain)
+ longest_chain = left_length;
+ if (right_length > longest_chain)
+ longest_chain = right_length;
+ }
+
+
+ /* Pick your policy for "hashing isn't working" here: */
+ if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
+ || HvREHASH(hv)) {
+ return;
+ }
+
+ if (hv == PL_strtab) {
+ /* Urg. Someone is doing something nasty to the string table.
+ Can't win. */
+ return;
+ }
+
+ /* Awooga. Awooga. Pathological data. */
+ /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
+ longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
+
+ ++newsize;
+ Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
+ was_shared = HvSHAREKEYS(hv);
+
+ xhv->xhv_fill = 0;
+ HvSHAREKEYS_off(hv);
+ HvREHASH_on(hv);
+
+ aep = (HE **) xhv->xhv_array;
+
+ for (i=0; i<newsize; i++,aep++) {
+ entry = *aep;
+ while (entry) {
+ /* We're going to trash this HE's next pointer when we chain it
+ into the new hash below, so store where we go next. */
+ HE *next = HeNEXT(entry);
+ UV hash;
+
+ /* Rehash it */
+ PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
+
+ if (was_shared) {
+ /* Unshare it. */
+ HEK *new_hek
+ = save_hek_flags(HeKEY(entry), HeKLEN(entry),
+ hash, HeKFLAGS(entry));
+ unshare_hek (HeKEY_hek(entry));
+ HeKEY_hek(entry) = new_hek;
+ } else {
+ /* Not shared, so simply write the new hash in. */
+ HeHASH(entry) = hash;
+ }
+ /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
+ HEK_REHASH_on(HeKEY_hek(entry));
+ /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
+
+ /* Copy oentry to the correct new chain. */
+ bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
+ if (!*bep)
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
+ HeNEXT(entry) = *bep;
+ *bep = entry;
+
+ entry = next;
+ }
}
+ Safefree (xhv->xhv_array);
+ xhv->xhv_array = a; /* HvARRAY(hv) = a */
}
void
@@ -1619,6 +1341,7 @@
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
#endif
+
xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
@@ -1636,7 +1359,6 @@
return hv;
hv_max = HvMAX(ohv);
- /* XXX disabled optimization in ponie because it was breaking things */
if (!SvMAGICAL((SV *)ohv)) {
/* It's an ordinary hash, so copy it fast. AMS 20010804 */
STRLEN i;
@@ -1761,9 +1483,11 @@
if (!hv)
return;
+ DEBUG_A(Perl_hv_assert(aTHX_ hv));
+
xhv = (XPVHV*)HvDATA(hv);
- if (SvREADONLY(hv)) {
+ if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
/* restricted hash: convert all keys to placeholders */
I32 i;
HE* entry;
@@ -1784,7 +1508,7 @@
}
}
}
- return;
+ goto reset;
}
hfreeentries(hv);
@@ -1797,6 +1521,70 @@
mg_clear((SV*)hv);
HvHASKFLAGS_off(hv);
+ HvREHASH_off(hv);
+ reset:
+ HvEITER(hv) = NULL;
+}
+
+/*
+=for apidoc hv_clear_placeholders
+
+Clears any placeholders from a hash. If a restricted hash has any of its keys
+marked as readonly and the key is subsequently deleted, the key is not actually
+deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
+it so it will be ignored by future operations such as iterating over the hash,
+but will still allow the hash to have a value reaasigned to the key at some
+future point. This function clears any such placeholder keys from the hash.
+See Hash::Util::lock_keys() for an example of its use.
+
+=cut
+*/
+
+void
+Perl_hv_clear_placeholders(pTHX_ HV *hv)
+{
+ I32 items = (I32)HvPLACEHOLDERS(hv);
+ I32 i = HvMAX(hv);
+
+ if (items == 0)
+ return;
+
+ do {
+ /* Loop down the linked list heads */
+ int first = 1;
+ HE **oentry = &(HvARRAY(hv))[i];
+ HE *entry = *oentry;
+
+ if (!entry)
+ continue;
+
+ for (; entry; entry = *oentry) {
+ if (HeVAL(entry) == &PL_sv_placeholder) {
+ *oentry = HeNEXT(entry);
+ if (first && !*oentry)
+ HvFILL(hv)--; /* This linked list is now empty. */
+ if (HvEITER(hv))
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+
+ if (--items == 0) {
+ /* Finished. */
+ HvTOTALKEYS(hv) -= HvPLACEHOLDERS(hv);
+ if (HvKEYS(hv) == 0)
+ HvHASKFLAGS_off(hv);
+ HvPLACEHOLDERS(hv) = 0;
+ return;
+ }
+ } else {
+ oentry = &HeNEXT(entry);
+ first = 0;
+ }
+ }
+ } while (--i >= 0);
+ /* You can't get here, hence assertion should always fail. */
+ assert (items == 0);
+ assert (0);
}
STATIC void
@@ -1853,6 +1641,7 @@
register XPVHV* xhv;
if (!hv)
return;
+ DEBUG_A(Perl_hv_assert(aTHX_ hv));
xhv = (XPVHV*)HvDATA(hv);
hfreeentries(hv);
Safefree(xhv->xhv_array /* HvARRAY(hv) */);
@@ -2036,6 +1825,9 @@
hv_free_ent(hv, oldentry);
}
+ /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
+ PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
+
xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
}
@@ -2093,6 +1885,16 @@
sv = newSVpvn ((char*)as_utf8, utf8_len);
SvUTF8_on (sv);
Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
+ } else if (flags & HVhek_REHASH) {
+ /* We don't have a pointer to the hv, so we have to replicate the
+ flag into every HEK. This hv is using custom a hasing
+ algorithm. Hence we can't return a shared string scalar, as
+ that would contain the (wrong) hash value, and might get passed
+ into an hv routine with a regular hash */
+
+ sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+ if (HEK_UTF8(hek))
+ SvUTF8_on (sv);
} else {
sv = newSVpvn_share(HEK_KEY(hek),
(HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
@@ -2315,6 +2117,9 @@
if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
hv_store(PL_strtab, str, len, Nullsv, hash);
+
+ Can't rehash the shared string table, so not sure if it's worth
+ counting the number of entries in the linked list
*/
xhv = (XPVHV*)HvDATA(PL_strtab);
/* assert(xhv_array != 0) */
@@ -2335,14 +2140,14 @@
}
if (!found) {
entry = new_HE();
- HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
+ HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;
xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
xhv->xhv_fill++; /* HvFILL(hv)++ */
- if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
+ } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
hsplit(PL_strtab);
}
}
@@ -2354,4 +2159,74 @@
Safefree(str);
return HeKEY_hek(entry);
+}
+
+
+/*
+=for apidoc hv_assert
+
+Check that a hash is in an internally consistent state.
+
+=cut
+*/
+
+void
+Perl_hv_assert(pTHX_ HV *hv)
+{
+ HE* entry;
+ int withflags = 0;
+ int placeholders = 0;
+ int real = 0;
+ int bad = 0;
+ I32 riter = HvRITER(hv);
+ HE *eiter = HvEITER(hv);
+
+ (void)hv_iterinit(hv);
+
+ while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
+ /* sanity check the values */
+ if (HeVAL(entry) == &PL_sv_placeholder) {
+ placeholders++;
+ } else {
+ real++;
+ }
+ /* sanity check the keys */
+ if (HeSVKEY(entry)) {
+ /* Don't know what to check on SV keys. */
+ } else if (HeKUTF8(entry)) {
+ withflags++;
+ if (HeKWASUTF8(entry)) {
+ PerlIO_printf(Perl_debug_log,
+ "hash key has both WASUFT8 and UTF8: '%.*s'\n",
+ (int) HeKLEN(entry), HeKEY(entry));
+ bad = 1;
+ }
+ } else if (HeKWASUTF8(entry)) {
+ withflags++;
+ }
+ }
+ if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
+ if (HvUSEDKEYS(hv) != real) {
+ PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
+ (int) real, (int) HvUSEDKEYS(hv));
+ bad = 1;
+ }
+ if (HvPLACEHOLDERS(hv) != placeholders) {
+ PerlIO_printf(Perl_debug_log,
+ "Count %d placeholder(s), but hash reports %d\n",
+ (int) placeholders, (int) HvPLACEHOLDERS(hv));
+ bad = 1;
+ }
+ }
+ if (withflags && ! HvHASKFLAGS(hv)) {
+ PerlIO_printf(Perl_debug_log,
+ "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
+ withflags);
+ bad = 1;
+ }
+ if (bad) {
+ sv_dump((SV *)hv);
+ }
+ HvRITER(hv) = riter; /* Restore hash iterator state */
+ HvEITER(hv) = eiter;
}
1.6 +40 -2 ponie/perl/hv.h
Index: hv.h
===================================================================
RCS file: /cvs/public/ponie/perl/hv.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- hv.h 4 Mar 2004 12:10:16 -0000 1.5
+++ hv.h 7 Apr 2004 10:37:27 -0000 1.6
@@ -25,8 +25,8 @@
I32 hek_len; /* length of hash key */
char hek_key[1]; /* variable-length hash key */
/* the hash-key is \0-terminated */
- /* after the \0 there is a byte for flags, such as whether the key is
- UTF8 */
+ /* after the \0 there is a byte for flags, such as whether the key
+ is UTF-8 */
};
/* hash structure: */
@@ -89,6 +89,25 @@
(hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \
} STMT_END
+/* Only hv.c and mod_perl should be doing this. */
+#ifdef PERL_HASH_INTERNAL_ACCESS
+#define PERL_HASH_INTERNAL(hash,str,len) \
+ STMT_START { \
+ register const char *s_PeRlHaSh_tmp = str; \
+ register const unsigned char *s_PeRlHaSh = (const unsigned char *)s_PeRlHaSh_tmp; \
+ register I32 i_PeRlHaSh = len; \
+ register U32 hash_PeRlHaSh = PL_rehash_seed; \
+ while (i_PeRlHaSh--) { \
+ hash_PeRlHaSh += *s_PeRlHaSh++; \
+ hash_PeRlHaSh += (hash_PeRlHaSh << 10); \
+ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 6); \
+ } \
+ hash_PeRlHaSh += (hash_PeRlHaSh << 3); \
+ hash_PeRlHaSh ^= (hash_PeRlHaSh >> 11); \
+ (hash) = (hash_PeRlHaSh + (hash_PeRlHaSh << 15)); \
+ } STMT_END
+#endif
+
/*
=head1 Hash Manipulation Functions
@@ -198,6 +217,7 @@
* is utf8 (including 8 bit keys that were entered as utf8, and need upgrading
* when retrieved during iteration. It may still be set when there are no longer
* any utf8 keys.
+ * See HVhek_ENABLEHVKFLAGS for the trigger.
*/
#define HvHASKFLAGS(hv) (SvFLAGS(hv) & SVphv_HASKFLAGS)
#define HvHASKFLAGS_on(hv) (SvFLAGS(hv) |= SVphv_HASKFLAGS)
@@ -207,6 +227,10 @@
#define HvLAZYDEL_on(hv) (SvFLAGS(hv) |= SVphv_LAZYDEL)
#define HvLAZYDEL_off(hv) (SvFLAGS(hv) &= ~SVphv_LAZYDEL)
+#define HvREHASH(hv) (SvFLAGS(hv) & SVphv_REHASH)
+#define HvREHASH_on(hv) (SvFLAGS(hv) |= SVphv_REHASH)
+#define HvREHASH_off(hv) (SvFLAGS(hv) &= ~SVphv_REHASH)
+
/* Maybe amagical: */
/* #define HV_AMAGICmb(hv) (SvFLAGS(hv) & (SVpgv_badAM | SVpgv_AM)) */
@@ -228,6 +252,7 @@
#define HeKLEN(he) HEK_LEN(HeKEY_hek(he))
#define HeKUTF8(he) HEK_UTF8(HeKEY_hek(he))
#define HeKWASUTF8(he) HEK_WASUTF8(HeKEY_hek(he))
+#define HeKREHASH(he) HEK_REHASH(HeKEY_hek(he))
#define HeKLEN_UTF8(he) (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he))
#define HeKFLAGS(he) HEK_FLAGS(HeKEY_hek(he))
#define HeVAL(he) (he)->hent_val
@@ -258,17 +283,30 @@
#define HVhek_UTF8 0x01 /* Key is utf8 encoded. */
#define HVhek_WASUTF8 0x02 /* Key is bytes here, but was supplied as utf8. */
+#define HVhek_REHASH 0x04 /* This key is in an hv using a custom HASH . */
#define HVhek_FREEKEY 0x100 /* Internal flag to say key is malloc()ed. */
#define HVhek_PLACEHOLD 0x200 /* Internal flag to create placeholder.
* (may change, but Storable is a core module) */
#define HVhek_MASK 0xFF
+/* Which flags enable HvHASKFLAGS? Somewhat a hack on a hack, as
+ HVhek_REHASH is only needed because the rehash flag has to be duplicated
+ into all keys as hv_iternext has no access to the hash flags. At this
+ point Storable's tests get upset, because sometimes hashes are "keyed"
+ and sometimes not, depending on the order of data insertion, and whether
+ it triggered rehashing. So currently HVhek_REHAS is exempt.
+*/
+
+#define HVhek_ENABLEHVKFLAGS (HVhek_MASK - HVhek_REHASH)
+
#define HEK_UTF8(hek) (HEK_FLAGS(hek) & HVhek_UTF8)
#define HEK_UTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_UTF8)
#define HEK_UTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_UTF8)
#define HEK_WASUTF8(hek) (HEK_FLAGS(hek) & HVhek_WASUTF8)
#define HEK_WASUTF8_on(hek) (HEK_FLAGS(hek) |= HVhek_WASUTF8)
#define HEK_WASUTF8_off(hek) (HEK_FLAGS(hek) &= ~HVhek_WASUTF8)
+#define HEK_REHASH(hek) (HEK_FLAGS(hek) & HVhek_REHASH)
+#define HEK_REHASH_on(hek) (HEK_FLAGS(hek) |= HVhek_REHASH)
/* calculate HV array allocation */
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1.5 +15 -18 ponie/perl/intrpvar.h
Index: intrpvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/intrpvar.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- intrpvar.h 10 Mar 2004 22:49:43 -0000 1.4
+++ intrpvar.h 7 Apr 2004 10:37:27 -0000 1.5
@@ -169,7 +169,7 @@
PERLVAR(Ioldname, char *) /* what to preserve mode on */
PERLVAR(IArgv, char **) /* stuff to free from do_aexec, vfork safe */
PERLVAR(ICmd, char *) /* stuff to free from do_aexec, vfork safe */
-PERLVAR(Igensym, I32) /* next symbol for getsym() to define */
+PERLVARI(Igensym, I32, 0) /* next symbol for getsym() to define */
PERLVAR(Ipreambled, bool)
PERLVAR(Ipreambleav, AV *)
PERLVARI(Ilaststatval, int, -1)
@@ -233,10 +233,9 @@
PERLVAR(Igid, Gid_t) /* current real group id */
PERLVAR(Iegid, Gid_t) /* current effective group id */
PERLVAR(Inomemok, bool) /* let malloc context handle nomem */
-PERLVAR(Ian, U32) /* malloc sequence number */
-PERLVAR(Icop_seqmax, U32) /* statement sequence number */
-PERLVAR(Iop_seqmax, U16) /* op sequence number */
-PERLVAR(Ievalseq, U32) /* eval sequence number */
+PERLVARI(Ian, U32, 0) /* malloc sequence number */
+PERLVARI(Icop_seqmax, U32, 0) /* statement sequence number */
+PERLVARI(Ievalseq, U32, 0) /* eval sequence number */
PERLVAR(Iorigenviron, char **)
PERLVAR(Iorigalen, U32)
PERLVAR(Ipidstatus, HV *) /* pid-to-status mappings for waitpid */
@@ -290,7 +289,7 @@
#ifdef CSH
PERLVARI(Icshname, char *, CSH)
-PERLVAR(Icshlen, I32)
+PERLVARI(Icshlen, I32, 0)
#endif
PERLVAR(Ilex_state, U32) /* next token is determined */
@@ -342,17 +341,17 @@
PERLVAR(Iin_my, I32) /* we're compiling a "my" (or "our") declaration */
PERLVAR(Iin_my_stash, HV *) /* declared class of this "my" declaration */
#ifdef FCRYPT
-PERLVAR(Icryptseen, bool) /* has fast crypt() been initialized? */
+PERLVARI(Icryptseen, bool, FALSE) /* has fast crypt() been initialized? */
#endif
PERLVAR(Ihints, U32) /* pragma-tic compile-time flags */
PERLVAR(Idebug, VOL U32) /* flags given to -D switch */
-PERLVAR(Iamagic_generation, long)
+PERLVARI(Iamagic_generation, long, 0)
#ifdef USE_LOCALE_COLLATE
-PERLVAR(Icollation_ix, U32) /* Collation generation index */
+PERLVARI(Icollation_ix, U32, 0) /* Collation generation index */
PERLVAR(Icollation_name,char *) /* Name of current collation */
PERLVARI(Icollation_standard, bool, TRUE)
/* Assume simple collation */
@@ -398,14 +397,10 @@
PERLVAR(Ilast_swash_slen, STRLEN)
/* perly.c globals */
-PERLVAR(Iyydebug, int)
-PERLVAR(Iyynerrs, int)
-PERLVAR(Iyyerrflag, int)
-PERLVAR(Iyychar, int)
-PERLVAR(Iyyval, YYSTYPE)
-PERLVAR(Iyylval, YYSTYPE)
+PERLVAR(Iyycharp, int *)
+PERLVAR(Iyylvalp, YYSTYPE *)
-PERLVAR(Iglob_index, int)
+PERLVARI(Iglob_index, int, 0)
PERLVAR(Isrand_called, bool)
PERLVARA(Iuudmap,256, char)
PERLVAR(Ibitcount, char *)
@@ -464,7 +459,7 @@
PERLVAR(Ireentrant_buffer, REENTR*) /* here we store the _r buffers */
#endif
-PERLVAR(Isavebegin, bool) /* save BEGINs for compiler */
+PERLVARI(Isavebegin, bool, FALSE) /* save BEGINs for compiler */
PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */
PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */
@@ -531,9 +526,11 @@
PERLVARI(Icv_has_eval, I32, 0) /* PL_compcv includes an entereval or similar */
+PERLVARI(Irehash_seed, UV, 0) /* 582 hash initializer */
-PERLVAR(IParrot, Parrot_Interp)
+PERLVARI(Irehash_seed_set, bool, FALSE) /* 582 hash initialized? */
+PERLVAR(IParrot, Parrot_Interp)
/* New variables must be added to the very end, before this comment,
* for binary compatibility (the offsets of the old members must not change).
1.4 +93 -28 ponie/perl/mg.c
Index: mg.c
===================================================================
RCS file: /cvs/public/ponie/perl/mg.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- mg.c 29 Feb 2004 18:02:19 -0000 1.3
+++ mg.c 7 Apr 2004 10:37:27 -0000 1.4
@@ -1,7 +1,7 @@
/* mg.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -48,6 +48,14 @@
static void restore_magic(pTHX_ void *p);
static void unwind_handler_stack(pTHX_ void *p);
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+void setruid(uid_t id);
+void seteuid(uid_t id);
+void setrgid(uid_t id);
+void setegid(uid_t id);
+#endif
+
/*
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
*/
@@ -380,7 +388,7 @@
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len > 0)
+ if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
@@ -393,10 +401,7 @@
return 0;
}
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
-#endif
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
@@ -565,9 +570,6 @@
case '\004': /* ^D */
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
-#if defined(YYDEBUG) && defined(DEBUGGING)
- PL_yydebug = DEBUG_p_TEST;
-#endif
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
@@ -619,8 +621,12 @@
SetLastError(dwErr);
}
#else
+ {
+ int saveerrno = errno;
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
+ errno = saveerrno;
+ }
#endif
#endif
#endif
@@ -643,8 +649,10 @@
sv_setsv(sv, &PL_sv_undef);
break;
case '\017': /* ^O & ^OPEN */
- if (*(mg->mg_ptr+1) == '\0')
+ if (*(mg->mg_ptr+1) == '\0') {
sv_setpv(sv, PL_osname);
+ SvTAINTED_off(sv);
+ }
else if (strEQ(mg->mg_ptr, "\017PEN")) {
if (!PL_compiling.cop_io)
sv_setsv(sv, &PL_sv_undef);
@@ -1530,6 +1538,7 @@
call_method("CLEAR", G_SCALAR|G_DISCARD);
POPSTACK;
LEAVE;
+
return 0;
}
@@ -1564,6 +1573,41 @@
return magic_methpack(sv,mg,"EXISTS");
}
+SV *
+Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
+{
+ dSP;
+ SV *retval = &PL_sv_undef;
+ SV *tied = SvTIED_obj((SV*)hv, mg);
+ HV *pkg = SvSTASH((SV*)SvRV(tied));
+
+ if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
+ SV *key;
+ if (HvEITER(hv))
+ /* we are in an iteration so the hash cannot be empty */
+ return &PL_sv_yes;
+ /* no xhv_eiter so now use FIRSTKEY */
+ key = sv_newmortal();
+ magic_nextpack((SV*)hv, mg, key);
+ HvEITER(hv) = NULL; /* need to reset iterator */
+ return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
+ }
+
+ /* there is a SCALAR method that we can call */
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP, 1);
+ PUSHs(tied);
+ PUTBACK;
+
+ if (call_method("SCALAR", G_SCALAR))
+ retval = *PL_stack_sp--;
+ POPSTACK;
+ LEAVE;
+ return retval;
+}
+
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
@@ -1740,16 +1784,21 @@
sv_utf8_upgrade(lsv);
sv_pos_u2b(lsv, &lvoff, &lvlen);
sv_insert(lsv, lvoff, lvlen, tmps, len);
+ LvTARGLEN(sv) = sv_len_utf8(sv);
SvUTF8_on(lsv);
}
else if (lsv && SvUTF8(lsv)) {
sv_pos_u2b(lsv, &lvoff, &lvlen);
+ LvTARGLEN(sv) = len;
tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
sv_insert(lsv, lvoff, lvlen, tmps, len);
Safefree(tmps);
}
- else
+ else {
sv_insert(lsv, lvoff, lvlen, tmps, len);
+ LvTARGLEN(sv) = len;
+ }
+
return 0;
}
@@ -1886,14 +1935,14 @@
SV **svp = AvARRAY(av);
I32 i = AvFILLp(av);
while (i >= 0) {
- if (svp[i] && svp[i] != &PL_sv_undef) {
+ if (svp[i]) {
if (!SvWEAKREF(svp[i]))
Perl_croak(aTHX_ "panic: magic_killbackrefs");
/* XXX Should we check that it hasn't changed? */
SvRV(svp[i]) = 0;
(void)SvOK_off(svp[i]);
SvWEAKREF_off(svp[i]);
- svp[i] = &PL_sv_undef;
+ svp[i] = Nullsv;
}
i--;
}
@@ -2048,13 +2097,15 @@
break;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
- if (PL_osname)
+ if (PL_osname) {
Safefree(PL_osname);
- if (SvOK(sv))
- PL_osname = savepv(SvPV(sv,len));
- else
PL_osname = Nullch;
}
+ if (SvOK(sv)) {
+ TAINT_PROPER("assigning to $^O");
+ PL_osname = savepv(SvPV(sv,len));
+ }
+ }
else if (strEQ(mg->mg_ptr, "\017PEN")) {
if (!PL_compiling.cop_io)
PL_compiling.cop_io = newSVsv(sv);
@@ -2064,7 +2115,8 @@
break;
case '\020': /* ^P */
PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- if (PL_perldb && !PL_DBsingle)
+ if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
+ && !PL_DBsingle)
init_debugger();
break;
case '\024': /* ^T */
@@ -2236,9 +2288,14 @@
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
#else
- if (PL_uid == PL_euid) /* special case $< = $> */
+ if (PL_uid == PL_euid) { /* special case $< = $> */
+#ifdef PERL_DARWIN
+ /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
+ if (PL_uid != 0 && PerlProc_getuid() == 0)
+ (void)PerlProc_setuid(0);
+#endif
(void)PerlProc_setuid(PL_uid);
- else {
+ } else {
PL_uid = PerlProc_getuid();
Perl_croak(aTHX_ "setruid() not implemented");
}
@@ -2391,10 +2448,10 @@
#endif
/* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
- if (len >= (STRLEN)PL_origalen) {
- /* Longer than original, will be truncated. */
- Copy(s, PL_origargv[0], PL_origalen, char);
- PL_origargv[0][PL_origalen - 1] = 0;
+ if (len >= (STRLEN)PL_origalen-1) {
+ /* Longer than original, will be truncated. We assume that
+ * PL_origalen bytes are available. */
+ Copy(s, PL_origargv[0], PL_origalen-1, char);
}
else {
/* Shorter than original, will be padded. */
@@ -2407,9 +2464,10 @@
* --jhi */
(int)' ',
PL_origalen - len - 1);
+ }
+ PL_origargv[0][PL_origalen-1] = 0;
for (i = 1; i < PL_origargc; i++)
PL_origargv[i] = 0;
- }
UNLOCK_DOLLARZERO_MUTEX;
break;
#endif
@@ -2569,6 +2627,13 @@
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
{
+#ifdef PERL_COPY_ON_WRITE
+ /* While magic was saved (and off) sv_setsv may well have seen
+ this SV as a prime candidate for COW. */
+ if (SvIsCOW(sv))
+ sv_force_normal(sv);
+#endif
+
if (mgs->mgs_flags)
SvFLAGS(sv) |= mgs->mgs_flags;
else
1.6 +81 -36 ponie/perl/perl.c
Index: perl.c
===================================================================
RCS file: /cvs/public/ponie/perl/perl.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- perl.c 19 Feb 2004 16:35:01 -0000 1.5
+++ perl.c 7 Apr 2004 10:37:27 -0000 1.6
@@ -1,7 +1,7 @@
/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -365,6 +365,10 @@
/* Destroy the main CV and syntax tree */
if (PL_main_root) {
+ /* ensure comppad/curpad to refer to main's pad */
+ if (CvPADLIST(PL_main_cv)) {
+ PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+ }
op_free(PL_main_root);
PL_main_root = Nullop;
}
@@ -388,6 +392,7 @@
* Non-referenced objects are on their own.
*/
sv_clean_objs();
+ PL_sv_objcount = 0;
}
/* unhook hooks which will soon be, or use, destroyed data */
@@ -513,6 +518,8 @@
PL_e_script = Nullsv;
}
+ PL_perldb = 0;
+
/* magical thingies */
SvREFCNT_dec(PL_ofs_sv); /* $, */
@@ -572,6 +579,15 @@
PL_stderrgv = Nullgv;
PL_last_in_gv = Nullgv;
PL_replgv = Nullgv;
+ PL_DBgv = Nullgv;
+ PL_DBline = Nullgv;
+ PL_DBsub = Nullgv;
+ PL_DBsingle = Nullsv;
+ PL_DBtrace = Nullsv;
+ PL_DBsignal = Nullsv;
+ PL_DBassertion = Nullsv;
+ PL_DBcv = Nullcv;
+ PL_dbargs = Nullav;
PL_debstash = Nullhv;
/* reset so print() ends up where we expect */
@@ -606,6 +622,7 @@
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
SvREFCNT_dec(PL_numeric_radix_sv);
+ PL_numeric_radix_sv = Nullsv;
#endif
/* clear utf8 character classes */
@@ -744,6 +761,7 @@
#ifdef USE_ITHREADS
/* free the pointer table used for cloning */
ptr_table_free(PL_ptr_table);
+ PL_ptr_table = (PTR_TBL_t*)NULL;
#endif
/* free special SVs */
@@ -787,6 +805,7 @@
}
}
#endif
+ PL_sv_count = 0;
#if defined(PERLIO_LAYERS)
@@ -801,22 +820,32 @@
SvREFCNT(&PL_sv_undef) = 0;
SvREADONLY_off(&PL_sv_undef);
- SvREFCNT(&PL_sv_placeholder) = 0;
- SvREADONLY_off(&PL_sv_placeholder);
-
Safefree(PL_origfilename);
+ PL_origfilename = Nullch;
Safefree(PL_reg_start_tmp);
+ PL_reg_start_tmp = (char**)NULL;
+ PL_reg_start_tmpl = 0;
if (PL_reg_curpm)
Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_psig_ptr);
+ PL_psig_ptr = (SV**)NULL;
Safefree(PL_psig_name);
+ PL_psig_name = (SV**)NULL;
Safefree(PL_bitcount);
+ PL_bitcount = Nullch;
Safefree(PL_psig_pend);
+ PL_psig_pend = (int*)NULL;
+ PL_formfeed = Nullsv;
+ Safefree(PL_ofmt);
+ PL_ofmt = Nullch;
nuke_stacks();
+ PL_tainting = FALSE;
+ PL_taint_warn = FALSE;
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
+ PL_debug = 0;
DEBUG_P(debprofdump());
@@ -923,11 +952,11 @@
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
/* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
* This MUST be done before any hash stores or fetches take place.
- * If you set PL_hash_seed (and assumedly also PL_hash_seed_set) yourself,
- * it is your responsibility to provide a good random seed!
+ * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
+ * yourself, it is your responsibility to provide a good random seed!
* You can also define PERL_HASH_SEED in compile time, see hv.h. */
- if (!PL_hash_seed_set)
- PL_hash_seed = get_hash_seed();
+ if (!PL_rehash_seed_set)
+ PL_rehash_seed = get_hash_seed();
{
char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
@@ -936,7 +965,7 @@
if (i == 1)
PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
- PL_hash_seed);
+ PL_rehash_seed);
}
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
@@ -947,7 +976,7 @@
{
/* Set PL_origalen be the sum of the contiguous argv[]
* elements plus the size of the env in case that it is
- * contiguous with the argv[]. This is used in mg.c:mg_set()
+ * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
* as the maximum modifiable length of $0. In the worst case
* the area we are able to modify is limited to the size of
* the original argv[0]. (See below for 'contiguous', though.)
@@ -1028,7 +1057,7 @@
}
}
}
- PL_origalen = s - PL_origargv[0];
+ PL_origalen = s - PL_origargv[0] + 1;
}
if (PL_do_undump) {
@@ -1342,7 +1371,6 @@
}
}
switch_end:
- sv_setsv(get_sv("/", TRUE), PL_rs);
if (
#ifndef SECURE_INTERNAL_GETENV
@@ -1680,6 +1708,7 @@
if (!PL_restartop) {
DEBUG_x(dump_all());
+ if (!DEBUG_q_TEST)
PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
PTR2UV(thr)));
@@ -2255,11 +2284,11 @@
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
-"-C enable native wide character system interfaces",
+"-C[number/list] enables the listed Unicode features",
"-c check syntax only (runs BEGIN and CHECK blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
-"-e 'command' one line of program (several -e's allowed, omit programfile)",
+"-e program one line of program (several -e's allowed, omit programfile)",
"-F/pattern/ split() pattern for -a switch (//'s are optional)",
"-i[extension] edit <> files in place (makes backup if extension supplied)",
"-Idirectory specify @INC/#include directory (several -I's allowed)",
@@ -2270,16 +2299,16 @@
"-P run program through C preprocessor before compilation",
"-s enable rudimentary parsing for switches after programfile",
"-S look for programfile using PATH environment variable",
-"-T enable tainting checks",
"-t enable tainting warnings",
+"-T enable tainting checks",
"-u dump core after parsing program",
"-U allow unsafe operations",
"-v print version, subversion (includes VERY IMPORTANT perl info)",
"-V[:variable] print configuration summary (or a single Config.pm variable)",
"-w enable many useful warnings (RECOMMENDED)",
"-W enable all warnings",
-"-X disable all warnings",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"-X disable all warnings",
"\n",
NULL
};
@@ -2302,7 +2331,7 @@
int i = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxu HXDSTRJvC";
+ static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
for (; isALNUM(**s); (*s)++) {
char *d = strchr(debopts,**s);
@@ -2372,6 +2401,7 @@
PL_rs = newSVpvn(&ch, 1);
}
}
+ sv_setsv(get_sv("/", TRUE), PL_rs);
return s + numlen;
}
case 'C':
@@ -2510,9 +2540,10 @@
if (!PL_preambleav)
PL_preambleav = newAV();
if (*++s) {
- SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
+ SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
+ sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
sv_catpv(sv,s);
- sv_catpv(sv,"})");
+ sv_catpvn(sv, "\0)", 2);
s+=strlen(s);
av_push(PL_preambleav, sv);
}
@@ -2546,9 +2577,10 @@
Perl_croak(aTHX_ "Module name required with -%c option",
s[-1]);
sv_catpvn(sv, start, s-start);
- sv_catpv(sv, " split(/,/,q{");
+ sv_catpv(sv, " split(/,/,q");
+ sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
+ sv_catpvn(sv, "\0)", 2);
}
s += strlen(s);
if (!PL_preambleav)
@@ -3166,8 +3198,10 @@
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
- Perl_croak(aTHX_ "Permission denied");
+ if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
#else
/* If we can swap euid and uid, then we can determine access rights
* with a simple stat of the file, and then compare device and
@@ -3187,15 +3221,20 @@
#endif
|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
- if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
- Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
+ if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n"); /* testing full pathname here */
+ }
#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
- Perl_croak(aTHX_ "Permission denied");
+ if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
#endif
if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
tmpstatbuf.st_ino != PL_statbuf.st_ino) {
(void)PerlIO_close(PL_rsfp);
+ errno = EPERM;
Perl_croak(aTHX_ "Permission denied\n");
}
if (
@@ -3214,8 +3253,10 @@
#endif /* HAS_SETREUID */
#endif /* IAMSUID */
- if (!S_ISREG(PL_statbuf.st_mode))
- Perl_croak(aTHX_ "Permission denied");
+ if (!S_ISREG(PL_statbuf.st_mode)) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
if (PL_statbuf.st_mode & S_IWOTH)
Perl_croak(aTHX_ "Setuid/gid script is writable by world");
PL_doswitches = FALSE; /* -s is insecure in suid */
@@ -3246,7 +3287,7 @@
PL_euid == PL_statbuf.st_uid)
if (!PL_do_undump)
Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
-FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
#endif /* IAMSUID */
if (PL_euid) { /* oops, we're not the setuid root perl */
@@ -3323,8 +3364,10 @@
Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
else if (fdscript >= 0)
Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
- else
+ else {
+ errno = EPERM;
Perl_croak(aTHX_ "Permission denied\n");
+ }
/* We absolutely must clear out any saved ids here, so we */
/* exec the real perl, substituting fd script for scriptname. */
@@ -3332,8 +3375,10 @@
PerlIO_rewind(PL_rsfp);
PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
- if (!PL_origargv[which])
- Perl_croak(aTHX_ "Permission denied");
+ if (!PL_origargv[which]) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
PerlIO_fileno(PL_rsfp), PL_origargv[which]));
#if defined(HAS_FCNTL) && defined(F_SETFD)
@@ -3510,7 +3555,7 @@
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
+ PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
1.6 +56 -12 ponie/perl/perl.h
Index: perl.h
===================================================================
RCS file: /cvs/public/ponie/perl/perl.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- perl.h 15 Dec 2003 10:25:26 -0000 1.5
+++ perl.h 7 Apr 2004 10:37:27 -0000 1.6
@@ -1,7 +1,7 @@
/* perl.h
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -53,9 +53,14 @@
* repeated in makedef.pl, so be certain to update
* both places when editing. */
+#ifdef PERL_IMPLICIT_SYS
+/* PERL_IMPLICIT_SYS implies PerlMemShared != PerlMem
+ so use slab allocator to avoid lots of MUTEX overhead
+ */
#ifndef PL_OP_SLAB_ALLOC
# define PL_OP_SLAB_ALLOC
#endif
+#endif
#ifdef USE_ITHREADS
# if !defined(MULTIPLICITY)
@@ -132,7 +137,7 @@
#endif
#ifdef HASATTRIBUTE
-# if defined(__GNUC__) && defined(__cplusplus)
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
# define PERL_UNUSED_DECL
# else
# define PERL_UNUSED_DECL __attribute__((unused))
@@ -1286,6 +1291,7 @@
# define Perl_atan2 atan2l
# define Perl_pow powl
# define Perl_floor floorl
+# define Perl_ceil ceill
# define Perl_fmod fmodl
# endif
/* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */
@@ -1356,6 +1362,7 @@
# define Perl_atan2 atan2
# define Perl_pow pow
# define Perl_floor floor
+# define Perl_ceil ceil
# define Perl_fmod fmod
# define Perl_modf(x,y) modf(x,y)
# define Perl_frexp(x,y) frexp(x,y)
@@ -2503,6 +2510,7 @@
#define DEBUG_r_FLAG 0x00000200 /* 512 */
#define DEBUG_x_FLAG 0x00000400 /* 1024 */
#define DEBUG_u_FLAG 0x00000800 /* 2048 */
+ /* spare */
#define DEBUG_H_FLAG 0x00002000 /* 8192 */
#define DEBUG_X_FLAG 0x00004000 /* 16384 */
#define DEBUG_D_FLAG 0x00008000 /* 32768 */
@@ -2512,7 +2520,9 @@
#define DEBUG_J_FLAG 0x00080000 /* 524288 */
#define DEBUG_v_FLAG 0x00100000 /*1048576 */
#define DEBUG_C_FLAG 0x00200000 /*2097152 */
-#define DEBUG_MASK 0x003FEFFF /* mask of all the standard flags */
+#define DEBUG_A_FLAG 0x00400000 /*4194304 */
+#define DEBUG_q_FLAG 0x00800000 /*8388608 */
+#define DEBUG_MASK 0x00FFEFFF /* mask of all the standard flags */
#define DEBUG_DB_RECURSE_FLAG 0x40000000
#define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal
@@ -2539,13 +2549,12 @@
# define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
# define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG)
# define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG)
+# define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG)
+# define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG)
# define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
#ifdef DEBUGGING
-# undef YYDEBUG
-# define YYDEBUG 1
-
# define DEBUG_p_TEST DEBUG_p_TEST_
# define DEBUG_s_TEST DEBUG_s_TEST_
# define DEBUG_l_TEST DEBUG_l_TEST_
@@ -2568,6 +2577,8 @@
# define DEBUG_J_TEST DEBUG_J_TEST_
# define DEBUG_v_TEST DEBUG_v_TEST_
# define DEBUG_C_TEST DEBUG_C_TEST_
+# define DEBUG_A_TEST DEBUG_A_TEST_
+# define DEBUG_q_TEST DEBUG_q_TEST_
# define PERL_DEB(a) a
# define PERL_DEBUG(a) if (PL_debug) a
@@ -2606,6 +2617,8 @@
# define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
# define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
# define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a)
+# define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a)
+# define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a)
#else /* DEBUGGING */
@@ -2631,6 +2644,8 @@
# define DEBUG_J_TEST (0)
# define DEBUG_v_TEST (0)
# define DEBUG_C_TEST (0)
+# define DEBUG_A_TEST (0)
+# define DEBUG_q_TEST (0)
# define PERL_DEB(a)
# define PERL_DEBUG(a)
@@ -2655,6 +2670,8 @@
# define DEBUG_R(a)
# define DEBUG_v(a)
# define DEBUG_C(a)
+# define DEBUG_A(a)
+# define DEBUG_q(a)
#endif /* DEBUGGING */
@@ -2716,8 +2733,6 @@
#define PERL_MAGIC_ext '~' /* Available for use by extensions */
-#define YYMAXDEPTH 300
-
#ifndef assert /* <assert.h> might have been included somehow */
#ifdef DEBUGGING
#define assert(what) PERL_DEB( { \
@@ -3251,6 +3266,23 @@
/*****************************************************************************/
/* XXX This needs to be revisited, since BEGIN makes yacc re-enter... */
+#ifdef __Lynx__
+/* LynxOS defines these in scsi.h which is included via ioctl.h */
+#ifdef FORMAT
+#undef FORMAT
+#endif
+#ifdef SPACE
+#undef SPACE
+#endif
+#endif
+
+/* Win32 defines a type 'WORD' in windef.h. This conflicts with the enumerator
+ * 'WORD' defined in perly.h. The yytokentype enum is only a debugging aid, so
+ * it's not really needed.
+ */
+#if defined(WIN32)
+# define YYTOKENTYPE
+#endif
#include "perly.h"
#define LEX_NOTPARSING 11 /* borrowed from toke.c */
@@ -3856,7 +3888,7 @@
#define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
#define IN_LOCALE \
- (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+ (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
bool was_local = PL_numeric_local && IN_LOCALE; \
@@ -4136,6 +4168,10 @@
# include <fcntl.h>
#endif
+#ifdef __Lynx__
+# include <fcntl.h>
+#endif
+
#ifdef I_SYS_FILE
# include <sys/file.h>
#endif
@@ -4282,6 +4318,14 @@
#ifndef PIPESOCK_MODE
# define PIPESOCK_MODE
+#endif
+
+#ifndef SOCKET_OPEN_MODE
+# define SOCKET_OPEN_MODE PIPESOCK_MODE
+#endif
+
+#ifndef PIPE_OPEN_MODE
+# define PIPE_OPEN_MODE PIPESOCK_MODE
#endif
#define PERL_MAGIC_UTF8_CACHESIZE 2
1.3 +9 -15 ponie/perl/perlapi.h
Index: perlapi.h
===================================================================
RCS file: /cvs/public/ponie/perl/perlapi.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- perlapi.h 19 Dec 2003 14:38:57 -0000 1.2
+++ perlapi.h 7 Apr 2004 10:37:27 -0000 1.3
@@ -1,7 +1,7 @@
/*
* perlapi.h
*
- * Copyright (C) 1999, 2000, 2001, 2002, 2003, by Larry Wall and others
+ * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -432,8 +432,6 @@
#define PL_oldoldbufptr (*Perl_Ioldoldbufptr_ptr(aTHX))
#undef PL_op_mask
#define PL_op_mask (*Perl_Iop_mask_ptr(aTHX))
-#undef PL_op_seqmax
-#define PL_op_seqmax (*Perl_Iop_seqmax_ptr(aTHX))
#undef PL_origalen
#define PL_origalen (*Perl_Iorigalen_ptr(aTHX))
#undef PL_origargc
@@ -492,6 +490,10 @@
#define PL_regex_pad (*Perl_Iregex_pad_ptr(aTHX))
#undef PL_regex_padav
#define PL_regex_padav (*Perl_Iregex_padav_ptr(aTHX))
+#undef PL_rehash_seed
+#define PL_rehash_seed (*Perl_Irehash_seed_ptr(aTHX))
+#undef PL_rehash_seed_set
+#define PL_rehash_seed_set (*Perl_Irehash_seed_set_ptr(aTHX))
#undef PL_replgv
#define PL_replgv (*Perl_Ireplgv_ptr(aTHX))
#undef PL_rsfp
@@ -672,18 +674,10 @@
#define PL_xrv_arenaroot (*Perl_Ixrv_arenaroot_ptr(aTHX))
#undef PL_xrv_root
#define PL_xrv_root (*Perl_Ixrv_root_ptr(aTHX))
-#undef PL_yychar
-#define PL_yychar (*Perl_Iyychar_ptr(aTHX))
-#undef PL_yydebug
-#define PL_yydebug (*Perl_Iyydebug_ptr(aTHX))
-#undef PL_yyerrflag
-#define PL_yyerrflag (*Perl_Iyyerrflag_ptr(aTHX))
-#undef PL_yylval
-#define PL_yylval (*Perl_Iyylval_ptr(aTHX))
-#undef PL_yynerrs
-#define PL_yynerrs (*Perl_Iyynerrs_ptr(aTHX))
-#undef PL_yyval
-#define PL_yyval (*Perl_Iyyval_ptr(aTHX))
+#undef PL_yycharp
+#define PL_yycharp (*Perl_Iyycharp_ptr(aTHX))
+#undef PL_yylvalp
+#define PL_yylvalp (*Perl_Iyylvalp_ptr(aTHX))
#undef PL_Sv
#define PL_Sv (*Perl_TSv_ptr(aTHX))
#undef PL_Xpv
1.4 +87 -41 ponie/perl/pp_hot.c
Index: pp_hot.c
===================================================================
RCS file: /cvs/public/ponie/perl/pp_hot.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- pp_hot.c 29 Feb 2004 22:02:14 -0000 1.3
+++ pp_hot.c 7 Apr 2004 10:37:27 -0000 1.4
@@ -1,7 +1,7 @@
/* pp_hot.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -137,17 +137,17 @@
bool lbyte;
STRLEN rlen;
char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
- bool rbyte = !SvUTF8(right), rcopied = FALSE;
+ bool rbyte = !DO_UTF8(right), rcopied = FALSE;
if (TARG == right && right != left) {
right = sv_2mortal(newSVpvn(rpv, rlen));
- rpv = SvPV(right, rlen); /* no point setting UTF8 here */
+ rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
rcopied = TRUE;
}
if (TARG != left) {
lpv = SvPV(left, llen); /* mg_get(left) may happen here */
- lbyte = !SvUTF8(left);
+ lbyte = !DO_UTF8(left);
sv_setpvn(TARG, lpv, llen);
if (!lbyte)
SvUTF8_on(TARG);
@@ -160,7 +160,9 @@
if (!SvOK(TARG))
sv_setpv(left, "");
lpv = SvPV_nomg(left, llen);
- lbyte = !SvUTF8(left);
+ lbyte = !DO_UTF8(left);
+ if (IN_BYTES)
+ SvUTF8_off(TARG);
}
#if defined(PERL_Y2KWARN)
@@ -295,7 +297,7 @@
PP(pp_preinc)
{
dSP;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
@@ -521,7 +523,8 @@
PP(pp_aelemfast)
{
dSP;
- AV *av = GvAV(cGVOP_gv);
+ AV *av = PL_op->op_flags & OPf_SPECIAL ?
+ (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
U32 lval = PL_op->op_flags & OPf_MOD;
SV** svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
@@ -795,6 +798,7 @@
{
dSP; dTOPss;
HV *hv;
+ I32 gimme = GIMME_V;
if (SvROK(sv)) {
wasref:
@@ -808,7 +812,7 @@
RETURN;
}
else if (LVRET) {
- if (GIMME != G_SCALAR)
+ if (gimme != G_ARRAY)
Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
SETs((SV*)hv);
RETURN;
@@ -825,7 +829,7 @@
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
+ if (gimme != G_ARRAY)
Perl_croak(aTHX_ "Can't return hash to lvalue"
" scalar context");
SETs((SV*)hv);
@@ -850,7 +854,7 @@
DIE(aTHX_ PL_no_usym, "a HASH");
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
- if (GIMME == G_ARRAY) {
+ if (gimme == G_ARRAY) {
SP--;
RETURN;
}
@@ -885,7 +889,7 @@
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
+ if (gimme != G_ARRAY)
Perl_croak(aTHX_ "Can't return hash to lvalue"
" scalar context");
SETs((SV*)hv);
@@ -894,21 +898,16 @@
}
}
- if (GIMME == G_ARRAY) { /* array wanted */
+ if (gimme == G_ARRAY) { /* array wanted */
*PL_stack_sp = (SV*)hv;
return do_kv();
}
- else {
+ else if (gimme == G_SCALAR) {
dTARGET;
- if (HvFILL(hv))
- Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
- (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
- else
- sv_setiv(TARG, 0);
-
+ TARG = Perl_hv_scalar(aTHX_ hv);
SETTARG;
- RETURN;
}
+ RETURN;
}
STATIC void
@@ -962,8 +961,12 @@
HV *hash;
I32 i;
int magic;
+ int duplicates = 0;
+ SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
+
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
+ gimme = GIMME_V;
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
@@ -1017,6 +1020,7 @@
hash = (HV*)sv;
magic = SvMAGICAL(hash) != 0;
hv_clear(hash);
+ firsthashrelem = relem;
while (relem < lastrelem) { /* gobble up all the rest */
HE *didstore;
@@ -1028,6 +1032,9 @@
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
*(relem++) = tmpstr;
+ if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
+ /* key overwrites an existing entry */
+ duplicates += 2;
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
if (SvSMAGICAL(tmpstr))
@@ -1062,10 +1069,13 @@
if (PL_delaymagic & ~DM_DELAY) {
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
+ (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+ (Uid_t)-1);
#else
# ifdef HAS_SETREUID
- (void)setreuid(PL_uid,PL_euid);
+ (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
@@ -1075,7 +1085,7 @@
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_uid);
+ (void)seteuid(PL_euid);
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
@@ -1091,10 +1101,13 @@
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
+ (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+ (Gid_t)-1);
#else
# ifdef HAS_SETREGID
- (void)setregid(PL_gid,PL_egid);
+ (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
@@ -1104,7 +1117,7 @@
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_gid);
+ (void)setegid(PL_egid);
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
@@ -1122,17 +1135,26 @@
}
PL_delaymagic = 0;
- gimme = GIMME_V;
if (gimme == G_VOID)
SP = firstrelem - 1;
else if (gimme == G_SCALAR) {
dTARGET;
SP = firstrelem;
- SETi(lastrelem - firstrelem + 1);
+ SETi(lastrelem - firstrelem + 1 - duplicates);
}
else {
- if (ary || hash)
+ if (ary)
+ SP = lastrelem;
+ else if (hash) {
+ if (duplicates) {
+ /* Removes from the stack the entries which ended up as
+ * duplicated keys in the hash (fix for [perl #24380]) */
+ Move(firsthashrelem + duplicates,
+ firsthashrelem, duplicates, SV**);
+ lastrelem -= duplicates;
+ }
SP = lastrelem;
+ }
else
SP = firstrelem + (lastlelem - firstlelem);
lelem = firstlelem + (relem - firstrelem);
@@ -1176,6 +1198,8 @@
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
@@ -1293,10 +1317,10 @@
/*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
len = rx->endp[i] - rx->startp[i];
+ s = rx->startp[i] + truebase;
if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
len < 0 || len > strend - s)
DIE(aTHX_ "panic: pp_match start/end pointers");
- s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
@@ -1541,7 +1565,9 @@
for (;;) {
PUTBACK;
if (!sv_gets(sv, fp, offset)
- && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
+ && (type == OP_GLOB
+ || SNARF_EOF(gimme, PL_rs, io, sv)
+ || PerlIO_error(fp)))
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
@@ -1593,6 +1619,17 @@
(void)POPs; /* Unmatched wildcard? Chuck it... */
continue;
}
+ } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+ U8 *s = (U8*)SvPVX(sv) + offset;
+ STRLEN len = SvCUR(sv) - offset;
+ U8 *f;
+
+ if (ckWARN(WARN_UTF8) &&
+ !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+ /* Emulate :encoding(utf8) warning in the same case. */
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "utf8 \"\\x%02X\" does not map to Unicode",
+ f < (U8*)SvEND(sv) ? *f : 0);
}
if (gimme == G_ARRAY) {
if (SvLEN(sv) - SvCUR(sv) > 20) {
@@ -1862,8 +1899,7 @@
}
if (sv && SvREFCNT(sv) == 0) {
*itersvp = Nullsv;
- Perl_croak(aTHX_
- "Use of freed value in iteration (perhaps you modified the iterated array within the loop?)");
+ Perl_croak(aTHX_ "Use of freed value in iteration");
}
if (sv)
@@ -1928,6 +1964,8 @@
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
@@ -1946,7 +1984,7 @@
!is_cow &&
#endif
(SvREADONLY(TARG)
- || (SvTYPE(TARG) > SVt_PVLV
+ || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
DIE(aTHX_ PL_no_modify);
PUTBACK;
@@ -2260,9 +2298,16 @@
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
+ if (PL_op->op_private & OPpGREP_LEX) {
+ SV* sv = sv_newmortal();
+ sv_setiv(sv, items);
+ PUSHs(sv);
+ }
+ else {
dTARGET;
XPUSHi(items);
}
+ }
else if (gimme == G_ARRAY)
SP += items;
RETURN;
@@ -2275,6 +2320,9 @@
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
DEFSV = src;
RETURNOP(cLOGOP->op_other);
@@ -2633,9 +2681,7 @@
* Owing the speed considerations, we choose instead to search for
* the cv using find_runcv() when calling doeval().
*/
- if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
- else {
+ if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, CvDEPTH(cv), 1);
}
1.15 +23 -10 ponie/perl/proto.h
Index: proto.h
===================================================================
RCS file: /cvs/public/ponie/perl/proto.h,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -w -r1.14 -r1.15
--- proto.h 10 Mar 2004 23:07:23 -0000 1.14
+++ proto.h 7 Apr 2004 10:37:27 -0000 1.15
@@ -2,7 +2,7 @@
* proto.h
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -316,6 +316,7 @@
PERL_CALLCONV bool Perl_is_uni_xdigit_lc(pTHX_ UV c);
PERL_CALLCONV STRLEN Perl_is_utf8_char(pTHX_ U8 *p);
PERL_CALLCONV bool Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len);
+PERL_CALLCONV bool Perl_is_utf8_string_loc(pTHX_ U8 *s, STRLEN len, U8 **p);
PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ U8 *p);
PERL_CALLCONV bool Perl_is_utf8_alnumc(pTHX_ U8 *p);
PERL_CALLCONV bool Perl_is_utf8_idfirst(pTHX_ U8 *p);
@@ -513,7 +514,7 @@
PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems);
PERL_CALLCONV char* Perl_scan_vstring(pTHX_ char *vstr, SV *sv);
-PERL_CALLCONV char* Perl_scan_version(pTHX_ char *vstr, SV *sv);
+PERL_CALLCONV char* Perl_scan_version(pTHX_ char *vstr, SV *sv, bool qv);
PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver);
PERL_CALLCONV SV* Perl_upg_version(pTHX_ SV *ver);
PERL_CALLCONV SV* Perl_vnumify(pTHX_ SV *vs);
@@ -666,14 +667,16 @@
PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV* sv);
PERL_CALLCONV CV* Perl_sv_2cv(pTHX_ SV* sv, HV** st, GV** gvp, I32 lref);
PERL_CALLCONV IO* Perl_sv_2io(pTHX_ SV* sv);
-PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV* sv);
+/* PERL_CALLCONV IV sv_2iv(pTHX_ SV* sv); */
+PERL_CALLCONV IV Perl_sv_2iv_flags(pTHX_ SV* sv, I32 flags);
PERL_CALLCONV SV* Perl_sv_2mortal(pTHX_ SV* sv);
PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV* sv);
/* PERL_CALLCONV char* sv_2pv(pTHX_ SV* sv, STRLEN* lp); */
PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV* sv, STRLEN* lp);
PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV* sv, STRLEN* lp);
PERL_CALLCONV char* Perl_sv_pvn_nomg(pTHX_ SV* sv, STRLEN* lp);
-PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV* sv);
+/* PERL_CALLCONV UV sv_2uv(pTHX_ SV* sv); */
+PERL_CALLCONV UV Perl_sv_2uv_flags(pTHX_ SV* sv, I32 flags);
PERL_CALLCONV IV Perl_sv_iv(pTHX_ SV* sv);
PERL_CALLCONV UV Perl_sv_uv(pTHX_ SV* sv);
PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv);
@@ -812,9 +815,6 @@
PERL_CALLCONV I32 Perl_whichsig(pTHX_ char* sig);
PERL_CALLCONV void Perl_write_to_stderr(pTHX_ const char* message, int msglen);
PERL_CALLCONV int Perl_yyerror(pTHX_ char* s);
-#ifdef USE_PURE_BISON
-PERL_CALLCONV int Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp);
-#endif
PERL_CALLCONV int Perl_yylex(pTHX);
PERL_CALLCONV int Perl_yyparse(pTHX);
PERL_CALLCONV int Perl_yywarn(pTHX_ char* s);
@@ -977,6 +977,11 @@
PERL_CALLCONV short* Perl_macro_IoSUBPROCESS(pTHX_ SV *);
PERL_CALLCONV char* Perl_macro_IoTYPE(pTHX_ SV *);
PERL_CALLCONV char* Perl_macro_IoFLAGS(pTHX_ SV *);
+PERL_CALLCONV GP** Perl_macro_GvGP(pTHX_ GV *);
+PERL_CALLCONV char** Perl_macro_GvNAME(pTHX_ GV *);
+PERL_CALLCONV STRLEN* Perl_macro_GvNAMELEN(pTHX_ GV *);
+PERL_CALLCONV HV** Perl_macro_GvSTASH(pTHX_ GV *);
+PERL_CALLCONV U8* Perl_macro_GvFLAGS(pTHX_ GV *);
END_EXTERN_C
@@ -1005,7 +1010,6 @@
STATIC void S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store);
STATIC void S_unshare_hek_or_pvn(pTHX_ HEK* hek, const char* sv, I32 len, U32 hash);
STATIC HEK* S_share_hek_flags(pTHX_ const char* sv, I32 len, U32 hash, int flags);
-STATIC SV** S_hv_fetch_flags(pTHX_ HV* tb, const char* key, I32 klen, I32 lval, int flags);
STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg);
#endif
@@ -1096,7 +1100,8 @@
STATIC void* S_vdocatch_body(pTHX_ va_list args);
#endif
STATIC OP* S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit);
-STATIC void S_doparseform(pTHX_ SV *sv);
+STATIC OP* S_doparseform(pTHX_ SV *sv);
+STATIC bool S_num_overflow(NV value, I32 fldsize, I32 frcsize);
STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock);
STATIC I32 S_dopoptolabel(pTHX_ char *label);
STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock);
@@ -1386,8 +1391,16 @@
PERL_CALLCONV int Perl_get_debug_opts(pTHX_ char **s);
#endif
PERL_CALLCONV void Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val);
+PERL_CALLCONV void Perl_hv_assert(pTHX_ HV* tb);
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+STATIC SV* S_hv_delete_common(pTHX_ HV* tb, SV* key_sv, const char* key, STRLEN klen, int k_flags, I32 d_flags, U32 hash);
+STATIC HE* S_hv_fetch_common(pTHX_ HV* tb, SV* key_sv, const char* key, STRLEN klen, int flags, int action, SV* val, U32 hash);
+#endif
+PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV* hb);
-END_EXTERN_C
+PERL_CALLCONV SV* Perl_hv_scalar(pTHX_ HV* hv);
+PERL_CALLCONV SV* Perl_magic_scalarpack(pTHX_ HV* hv, MAGIC* mg);
+END_EXTERN_C
1.19 +242 -105 ponie/perl/sv.c
Index: sv.c
===================================================================
RCS file: /cvs/public/ponie/perl/sv.c,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -w -r1.18 -r1.19
--- sv.c 16 Mar 2004 17:07:25 -0000 1.18
+++ sv.c 7 Apr 2004 10:37:28 -0000 1.19
@@ -1,7 +1,7 @@
/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -501,78 +501,91 @@
Safefree(arena);
}
PL_xiv_arenaroot = 0;
+ PL_xiv_root = 0;
for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xnv_arenaroot = 0;
+ PL_xnv_root = 0;
for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xrv_arenaroot = 0;
+ PL_xrv_root = 0;
for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpv_arenaroot = 0;
+ PL_xpv_root = 0;
for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpviv_arenaroot = 0;
+ PL_xpviv_root = 0;
for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvnv_arenaroot = 0;
+ PL_xpvnv_root = 0;
for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvcv_arenaroot = 0;
+ PL_xpvcv_root = 0;
for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvav_arenaroot = 0;
+ PL_xpvav_root = 0;
for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvhv_arenaroot = 0;
+ PL_xpvhv_root = 0;
for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvmg_arenaroot = 0;
+ PL_xpvmg_root = 0;
for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvlv_arenaroot = 0;
+ PL_xpvlv_root = 0;
for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvbm_arenaroot = 0;
+ PL_xpvbm_root = 0;
for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_he_arenaroot = 0;
+ PL_he_root = 0;
if (PL_nice_chunk)
Safefree(PL_nice_chunk);
@@ -1744,6 +1757,11 @@
LvTARGLEN(sv) = 0;
LvTARG(sv) = 0;
LvTYPE(sv) = 0;
+ GvGP(sv) = 0;
+ GvNAME(sv) = 0;
+ GvNAMELEN(sv) = 0;
+ GvSTASH(sv) = 0;
+ GvFLAGS(sv) = 0;
break;
case SVt_PVAV:
SvANY(sv) = new_XPVAV();
@@ -2330,21 +2348,33 @@
}
#endif /* !NV_PRESERVES_UV*/
+/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
+ * this function provided for binary compatibility only
+ */
+
+IV
+Perl_sv_2iv(pTHX_ register SV *sv)
+{
+ return sv_2iv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2iv
+=for apidoc sv_2iv_flags
-Return the integer value of an SV, doing any necessary string conversion,
-magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+Return the integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
=cut
*/
IV
-Perl_sv_2iv(pTHX_ register SV *sv)
+Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
+ if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
return SvIVX(sv);
@@ -2627,22 +2657,33 @@
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
+/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
+ * this function provided for binary compatibility only
+ */
+
+UV
+Perl_sv_2uv(pTHX_ register SV *sv)
+{
+ return sv_2uv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2uv
+=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
-conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
-macros.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
=cut
*/
UV
-Perl_sv_2uv(pTHX_ register SV *sv)
+Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
+ if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
return SvUVX(sv);
@@ -3565,7 +3606,7 @@
=for apidoc sv_2pvbyte_nolen
Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF8 as a side-effect.
+May cause the SV to be downgraded from UTF-8 as a side-effect.
Usually accessed via the C<SvPVbyte_nolen> macro.
@@ -3583,7 +3624,7 @@
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be downgraded from UTF8 as a
+to its length. May cause the SV to be downgraded from UTF-8 as a
side-effect.
Usually accessed via the C<SvPVbyte> macro.
@@ -3601,8 +3642,8 @@
/*
=for apidoc sv_2pvutf8_nolen
-Return a pointer to the UTF8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV.
+May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8_nolen> macro.
@@ -3619,8 +3660,8 @@
/*
=for apidoc sv_2pvutf8
-Return a pointer to the UTF8-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8> macro.
@@ -3694,7 +3735,7 @@
/*
=for apidoc sv_utf8_upgrade
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
@@ -3704,7 +3745,7 @@
=for apidoc sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
@@ -3774,7 +3815,7 @@
/*
=for apidoc sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
+Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
This may not be possible if the PV contains non-byte encoding characters;
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
@@ -3818,7 +3859,7 @@
/*
=for apidoc sv_utf8_encode
-Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
flag so that it looks like octets again. Used as a building block
for encode_utf8 in Encode.xs
@@ -3829,6 +3870,12 @@
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
(void) sv_utf8_upgrade(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
SvUTF8_off(sv);
}
@@ -4062,6 +4109,8 @@
if (dtype != SVt_PVGV) {
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
+ /* don't upgrade SVt_PVLV: it can hold a glob */
+ if (dtype != SVt_PVLV)
sv_upgrade(dstr, SVt_PVGV);
sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
@@ -4286,6 +4335,10 @@
* has to be allocated and SvPVX(sstr) has to be freed.
*/
+ /* Whichever path we take through the next code, we want this true,
+ and doing it now facilitates the COW check. */
+ (void)SvPOK_only(dstr);
+
if (
#ifdef PERL_COPY_ON_WRITE
(sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
@@ -4300,6 +4353,7 @@
!(PL_op && PL_op->op_type == OP_AASSIGN))
#ifdef PERL_COPY_ON_WRITE
&& !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+ && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
&& SvTYPE(sstr) >= SVt_PVIV)
#endif
) {
@@ -4310,7 +4364,6 @@
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
*SvEND(dstr) = '\0';
- (void)SvPOK_only(dstr);
} else {
/* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
be true in here. */
@@ -4348,7 +4401,6 @@
else if (SvLEN(dstr))
Safefree(SvPVX(dstr));
}
- (void)SvPOK_only(dstr);
#ifdef PERL_COPY_ON_WRITE
if (!isSwipe) {
@@ -4496,7 +4548,7 @@
}
else
new_SV(dstr);
- SvUPGRADE (dstr, SVt_PVIV);
+ (void)SvUPGRADE (dstr, SVt_PVIV);
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
@@ -4519,7 +4571,7 @@
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
- SvUPGRADE (sstr, SVt_PVIV);
+ (void)SvUPGRADE (sstr, SVt_PVIV);
SvREADONLY_on(sstr);
SvFAKE_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
@@ -4788,7 +4840,7 @@
sv_dump(sv);
}
}
- else if (PL_curcop != &PL_compiling)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
/* At this point I believe that I can drop the global SV mutex. */
}
@@ -4796,16 +4848,19 @@
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
+ int is_utf8 = SvUTF8(sv);
STRLEN len = SvCUR(sv);
U32 hash = SvUVX(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
+ SvPVX(sv) = 0;
+ SvLEN(sv) = 0;
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
- unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
+ unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
}
- else if (PL_curcop != &PL_compiling)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
#endif
@@ -4890,15 +4945,15 @@
=for apidoc sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
@@ -5020,8 +5075,8 @@
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-If the SV has the UTF8 status set, then the bytes appended should be
-valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF-8 status set, then the bytes appended should be
+valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
=cut */
@@ -5190,11 +5245,12 @@
sv_force_normal_flags(sv, 0);
#endif
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling
+ if (IN_PERL_RUNTIME
&& how != PERL_MAGIC_regex_global
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
&& how != PERL_MAGIC_sv
+ && how != PERL_MAGIC_backref
)
{
Perl_croak(aTHX_ PL_no_modify);
@@ -5433,15 +5489,13 @@
* by magic_killbackrefs() when tsv is being freed */
}
if (AvFILLp(av) >= AvMAX(av)) {
+ I32 i;
SV **svp = AvARRAY(av);
- I32 i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == &PL_sv_undef) {
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (!svp[i]) {
svp[i] = sv; /* reuse the slot */
return;
}
- i--;
- }
av_extend(av, AvFILLp(av)+1);
}
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
@@ -5463,13 +5517,8 @@
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == sv) {
- svp[i] = &PL_sv_undef; /* XXX */
- }
- i--;
- }
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (svp[i] == sv) svp[i] = Nullsv;
}
/*
@@ -5915,7 +5964,9 @@
return;
}
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf,
+ PTR2UV(sv));
return;
}
if (--(SvREFCNT(sv)) > 0)
@@ -5973,7 +6024,7 @@
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF8 bytes as a single character. Handles magic and type coercion.
+UTF-8 bytes as a single character. Handles magic and type coercion.
=cut
*/
@@ -6035,10 +6086,8 @@
bool found = FALSE;
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
- if (!*mgp) {
- sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
- *mgp = mg_find(sv, PERL_MAGIC_utf8);
- }
+ if (!*mgp)
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
assert(*mgp);
if ((*mgp)->mg_ptr)
@@ -6132,6 +6181,12 @@
(*cachep)[i] = (STRLEN)uoff;
(*cachep)[i+1] = p - start;
+ /* Drop the stale "length" cache */
+ if (i == 0) {
+ (*cachep)[2] = 0;
+ (*cachep)[3] = 0;
+ }
+
found = TRUE;
}
}
@@ -6172,7 +6227,7 @@
/*
=for apidoc sv_pos_u2b
-Converts the value pointed to by offsetp from a count of UTF8 chars from
+Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
the offset, rather than from the start of the string. Handles magic and
@@ -6252,7 +6307,7 @@
=for apidoc sv_pos_b2u
Converts the value pointed to by offsetp from a count of bytes from the
-start of the string, to a count of the equivalent number of UTF8 chars.
+start of the string, to a count of the equivalent number of UTF-8 chars.
Handles magic and type coercion.
=cut
@@ -6717,7 +6772,7 @@
if (PerlIO_isutf8(fp))
SvUTF8_on(sv);
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
/* we always read code in line mode */
rsptr = "\n";
rslen = 1;
@@ -7052,7 +7107,7 @@
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
@@ -7208,7 +7263,7 @@
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
@@ -8848,6 +8903,33 @@
}
#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
+static char *
+F0convert(NV nv, char *endbuf, STRLEN *len)
+{
+ int neg = nv < 0;
+ UV uv;
+ char *p = endbuf;
+
+ if (neg)
+ nv = -nv;
+ if (nv < UV_MAX) {
+ nv += 0.5;
+ uv = (UV)nv;
+ if (uv & 1 && uv == nv)
+ uv--; /* Round to even */
+ do {
+ unsigned dig = uv % 10;
+ *--p = '0' + dig;
+ } while (uv /= 10);
+ if (neg)
+ *--p = '-';
+ *len = endbuf - p;
+ return p;
+ }
+ return Nullch;
+}
+
+
/*
=for apidoc sv_vcatpvfn
@@ -8875,6 +8957,12 @@
bool has_utf8; /* has the result utf8? */
bool pat_utf8; /* the pattern is in utf8? */
SV *nsv = Nullsv;
+ /* Times 4: a decimal digit takes more than 3 binary digits.
+ * NV_DIG: mantissa takes than many decimal digits.
+ * Plus 32: Playing safe. */
+ char ebuf[IV_DIG * 4 + NV_DIG + 32];
+ /* large enough for "%#.#f" --chip */
+ /* what about long double NVs? --jhi */
has_utf8 = pat_utf8 = DO_UTF8(sv);
@@ -8910,6 +8998,48 @@
}
}
+#ifndef USE_LONG_DOUBLE
+ /* special-case "%.<number>[gf]" */
+ if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+ && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
+ unsigned digits = 0;
+ const char *pp;
+
+ pp = pat + 2;
+ while (*pp >= '0' && *pp <= '9')
+ digits = 10 * digits + (*pp++ - '0');
+ if (pp - pat == (int)patlen - 1) {
+ NV nv;
+
+ if (args)
+ nv = (NV)va_arg(*args, double);
+ else if (svix < svmax)
+ nv = SvNV(*svargs);
+ else
+ return;
+ if (*pp == 'g') {
+ /* Add check for digits != 0 because it seems that some
+ gconverts are buggy in this case, and we don't yet have
+ a Configure test for this. */
+ if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
+ /* 0, point, slack */
+ Gconvert(nv, (int)digits, 0, ebuf);
+ sv_catpv(sv, ebuf);
+ if (*ebuf) /* May return an empty string for digits==0 */
+ return;
+ }
+ } else if (!digits) {
+ STRLEN l;
+
+ if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+ sv_catpvn(sv, p, l);
+ return;
+ }
+ }
+ }
+ }
+#endif /* !USE_LONG_DOUBLE */
+
if (!args && svix < svmax && DO_UTF8(*svargs))
has_utf8 = TRUE;
@@ -8941,13 +9071,6 @@
char *eptr = Nullch;
STRLEN elen = 0;
- /* Times 4: a decimal digit takes more than 3 binary digits.
- * NV_DIG: mantissa takes than many decimal digits.
- * Plus 32: Playing safe. */
- char ebuf[IV_DIG * 4 + NV_DIG + 32];
- /* large enough for "%#.#f" --chip */
- /* what about long double NVs? --jhi */
-
SV *vecsv = Nullsv;
U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
@@ -9296,23 +9419,23 @@
else if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
- default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+ default: iv = va_arg(*args, int); break;
#ifdef HAS_QUAD
case 'q': iv = va_arg(*args, Quad_t); break;
#endif
}
}
else {
- iv = SvIVx(argsv);
+ IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': iv = (short)iv; break;
- default: break;
- case 'l': iv = (long)iv; break;
- case 'V': break;
+ case 'h': iv = (short)tiv; break;
+ case 'l': iv = (long)tiv; break;
+ case 'V':
+ default: iv = tiv; break;
#ifdef HAS_QUAD
- case 'q': iv = (Quad_t)iv; break;
+ case 'q': iv = (Quad_t)tiv; break;
#endif
}
}
@@ -9380,23 +9503,23 @@
else if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
- default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+ default: uv = va_arg(*args, unsigned); break;
#ifdef HAS_QUAD
- case 'q': uv = va_arg(*args, Quad_t); break;
+ case 'q': uv = va_arg(*args, Uquad_t); break;
#endif
}
}
else {
- uv = SvUVx(argsv);
+ UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': uv = (unsigned short)uv; break;
- default: break;
- case 'l': uv = (unsigned long)uv; break;
- case 'V': break;
+ case 'h': uv = (unsigned short)tuv; break;
+ case 'l': uv = (unsigned long)tuv; break;
+ case 'V':
+ default: uv = tuv; break;
#ifdef HAS_QUAD
- case 'q': uv = (Quad_t)uv; break;
+ case 'q': uv = (Uquad_t)tuv; break;
#endif
}
}
@@ -9607,6 +9730,19 @@
PL_efloatbuf[0] = '\0';
}
+ if ( !(width || left || plus || alt) && fill != '0'
+ && has_precis && intsize != 'q' ) { /* Shortcuts */
+ /* See earlier comment about buggy Gconvert when digits,
+ aka precis is 0 */
+ if ( c == 'g' && precis) {
+ Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+ if (*PL_efloatbuf) /* May return an empty string for digits==0 */
+ goto float_converted;
+ } else if ( c == 'f' && !precis) {
+ if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+ break;
+ }
+ }
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
@@ -9651,6 +9787,7 @@
#else
(void)sprintf(PL_efloatbuf, eptr, nv);
#endif
+ float_converted:
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
break;
@@ -9714,6 +9851,9 @@
continue; /* not "break" */
}
+ /* calculate width before utf8_upgrade changes it */
+ have = esignlen + zeros + elen;
+
if (is_utf8 != has_utf8) {
if (is_utf8) {
if (SvCUR(sv))
@@ -9737,7 +9877,6 @@
"Newline in left-justified string for %sprintf",
(PL_op->op_type == OP_PRTF) ? "" : "s");
- have = esignlen + zeros + elen;
need = (have > width ? have : width);
gap = need - have;
@@ -9907,7 +10046,7 @@
New(0, ret->offsets, 2*len+1, U32);
Copy(r->offsets, ret->offsets, 2*len+1, U32);
- ret->precomp = SAVEPV(r->precomp);
+ ret->precomp = SAVEPVN(r->precomp, r->prelen);
ret->refcnt = r->refcnt;
ret->minlen = r->minlen;
ret->prelen = r->prelen;
@@ -9919,7 +10058,7 @@
ret->sublen = r->sublen;
if (RX_MATCH_COPIED(ret))
- ret->subbeg = SAVEPV(r->subbeg);
+ ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
else
ret->subbeg = Nullch;
#ifdef PERL_COPY_ON_WRITE
@@ -10026,12 +10165,11 @@
AV *av = (AV*) mg->mg_obj;
SV **svp;
I32 i;
- nmg->mg_obj = (SV*)newAV();
+ SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
+ for (i = AvFILLp(av); i >= 0; i--) {
+ if (!svp[i]) continue;
av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
- i--;
}
}
else {
@@ -10261,7 +10399,7 @@
GvHV(gv) = (HV*)sv;
}
else {
- SvREADONLY_on(GvAV(gv));
+ SvREADONLY_on(GvHV(gv));
}
return sstr; /* he_dup() will SvREFCNT_inc() */
@@ -10605,7 +10743,10 @@
SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
}
- CvGV(dstr) = gv_dup(CvGV(sstr), param);
+ /* don't dup if copying back - CvGV isn't refcounted, so the
+ * duped GV may never be freed. A bit of a hack! DAPM */
+ CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
+ Nullgv : gv_dup(CvGV(sstr), param) ;
if (param->flags & CLONEf_COPY_STACKS) {
CvDEPTH(dstr) = CvDEPTH(sstr);
} else {
@@ -11237,6 +11378,10 @@
PL_debug = proto_perl->Idebug;
#ifdef USE_REENTRANT_API
+ /* XXX: things like -Dm will segfault here in perlio, but doing
+ * PERL_SET_CONTEXT(proto_perl);
+ * breaks too many other things
+ */
Perl_reentrant_init(aTHX);
#endif
@@ -11488,7 +11633,6 @@
PL_egid = proto_perl->Iegid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
- PL_op_seqmax = proto_perl->Iop_seqmax;
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
@@ -11667,17 +11811,10 @@
PL_last_swash_tmps = (U8*)NULL;
PL_last_swash_slen = 0;
- /* perly.c globals */
- PL_yydebug = proto_perl->Iyydebug;
- PL_yynerrs = proto_perl->Iyynerrs;
- PL_yyerrflag = proto_perl->Iyyerrflag;
- PL_yychar = proto_perl->Iyychar;
- PL_yyval = proto_perl->Iyyval;
- PL_yylval = proto_perl->Iyylval;
-
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
PL_hash_seed = proto_perl->Ihash_seed;
+ PL_rehash_seed = proto_perl->Irehash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
1.14 +59 -37 ponie/perl/sv.h
Index: sv.h
===================================================================
RCS file: /cvs/public/ponie/perl/sv.h,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -w -r1.13 -r1.14
--- sv.h 16 Mar 2004 17:08:33 -0000 1.13
+++ sv.h 7 Apr 2004 10:37:28 -0000 1.14
@@ -1,7 +1,7 @@
/* sv.h
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -53,11 +53,11 @@
SVt_PVNV, /* 6 */
SVt_PVMG, /* 7 */
SVt_PVBM, /* 8 */
- SVt_PVLV, /* 9 */
- SVt_PVAV, /* 10 */
- SVt_PVHV, /* 11 */
- SVt_PVCV, /* 12 */
- SVt_PVGV, /* 13 */
+ SVt_PVGV, /* 9 */
+ SVt_PVLV, /* 10 */
+ SVt_PVAV, /* 11 */
+ SVt_PVHV, /* 12 */
+ SVt_PVCV, /* 13 */
SVt_PVFM, /* 14 */
SVt_PVIO /* 15 */
} svtype;
@@ -139,10 +139,10 @@
#if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
# define SvREFCNT_inc(sv) \
({ \
- SV *nsv = (SV*)(sv); \
- if (nsv) \
- (SvREFCNT(nsv))++; \
- nsv; \
+ SV *_sv = (SV*)(sv); \
+ if (_sv) \
+ (SvREFCNT(_sv))++; \
+ _sv; \
})
#else
# define SvREFCNT_inc(sv) \
@@ -152,13 +152,13 @@
#if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
# define SvREFCNT_dec(sv) \
({ \
- SV *nsv = (SV*)(sv); \
- if (nsv) { \
- if (SvREFCNT(nsv)) { \
- if (--(SvREFCNT(nsv)) == 0) \
- Perl_sv_free2(aTHX_ nsv); \
+ SV *_sv = (SV*)(sv); \
+ if (_sv) { \
+ if (SvREFCNT(_sv)) { \
+ if (--(SvREFCNT(_sv)) == 0) \
+ Perl_sv_free2(aTHX_ _sv); \
} else { \
- sv_free(nsv); \
+ sv_free(_sv); \
} \
} \
})
@@ -223,6 +223,7 @@
#define SVrepl_EVAL 0x40000000 /* Replacement part of s///e */
+#define SVphv_REHASH 0x10000000 /* HV is recalculating hash values */
#define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
#define SVphv_HASKFLAGS 0x80000000 /* keys have flag byte after hash */
@@ -281,6 +282,13 @@
MAGIC* xmg_magic; /* linked list of magicalness */
HV* xmg_stash; /* class package */
+ /* a full glob fits into this */
+ GP* xgv_gp;
+ char* xgv_name;
+ STRLEN xgv_namelen;
+ HV* xgv_stash;
+ U8 xgv_flags;
+
STRLEN xlv_targoff;
STRLEN xlv_targlen;
SV* xlv_targ;
@@ -451,13 +459,13 @@
=for apidoc Am|void|SvIOK_only_UV|SV* sv
Tells and SV that it is an unsigned integer and disables all other OK bits.
-=for apidoc Am|void|SvIOK_UV|SV* sv
+=for apidoc Am|bool|SvIOK_UV|SV* sv
Returns a boolean indicating whether the SV contains an unsigned integer.
=for apidoc Am|void|SvUOK|SV* sv
Returns a boolean indicating whether the SV contains an unsigned integer.
-=for apidoc Am|void|SvIOK_notUV|SV* sv
+=for apidoc Am|bool|SvIOK_notUV|SV* sv
Returns a boolean indicating whether the SV contains a signed integer.
=for apidoc Am|bool|SvNOK|SV* sv
@@ -484,7 +492,7 @@
=for apidoc Am|void|SvPOK_only|SV* sv
Tells an SV that it is a string and disables all other OK bits.
-Will also turn off the UTF8 status.
+Will also turn off the UTF-8 status.
=for apidoc Am|bool|SvVOK|SV* sv
Returns a boolean indicating whether the SV contains a v-string.
@@ -549,7 +557,7 @@
SVp_IOK|SVp_NOK|SVf_IVisUV))
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-#define assert_not_ROK(sv) ({assert(!SvROK(sv) || !SvRV(sv))}),
+#define assert_not_ROK(sv) ({assert(!SvROK(sv) || !SvRV(sv));}),
#else
#define assert_not_ROK(sv)
#endif
@@ -600,19 +608,19 @@
SvFLAGS(sv) |= (SVf_NOK|SVp_NOK))
/*
-=for apidoc Am|void|SvUTF8|SV* sv
+=for apidoc Am|bool|SvUTF8|SV* sv
Returns a boolean indicating whether the SV contains UTF-8 encoded data.
=for apidoc Am|void|SvUTF8_on|SV *sv
-Turn on the UTF8 status of an SV (the data is not changed, just the flag).
+Turn on the UTF-8 status of an SV (the data is not changed, just the flag).
Do not use frivolously.
=for apidoc Am|void|SvUTF8_off|SV *sv
-Unsets the UTF8 status of an SV.
+Unsets the UTF-8 status of an SV.
=for apidoc Am|void|SvPOK_only_UTF8|SV* sv
Tells an SV that it is a string and disables all other OK bits,
-and leaves the UTF8 status as it was.
+and leaves the UTF-8 status as it was.
=cut
*/
@@ -763,22 +771,22 @@
(void) SvIV(sv); } STMT_END
#define SvIV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
- (SvIVX(sv) = val); } STMT_END
+ (SvIVX(sv) = (val)); } STMT_END
#define SvNV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) == SVt_NV || SvTYPE(sv) >= SVt_PVNV); \
- (SvNVX(sv) = val); } STMT_END
+ (SvNVX(sv) = (val)); } STMT_END
#define SvPV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- (SvPVX(sv) = val); } STMT_END
+ (SvPVX(sv) = (val)); } STMT_END
#define SvCUR_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- (SvCUR(sv) = val); } STMT_END
+ (SvCUR(sv) = (val)); } STMT_END
#define SvLEN_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- (SvLEN(sv) = val); } STMT_END
+ (SvLEN(sv) = (val)); } STMT_END
#define SvEND_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
- (SvCUR(sv) = val - SvPVX(sv)); } STMT_END
+ (SvCUR(sv) = (val) - SvPVX(sv)); } STMT_END
#define BmRARE(sv) (* Perl_macro_BmRARE(aTHX_ (SV*)(sv)))
#define BmUSEFUL(sv) (* Perl_macro_BmUSEFUL(aTHX_ (SV*)(sv)))
@@ -875,6 +883,9 @@
=for apidoc Am|char*|SvPVx|SV* sv|STRLEN len
A version of C<SvPV> which guarantees to evaluate sv only once.
+=for apidoc Am|char*|SvPV_nomg|SV* sv|STRLEN len
+Like C<SvPV> but doesn't process magic.
+
=for apidoc Am|char*|SvPV_nolen|SV* sv
Returns a pointer to the string in the SV, or a stringified form of
the SV if the SV does not contain a string. The SV may cache the
@@ -884,6 +895,9 @@
Coerces the given SV to an integer and returns it. See C<SvIVx> for a
version which guarantees to evaluate sv only once.
+=for apidoc Am|IV|SvIV_nomg|SV* sv
+Like C<SvIV> but doesn't process magic.
+
=for apidoc Am|IV|SvIVx|SV* sv
Coerces the given SV to an integer and returns it. Guarantees to evaluate
sv only once. Use the more efficient C<SvIV> otherwise.
@@ -900,6 +914,9 @@
Coerces the given SV to an unsigned integer and returns it. See C<SvUVx>
for a version which guarantees to evaluate sv only once.
+=for apidoc Am|UV|SvUV_nomg|SV* sv
+Like C<SvUV> but doesn't process magic.
+
=for apidoc Am|UV|SvUVx|SV* sv
Coerces the given SV to an unsigned integer and returns it. Guarantees to
evaluate sv only once. Use the more efficient C<SvUV> otherwise.
@@ -963,6 +980,9 @@
#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
+#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
+
/* ----*/
#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
@@ -1027,12 +1047,12 @@
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); })
-# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); })
-# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); })
-# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); })
-# define SvPVutf8x(sv, lp) ({SV *nsv = (sv); SvPVutf8(nsv, lp); })
-# define SvPVbytex(sv, lp) ({SV *nsv = (sv); SvPVbyte(nsv, lp); })
+# define SvIVx(sv) ({SV *_sv = (SV*)(sv); SvIV(_sv); })
+# define SvUVx(sv) ({SV *_sv = (SV*)(sv); SvUV(_sv); })
+# define SvNVx(sv) ({SV *_sv = (SV*)(sv); SvNV(_sv); })
+# define SvPVx(sv, lp) ({SV *_sv = (sv); SvPV(_sv, lp); })
+# define SvPVutf8x(sv, lp) ({SV *_sv = (sv); SvPVutf8(_sv, lp); })
+# define SvPVbytex(sv, lp) ({SV *_sv = (sv); SvPVbyte(_sv, lp); })
# define SvTRUE(sv) ( \
!sv \
? 0 \
@@ -1049,7 +1069,7 @@
: SvNOK(sv) \
? SvNVX(sv) != 0.0 \
: sv_2bool(sv) )
-# define SvTRUEx(sv) ({SV *nsv = (sv); SvTRUE(nsv); })
+# define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
#else /* __GNUC__ */
@@ -1135,6 +1155,8 @@
#define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0)
#define sv_pvn_force(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC)
#define sv_utf8_upgrade(sv) sv_utf8_upgrade_flags(sv, SV_GMAGIC)
+#define sv_2iv(sv) sv_2iv_flags(sv, SV_GMAGIC)
+#define sv_2uv(sv) sv_2uv_flags(sv, SV_GMAGIC)
/* Should be named SvCatPVN_utf8_upgrade? */
#define sv_catpvn_utf8_upgrade(dsv, sstr, slen, nsv) \
1.3 +86 -50 ponie/perl/util.c
Index: util.c
===================================================================
RCS file: /cvs/public/ponie/perl/util.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- util.c 12 Mar 2004 13:27:36 -0000 1.2
+++ util.c 7 Apr 2004 10:37:28 -0000 1.3
@@ -1,7 +1,7 @@
/* util.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -18,10 +18,7 @@
#include "perl.h"
#ifndef PERL_MICRO
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
-#endif
-
#ifndef SIG_ERR
# define SIG_ERR ((Sighandler_t) -1)
#endif
@@ -75,7 +72,9 @@
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
my_exit(1);
return Nullch;
}
@@ -122,7 +121,9 @@
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
my_exit(1);
return Nullch;
}
@@ -174,7 +175,9 @@
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
my_exit(1);
return Nullch;
}
@@ -1222,8 +1225,9 @@
=for apidoc croak
This is the XSUB-writer's interface to Perl's C<die> function.
-Normally use this function the same way you use the C C<printf>
-function. See C<warn>.
+Normally call this function the same way you call the C C<printf>
+function. Calling C<croak> returns control directly to Perl,
+sidestepping the normal C order of execution. See C<warn>.
If you want to throw an exception object, assign the object to
C<$@> and then pass C<Nullch> to croak():
@@ -1308,9 +1312,8 @@
/*
=for apidoc warn
-This is the XSUB-writer's interface to Perl's C<warn> function. Use this
-function the same way you use the C C<printf> function. See
-C<croak>.
+This is the XSUB-writer's interface to Perl's C<warn> function. Call this
+function the same way you call the C C<printf> function. See C<croak>.
=cut
*/
@@ -3661,19 +3664,21 @@
Function must be called with an already existing SV like
- sv = NEWSV(92,0);
- s = scan_version(s,sv);
+ sv = newSV(0);
+ s = scan_version(s,SV *sv, bool qv);
Performs some preprocessing to the string to ensure that
it has the correct characteristics of a version. Flags the
object if it contains an underscore (which denotes this
-is a beta version).
+is a alpha version). The boolean qv denotes that the version
+should be interpreted as if it had multiple decimals, even if
+it doesn't.
=cut
*/
char *
-Perl_scan_version(pTHX_ char *s, SV *rv)
+Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
{
const char *start = s;
char *pos = s;
@@ -3701,7 +3706,10 @@
}
pos = s;
- if (*pos == 'v') pos++; /* get past 'v' */
+ if (*pos == 'v') {
+ pos++; /* get past 'v' */
+ qv = 1; /* force quoted version processing */
+ }
while (isDIGIT(*pos))
pos++;
if (!isALPHA(*pos)) {
@@ -3717,13 +3725,13 @@
I32 mult = 1;
I32 orev;
if ( s < pos && s > start && *(s-1) == '_' ) {
- mult *= -1; /* beta version */
+ mult *= -1; /* alpha version */
}
/* the following if() will only be true after the decimal
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( s > start+1 && saw_period == 1 && !saw_under ) {
+ if ( !qv && s > start+1 && saw_period == 1 && !saw_under ) {
mult = 100;
while ( s < end ) {
orev = rev;
@@ -3782,24 +3790,21 @@
Perl_new_version(pTHX_ SV *ver)
{
SV *rv = newSV(0);
- char *version;
- if ( SvNOK(ver) ) /* may get too much accuracy */
- {
- char tbuf[64];
- sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
- version = savepv(tbuf);
- }
#ifdef SvVOK
- else if ( SvVOK(ver) ) { /* already a v-string */
+ if ( SvVOK(ver) ) { /* already a v-string */
+ char *version;
MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+ sv_setpv(rv,version);
+ Safefree(version);
}
+ else {
#endif
- else /* must be a string or something like a string */
- {
- version = (char *)SvPV(ver,PL_na);
+ sv_setsv(rv,ver); /* make a duplicate */
+#ifdef SvVOK
}
- version = scan_version(version,rv);
+#endif
+ upg_version(rv);
return rv;
}
@@ -3818,14 +3823,29 @@
SV *
Perl_upg_version(pTHX_ SV *ver)
{
- char *version = savepvn(SvPVX(ver),SvCUR(ver));
+ char *version;
+ bool qv = 0;
+
+ if ( SvNOK(ver) ) /* may get too much accuracy */
+ {
+ char tbuf[64];
+ sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+ version = savepv(tbuf);
+ }
#ifdef SvVOK
- if ( SvVOK(ver) ) { /* already a v-string */
+ else if ( SvVOK(ver) ) { /* already a v-string */
MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+ qv = 1;
}
#endif
- version = scan_version(version,ver);
+ else /* must be a string or something like a string */
+ {
+ STRLEN n_a;
+ version = savepv(SvPV(ver,n_a));
+ }
+ (void)scan_version(version, ver, qv);
+ Safefree(version);
return ver;
}
@@ -3848,7 +3868,7 @@
Perl_vnumify(pTHX_ SV *vs)
{
I32 i, len, digit;
- SV *sv = NEWSV(92,0);
+ SV *sv = newSV(0);
if ( SvROK(vs) )
vs = SvRV(vs);
len = av_len((AV *)vs);
@@ -3888,7 +3908,7 @@
Perl_vstringify(pTHX_ SV *vs)
{
I32 i, len, digit;
- SV *sv = NEWSV(92,0);
+ SV *sv = newSV(0);
if ( SvROK(vs) )
vs = SvRV(vs);
len = av_len((AV *)vs);
@@ -3907,8 +3927,12 @@
else
Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
}
- if ( len == 0 )
+
+ if ( len <= 2 ) { /* short version, must be at least three */
+ for ( len = 2 - len; len != 0; len-- )
Perl_sv_catpv(aTHX_ sv,".0");
+ }
+
return sv;
}
@@ -3938,23 +3962,36 @@
{
I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
- bool lbeta = left < 0 ? 1 : 0;
- bool rbeta = right < 0 ? 1 : 0;
- left = PERL_ABS(left);
- right = PERL_ABS(right);
- if ( left < right || (left == right && lbeta && !rbeta) )
+ bool lalpha = left < 0 ? 1 : 0;
+ bool ralpha = right < 0 ? 1 : 0;
+ left = abs(left);
+ right = abs(right);
+ if ( left < right || (left == right && lalpha && !ralpha) )
retval = -1;
- if ( left > right || (left == right && rbeta && !lbeta) )
+ if ( left > right || (left == right && ralpha && !lalpha) )
retval = +1;
i++;
}
- if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
+ if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
+ {
+ if ( l < r )
{
- if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
- !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
+ while ( i <= r && retval == 0 )
{
- retval = l < r ? -1 : +1; /* not a match after all */
+ if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
+ retval = -1; /* not a match after all */
+ i++;
+ }
+ }
+ else
+ {
+ while ( i <= l && retval == 0 )
+ {
+ if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
+ retval = +1; /* not a match after all */
+ i++;
+ }
}
}
return retval;
@@ -4413,7 +4450,6 @@
{
/* Compute a random seed */
(void)seedDrand01((Rand_seed_t)seed());
- PL_srand_called = TRUE;
myseed = (UV)(Drand01() * (NV)UV_MAX);
#if RANDBITS < (UVSIZE * 8)
/* Since there are not enough randbits to to reach all
@@ -4429,7 +4465,7 @@
Perl_croak(aTHX_ "Your random numbers are not that random");
}
}
- PL_hash_seed_set = TRUE;
+ PL_rehash_seed_set = TRUE;
return myseed;
}
1.3 +8 -1 ponie/perl/ext/POSIX/t/posix.t
Index: posix.t
===================================================================
RCS file: /cvs/public/ponie/perl/ext/POSIX/t/posix.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- posix.t 12 Mar 2004 12:28:48 -0000 1.2
+++ posix.t 7 Apr 2004 10:37:28 -0000 1.3
@@ -11,7 +11,7 @@
}
require "./test.pl";
-plan(tests => 61);
+plan(tests => 65);
use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
errno);
@@ -259,6 +259,13 @@
ok(!POSIX::isspace('_'), 'isspace' );
ok( POSIX::isxdigit('f'), 'isxdigit' );
ok(!POSIX::isxdigit('g'), 'isxdigit' );
+# metaphysical question : what should be returned for an empty string ?
+# anyway this shouldn't segfault (bug #24554)
+ok( POSIX::isalnum(''), 'isalnum empty string' );
+ok( POSIX::isalnum(undef),'isalnum undef' );
+# those functions should stringify their arguments
+ok(!POSIX::isalpha([]), 'isalpha []' );
+ok( POSIX::isprint([]), 'isprint []' );
# Check that output is not flushed by _exit. This test should be last
# in the file, and is not counted in the total number of tests.
1.3 +135 -148 ponie/perl/lib/ExtUtils/MM_Unix.pm
Index: MM_Unix.pm
===================================================================
RCS file: /cvs/public/ponie/perl/lib/ExtUtils/MM_Unix.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- MM_Unix.pm 9 Sep 2003 14:48:07 -0000 1.2
+++ MM_Unix.pm 7 Apr 2004 10:37:29 -0000 1.3
@@ -7,7 +7,7 @@
use Exporter ();
use Carp;
use Config qw(%Config);
-use File::Basename qw(basename dirname fileparse);
+use File::Basename qw(basename dirname);
use DirHandle;
use vars qw($VERSION @ISA
@@ -20,7 +20,7 @@
use ExtUtils::MakeMaker qw($Verbose neatvalue);
-$VERSION = '1.41';
+$VERSION = '1.45_01';
require ExtUtils::MM_Any;
@ISA = qw(ExtUtils::MM_Any);
@@ -295,7 +295,8 @@
push(@otherfiles, qw[./blib $(MAKE_APERL_FILE)
$(INST_ARCHAUTODIR)/extralibs.all
$(INST_ARCHAUTODIR)/extralibs.ld
- perlmain.c tmon.out mon.out so_locations pm_to_blib
+ perlmain.c tmon.out mon.out so_locations
+ blibdirs.exists pm_to_blib
*$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
$(BOOTSTRAP) $(BASEEXT).bso
$(BASEEXT).def lib$(BASEEXT).def
@@ -558,50 +559,73 @@
join "", @m;
}
-=item dir_target (o)
-Takes an array of directories that need to exist and returns a
-Makefile entry for a .exists file in these directories. Returns
-nothing, if the entry has already been processed. We're helpless
-though, if the same directory comes as $(FOO) _and_ as "bar". Both of
-them get an entry, that's why we use "::".
+=item dir_target B<DEPRECATED>
+
+ my $make_frag = $mm->dir_target(@directories);
+
+I<This function is deprecated> its use is no longer necessary and is I<only
+provided for backwards compatibility>. blibdirs_target provides a much
+simpler mechanism and pm_to_blib() can create its own directories anyway.
+
+Returns a Makefile entry for a .exists file in each of the @directories.
+The purpose is to create a directory and provide a make target to depend on.
+The make target is a .exists file in each of those directories.
+
+For example
+
+ $mm->dir_target('$(INST_ARCHDIR)');
+
+would return the make target C<$(INST_ARCHDIR)/.exists> which would
+create $(INST_ARCHDIR) and touch .exists. You would depend on this target
+to make sure $(INST_ARCHDIR) is created.
+
+Ignores directories which have already gone through dir_target() so you
+might wind up getting nothing.
=cut
sub dir_target {
-# --- Make-Directories section (internal method) ---
-# dir_target(@array) returns a Makefile entry for the file .exists in each
-# named directory. Returns nothing, if the entry has already been processed.
-# We're helpless though, if the same directory comes as $(FOO) _and_ as "bar".
-# Both of them get an entry, that's why we use "::". I chose '$(PERL)' as the
-# prerequisite, because there has to be one, something that doesn't change
-# too often :)
-
my($self,@dirs) = @_;
- my(@m,$dir,$targdir);
- foreach $dir (@dirs) {
- my($src) = $self->catfile($self->{PERL_INC},'perl.h');
- my($targ) = $self->catfile($dir,'.exists');
- # catfile may have adapted syntax of $dir to target OS, so...
+
+ my @targs = ();
+ my $make = '';
+ foreach my $dir (@dirs) {
+ my $targ = $self->catfile($dir, '.exists');
+
+ my $targdir;
if ($Is_VMS) { # Just remove file name; dirspec is often in macro
($targdir = $targ) =~ s:/?\.exists\z::;
}
else { # while elsewhere we expect to see the dir separator in $targ
$targdir = dirname($targ);
}
+
next if $self->{DIR_TARGET}{$self}{$targdir}++;
- push @m, qq{
-$targ :: $src
+
+ push @targs, $targ;
+ $make .= <<MAKE_FRAG;
+$targ ::
\$(NOECHO) \$(MKPATH) $targdir
- \$(NOECHO) \$(EQUALIZE_TIMESTAMP) $src $targ
-};
- push(@m, qq{
- -\$(NOECHO) \$(CHMOD) \$(PERM_RWX) $targdir
-}) unless $Is_VMS;
+ \$(NOECHO) \$(TOUCH) $targ
+ \$(NOECHO) \$(CHMOD) \$(PERM_RWX) $targdir
+
+MAKE_FRAG
+
}
- join "", @m;
+
+ # So these new .exists targets get called along with blibdirs.exists.
+ my $blib_addition = '';
+ $blib_addition = <<MAKE_FRAG if @targs;
+blibdirs.exists :: @targs
+ \$(NOECHO) \$(NOOP)
+
+MAKE_FRAG
+
+ return $blib_addition . $make;
}
+
=item init_DEST
$mm->init_DEST
@@ -953,7 +977,7 @@
my($self) = shift;
return <<'MAKE_FRAG';
-distdir : metafile metafile_addtomanifest
+distdir : metafile metafile_addtomanifest signature
$(RM_RF) $(DISTVNAME)
$(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \
-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
@@ -1054,7 +1078,7 @@
# As Mkbootstrap might not write a file (if none is required)
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
-$(BOOTSTRAP): $(FIRST_MAKEFILE) $(BOOTDEP) $(INST_ARCHAUTODIR)$(DIRFILESEP).exists
+$(BOOTSTRAP): $(FIRST_MAKEFILE) $(BOOTDEP) blibdirs.exists
$(NOECHO) $(ECHO) "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
$(NOECHO) $(PERLRUN) \
"-MExtUtils::Mkbootstrap" \
@@ -1062,7 +1086,7 @@
$(NOECHO) $(TOUCH) $(BOOTSTRAP)
$(CHMOD) $(PERM_RW) $@
-$(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DIRFILESEP).exists
+$(INST_BOOT): $(BOOTSTRAP) blibdirs.exists
$(NOECHO) $(RM_RF) $(INST_BOOT)
-$(CP) $(BOOTSTRAP) $(INST_BOOT)
$(CHMOD) $(PERM_RW) $@
@@ -1097,7 +1121,7 @@
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
INST_DYNAMIC_FIX = '.$ld_fix.'
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DIRFILESEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) blibdirs.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
');
if ($armaybe ne ':'){
$ldfrom = 'tmp$(LIB_EXT)';
@@ -1120,17 +1144,15 @@
my $libs = '$(LDLOADLIBS)';
- if ($Is_NetBSD) {
+ if ($Is_NetBSD && $Config{'useshrplib'}) {
# Use nothing on static perl platforms, and to the flags needed
# to link against the shared libperl library on shared perl
# platforms. We peek at lddlflags to see if we need -Wl,-R
# or -R to add paths to the run-time library search path.
- if ($Config{'useshrplib'}) {
if ($Config{'lddlflags'} =~ /-Wl,-R/) {
- $libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -lperl';
+ $libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -Wl,-R$(PERL_ARCHLIB)/CORE -lperl';
} elsif ($Config{'lddlflags'} =~ /-R/) {
- $libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -lperl';
- }
+ $libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -R$(PERL_ARCHLIB)/CORE -lperl';
}
}
@@ -1141,7 +1163,6 @@
$(CHMOD) $(PERM_RWX) $@
';
- push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
join('',@m);
}
@@ -1216,7 +1237,7 @@
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
- my $version_check = qq{$abs -e "require $ver; print qq{VER_OK\n}"};
+ my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"};
# To avoid using the unportable 2>&1 to supress STDERR,
# we close it before running the command.
# However, thanks to a thread library bug in many BSDs
@@ -1669,7 +1690,7 @@
Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*,
-INSTALL*, INSTALLDIRS, LD, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
+INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB,
PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION,
VERSION_SYM, XS_VERSION.
@@ -1815,24 +1836,6 @@
}
}
}
-
- unless(-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")))
- {
- die qq{
-Error: Unable to locate installed Perl libraries or Perl source code.
-
-It is recommended that you install perl in a standard location before
-building extensions. Some precompiled versions of perl do not contain
-these header files, so you cannot build extensions. In such a case,
-please build and install your perl from a fresh perl distribution. It
-usually solves this kind of problem.
-
-\(You get this message, because MakeMaker could not find "$perl_h"\)
-};
- }
-# print STDOUT "Using header files found in $self->{PERL_INC}\n"
-# if $Verbose && $self->needs_linking();
-
}
# We get SITELIBEXP and SITEARCHEXP directly via
@@ -1870,7 +1873,6 @@
$self->{AR_STATIC_ARGS} ||= "cr";
# These should never be needed
- $self->{LD} ||= 'ld';
$self->{OBJ_EXT} ||= '.o';
$self->{LIB_EXT} ||= '.a';
@@ -1887,7 +1889,7 @@
=item init_others
-Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH,
+Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, LD,
OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, SHELL, NOOP,
FIRST_MAKEFILE, MAKEFILE_OLD, NOECHO, RM_F, RM_RF, TEST_F,
TOUCH, CP, MV, CHMOD, UMASK_NULL, ECHO, ECHO_N
@@ -1897,6 +1899,8 @@
sub init_others { # --- Initialize Other Attributes
my($self) = shift;
+ $self->{LD} ||= 'ld';
+
# Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
# undefined. In any case we turn it into an anon array:
@@ -1943,10 +1947,10 @@
$self->{NOOP} ||= '$(SHELL) -c true';
$self->{NOECHO} = '@' unless defined $self->{NOECHO};
- $self->{MAKEFILE} ||= 'Makefile';
- $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE};
- $self->{MAKEFILE_OLD} ||= '$(FIRST_MAKEFILE).old';
- $self->{MAKE_APERL_FILE} ||= '$(FIRST_MAKEFILE).aperl';
+ $self->{FIRST_MAKEFILE} ||= 'Makefile';
+ $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
+ $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old';
+ $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl';
$self->{SHELL} ||= $Config{sh} || '/bin/sh';
@@ -2045,17 +2049,35 @@
$self->init_lib2arch;
- # Initialize installvendorman*dir if necessary
+ # There are often no Config.pm defaults for these new man variables so
+ # we fall back to the old behavior which is to use installman*dir
+ foreach my $num (1, 3) {
+ my $k = 'installsiteman'.$num.'dir';
+
+ $self->{uc $k} ||= uc "\$(installman${num}dir)"
+ unless $Config{$k};
+ }
+
foreach my $num (1, 3) {
my $k = 'installvendorman'.$num.'dir';
unless ($Config{$k}) {
- $Config_Override{$k} = $Config{usevendorprefix} ?
- $self->catdir($Config{vendorprefixexp}, 'man', "man$num") :
- '';
+ $self->{uc $k} ||= $Config{usevendorprefix}
+ ? uc "\$(installman${num}dir)"
+ : '';
+ }
}
+
+ $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)'
+ unless $Config{installsitebin};
+
+ unless( $Config{installvendorbin} ) {
+ $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix}
+ ? $Config{installbin}
+ : '';
}
+
my $iprefix = $Config{installprefixexp} || $Config{installprefix} ||
$Config{prefixexp} || $Config{prefix} || '';
my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : '';
@@ -2064,22 +2086,6 @@
# 5.005_03 doesn't have a siteprefix.
$sprefix = $iprefix unless $sprefix;
- # There are often no Config.pm defaults for these, but we can make
- # it up.
- unless( $Config{installsiteman1dir} ) {
- $Config_Override{installsiteman1dir} =
- $self->catdir($sprefix, 'man', 'man1');
- }
-
- unless( $Config{installsiteman3dir} ) {
- $Config_Override{installsiteman3dir} =
- $self->catdir($sprefix, 'man', 'man3');
- }
-
- unless( $Config{installsitebin} ) {
- $Config_Override{installsitebin} =
- $self->catdir($sprefix, 'bin');
- }
$self->{PREFIX} ||= '';
@@ -2091,6 +2097,10 @@
$self->{PERLPREFIX} ||= $iprefix;
$self->{SITEPREFIX} ||= $sprefix;
$self->{VENDORPREFIX} ||= $vprefix;
+
+ # Lots of MM extension authors like to use $(PREFIX) so we
+ # put something sensible in there no matter what.
+ $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)';
}
my $arch = $Config{archname};
@@ -2321,21 +2331,15 @@
# Build up a set of file names (not command names).
my $thisperl = $self->canonpath($^X);
- $thisperl .= $Config{exe_ext} unless $thisperl =~ m/$Config{exe_ext}$/i;
+ $thisperl .= $Config{exe_ext} unless
+ # VMS might have a file version # at the end
+ $Is_VMS ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i
+ : $thisperl =~ m/$Config{exe_ext}$/i;
# We need a relative path to perl when in the core.
$thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE};
my @perls = ($thisperl);
- my $ndbg = '';
- if ( $Is_VMS ) {
- if ( defined( $Config{usevmsdebug} ) ) {
- if ( $Config{usevmsdebug} eq 'define' ) {
- push @perls, map { "$_$Config{exe_ext}" } ('ndbgperl');
- $ndbg = 'ndbg';
- }
- }
- }
push @perls, map { "$_$Config{exe_ext}" }
('perl', 'perl5', "perl$Config{version}");
@@ -2354,8 +2358,15 @@
# don't check if perl is executable, maybe they have decided to
# supply switches with perl
+ # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
+ my $perl_name = 'perl';
+ $perl_name = 'ndbgperl' if $Is_VMS &&
+ defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define';
+
+ # XXX This logic is flawed. If "miniperl" is anywhere in the path
+ # it will get confused. It should be fixed to work only on the filename.
# Define 'FULLPERL' to be a non-miniperl (used in test: target)
- ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/${ndbg}perl/i
+ ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/$perl_name/i
unless $self->{FULLPERL};
# Little hack to get around VMS's find_perl putting "MCR" in front
@@ -2596,7 +2607,6 @@
return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
return "" unless @{$self->{EXE_FILES}};
my(@m, $from, $to, %fromto, @to);
- push @m, $self->dir_target(qw[$(INST_SCRIPT)]);
for $from (@{$self->{EXE_FILES}}) {
my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
local($_) = $path; # for backwards compatibility
@@ -2631,7 +2641,7 @@
last unless defined $from;
my $todir = dirname($to);
push @m, "
-$to: $from \$(FIRST_MAKEFILE) " . $self->catdir($todir,'.exists') . "
+$to : $from \$(FIRST_MAKEFILE) blibdirs.exists
\$(NOECHO) \$(RM_F) $to
\$(CP) $from $to
\$(FIXIN) $to
@@ -2767,7 +2777,7 @@
require File::Find;
File::Find::find(sub {
return unless m/\Q$self->{LIB_EXT}\E$/;
- return if m/^libperl/;
+ return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;
# Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a)
return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";
@@ -2879,7 +2889,7 @@
";
push @m, "
-\$(INST_ARCHAUTODIR)/extralibs.all: \$(INST_ARCHAUTODIR)\$(DIRFILESEP).exists ".join(" \\\n\t", @$extra).'
+\$(INST_ARCHAUTODIR)/extralibs.all: blibdirs.exists ".join(" \\\n\t", @$extra).'
$(NOECHO) $(RM_F) $@
$(NOECHO) $(TOUCH) $@
';
@@ -2962,8 +2972,8 @@
$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
$(NOECHO) $(ECHO) "Makefile out-of-date with respect to $?"
$(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."
- $(NOECHO) $(RM_F) $(MAKEFILE_OLD)
- $(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
+ -$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
+ -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
-$(MAKE) -f $(MAKEFILE_OLD) clean $(DEV_NULL) || $(NOOP)
$(PERLRUN) Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{
$(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
@@ -3074,6 +3084,7 @@
my $result;
local *FH;
local $/ = "\n";
+ local $_;
open(FH,$parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
while (<FH>) {
@@ -3427,7 +3438,9 @@
print STDERR " prefixify $var => $path\n" if $Verbose >= 2;
print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2;
- if( $path !~ s{^\Q$sprefix\E\b}{$rprefix}s && $self->{ARGS}{PREFIX} ) {
+ if( $self->{ARGS}{PREFIX} && $self->file_name_is_absolute($path) &&
+ $path !~ s{^\Q$sprefix\E\b}{$rprefix}s )
+ {
print STDERR " cannot prefix, using default.\n" if $Verbose >= 2;
print STDERR " no default!\n" if !$default && $Verbose >= 2;
@@ -3685,7 +3698,7 @@
my(@m);
push(@m, <<'END');
-$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DIRFILESEP).exists
+$(INST_STATIC): $(OBJECT) $(MYEXTLIB) blibdirs.exists
$(RM_RF) $@
END
@@ -3714,7 +3727,6 @@
$(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs
MAKE_FRAG
- push @m, "\n", $self->dir_target('$(INST_ARCHAUTODIR)');
join('', @m);
}
@@ -3833,7 +3845,7 @@
");
if ($Is_Win95) {
- push(@m, map(qq{\t\$(NOECHO) \$(PERLRUN) -e "exit unless -f shift; chdir '$_'; system q{\$(MAKE) test \$(PASTHRU)}" \$(FIRST_MAKEFILE)\n}, @{$self->{DIR}}));
+ push(@m, map(qq{\t\$(NOECHO) \$(PERLRUN) -e "exit unless -f shift; chdir '$_'; system q[\$(MAKE) test \$(PASTHRU)]" \$(FIRST_MAKEFILE)\n}, @{$self->{DIR}}));
}
else {
push(@m, map("\t\$(NOECHO) cd $_ && \$(TEST_F) \$(FIRST_MAKEFILE) && \$(MAKE) test \$(PASTHRU)\n", @{$self->{DIR}}));
@@ -4018,35 +4030,10 @@
subdirs :: $(MYEXTLIB)
$(NOECHO) $(NOOP)
-config :: $(FIRST_MAKEFILE) $(INST_LIBDIR)$(DIRFILESEP).exists
- $(NOECHO) $(NOOP)
-
-config :: $(INST_ARCHAUTODIR)$(DIRFILESEP).exists
- $(NOECHO) $(NOOP)
-
-config :: $(INST_AUTODIR)$(DIRFILESEP).exists
+config :: $(FIRST_MAKEFILE) blibdirs.exists
$(NOECHO) $(NOOP)
';
- push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
-
- if (%{$self->{MAN1PODS}}) {
- push @m, q[
-config :: $(INST_MAN1DIR)$(DIRFILESEP).exists
- $(NOECHO) $(NOOP)
-
-];
- push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
- }
- if (%{$self->{MAN3PODS}}) {
- push @m, q[
-config :: $(INST_MAN3DIR)$(DIRFILESEP).exists
- $(NOECHO) $(NOOP)
-
-];
- push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
- }
-
push @m, '
$(O_FILES): $(H_FILES)
' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
1.5 +148 -73 ponie/perl/pod/perlapi.pod
Index: perlapi.pod
===================================================================
RCS file: /cvs/public/ponie/perl/pod/perlapi.pod,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- perlapi.pod 10 Mar 2004 23:07:23 -0000 1.4
+++ perlapi.pod 7 Apr 2004 10:37:30 -0000 1.5
@@ -725,7 +725,9 @@
=item unpackstring
-The engine implementing unpack() Perl function.
+The engine implementing unpack() Perl function. C<unpackstring> puts the
+extracted list items on the stack and returns the number of elements.
+Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
I32 unpackstring(char *pat, char *patend, char *s, char *strend, U32 flags)
@@ -1065,6 +1067,15 @@
=for hackers
Found in file hv.h
+=item hv_assert
+
+Check that a hash is in an internally consistent state.
+
+ void hv_assert(HV* tb)
+
+=for hackers
+Found in file hv.c
+
=item hv_clear
Clears a hash, making it empty.
@@ -1074,6 +1085,21 @@
=for hackers
Found in file hv.c
+=item hv_clear_placeholders
+
+Clears any placeholders from a hash. If a restricted hash has any of its keys
+marked as readonly and the key is subsequently deleted, the key is not actually
+deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
+it so it will be ignored by future operations such as iterating over the hash,
+but will still allow the hash to have a value reaasigned to the key at some
+future point. This function clears any such placeholder keys from the hash.
+See Hash::Util::lock_keys() for an example of its use.
+
+ void hv_clear_placeholders(HV* hb)
+
+=for hackers
+Found in file hv.c
+
=item hv_delete
Deletes a key/value pair in the hash. The value SV is removed from the
@@ -1254,6 +1280,15 @@
=for hackers
Found in file hv.c
+=item hv_scalar
+
+Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
+
+ SV* hv_scalar(HV* hv)
+
+=for hackers
+Found in file hv.c
+
=item hv_store
Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
@@ -1737,15 +1772,17 @@
Function must be called with an already existing SV like
- sv = NEWSV(92,0);
- s = scan_version(s,sv);
+ sv = newSV(0);
+ s = scan_version(s,SV *sv, bool qv);
Performs some preprocessing to the string to ensure that
it has the correct characteristics of a version. Flags the
object if it contains an underscore (which denotes this
-is a beta version).
+is a alpha version). The boolean qv denotes that the version
+should be interpreted as if it had multiple decimals, even if
+it doesn't.
- char* scan_version(char *vstr, SV *sv)
+ char* scan_version(char *vstr, SV *sv, bool qv)
=for hackers
Found in file util.c
@@ -2787,7 +2824,7 @@
Returns a boolean indicating whether the SV contains a signed integer.
- void SvIOK_notUV(SV* sv)
+ bool SvIOK_notUV(SV* sv)
=for hackers
Found in file sv.h
@@ -2832,7 +2869,7 @@
Returns a boolean indicating whether the SV contains an unsigned integer.
- void SvIOK_UV(SV* sv)
+ bool SvIOK_UV(SV* sv)
=for hackers
Found in file sv.h
@@ -2888,6 +2925,15 @@
=for hackers
Found in file sv.h
+=item SvIV_nomg
+
+Like C<SvIV> but doesn't process magic.
+
+ IV SvIV_nomg(SV* sv)
+
+=for hackers
+Found in file sv.h
+
=item SvLEN
Returns the size of the string buffer in the SV, not including any part
@@ -2983,22 +3029,22 @@
=for hackers
Found in file sv.h
-=item SvNVX
+=item SvNVx
-Returns the raw value in the SV's NV slot, without checks or conversions.
-Only use when you are sure SvNOK is true. See also C<SvNV()>.
+Coerces the given SV to a double and returns it. Guarantees to evaluate
+sv only once. Use the more efficient C<SvNV> otherwise.
- NV SvNVX(SV* sv)
+ NV SvNVx(SV* sv)
=for hackers
Found in file sv.h
-=item SvNVx
+=item SvNVX
-Coerces the given SV to a double and returns it. Guarantees to evaluate
-sv only once. Use the more efficient C<SvNV> otherwise.
+Returns the raw value in the SV's NV slot, without checks or conversions.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
- NV SvNVx(SV* sv)
+ NV SvNVX(SV* sv)
=for hackers
Found in file sv.h
@@ -3065,7 +3111,7 @@
=item SvPOK_only
Tells an SV that it is a string and disables all other OK bits.
-Will also turn off the UTF8 status.
+Will also turn off the UTF-8 status.
void SvPOK_only(SV* sv)
@@ -3075,7 +3121,7 @@
=item SvPOK_only_UTF8
Tells an SV that it is a string and disables all other OK bits,
-and leaves the UTF8 status as it was.
+and leaves the UTF-8 status as it was.
void SvPOK_only_UTF8(SV* sv)
@@ -3244,6 +3290,15 @@
=for hackers
Found in file sv.h
+=item SvPV_nomg
+
+Like C<SvPV> but doesn't process magic.
+
+ char* SvPV_nomg(SV* sv, STRLEN len)
+
+=for hackers
+Found in file sv.h
+
=item SvREFCNT
Returns the value of the object's reference count.
@@ -3411,14 +3466,14 @@
Returns a boolean indicating whether the SV contains UTF-8 encoded data.
- void SvUTF8(SV* sv)
+ bool SvUTF8(SV* sv)
=for hackers
Found in file sv.h
=item SvUTF8_off
-Unsets the UTF8 status of an SV.
+Unsets the UTF-8 status of an SV.
void SvUTF8_off(SV *sv)
@@ -3427,7 +3482,7 @@
=item SvUTF8_on
-Turn on the UTF8 status of an SV (the data is not changed, just the flag).
+Turn on the UTF-8 status of an SV (the data is not changed, just the flag).
Do not use frivolously.
void SvUTF8_on(SV *sv)
@@ -3445,6 +3500,16 @@
=for hackers
Found in file sv.h
+=item SvUVX
+
+Returns the raw value in the SV's UV slot, without checks or conversions.
+Only use when you are sure SvIOK is true. See also C<SvUV()>.
+
+ UV SvUVX(SV* sv)
+
+=for hackers
+Found in file sv.h
+
=item SvUVx
Coerces the given SV to an unsigned integer and returns it. Guarantees to
@@ -3455,12 +3520,11 @@
=for hackers
Found in file sv.h
-=item SvUVX
+=item SvUV_nomg
-Returns the raw value in the SV's UV slot, without checks or conversions.
-Only use when you are sure SvIOK is true. See also C<SvUV()>.
+Like C<SvUV> but doesn't process magic.
- UV SvUVX(SV* sv)
+ UV SvUV_nomg(SV* sv)
=for hackers
Found in file sv.h
@@ -3505,12 +3569,13 @@
=for hackers
Found in file sv.c
-=item sv_2iv
+=item sv_2iv_flags
-Return the integer value of an SV, doing any necessary string conversion,
-magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+Return the integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
- IV sv_2iv(SV* sv)
+ IV sv_2iv_flags(SV* sv, I32 flags)
=for hackers
Found in file sv.c
@@ -3540,7 +3605,7 @@
=item sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be downgraded from UTF8 as a
+to its length. May cause the SV to be downgraded from UTF-8 as a
side-effect.
Usually accessed via the C<SvPVbyte> macro.
@@ -3553,7 +3618,7 @@
=item sv_2pvbyte_nolen
Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF8 as a side-effect.
+May cause the SV to be downgraded from UTF-8 as a side-effect.
Usually accessed via the C<SvPVbyte_nolen> macro.
@@ -3564,8 +3629,8 @@
=item sv_2pvutf8
-Return a pointer to the UTF8-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8> macro.
@@ -3576,8 +3641,8 @@
=item sv_2pvutf8_nolen
-Return a pointer to the UTF8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV.
+May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8_nolen> macro.
@@ -3608,13 +3673,13 @@
=for hackers
Found in file sv.c
-=item sv_2uv
+=item sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
-conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
-macros.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
- UV sv_2uv(SV* sv)
+ UV sv_2uv_flags(SV* sv, I32 flags)
=for hackers
Found in file sv.c
@@ -3643,8 +3708,8 @@
=item sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-If the SV has the UTF8 status set, then the bytes appended should be
-valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF-8 status set, then the bytes appended should be
+valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
void sv_catpv(SV* sv, const char* ptr)
@@ -3678,8 +3743,8 @@
=item sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
void sv_catpvn(SV* sv, const char* ptr, STRLEN len)
@@ -3690,8 +3755,8 @@
=item sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
@@ -3990,7 +4055,7 @@
=item sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF8 bytes as a single character. Handles magic and type coercion.
+UTF-8 bytes as a single character. Handles magic and type coercion.
STRLEN sv_len_utf8(SV* sv)
@@ -4075,7 +4140,7 @@
=item sv_pos_b2u
Converts the value pointed to by offsetp from a count of bytes from the
-start of the string, to a count of the equivalent number of UTF8 chars.
+start of the string, to a count of the equivalent number of UTF-8 chars.
Handles magic and type coercion.
void sv_pos_b2u(SV* sv, I32* offsetp)
@@ -4085,7 +4150,7 @@
=item sv_pos_u2b
-Converts the value pointed to by offsetp from a count of UTF8 chars from
+Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
the offset, rather than from the start of the string. Handles magic and
@@ -4634,7 +4699,7 @@
=item sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
+Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
This may not be possible if the PV contains non-byte encoding characters;
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
@@ -4652,7 +4717,7 @@
=item sv_utf8_encode
-Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
flag so that it looks like octets again. Used as a building block
for encode_utf8 in Encode.xs
@@ -4663,7 +4728,7 @@
=item sv_utf8_upgrade
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
@@ -4678,7 +4743,7 @@
=item sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
@@ -4739,7 +4804,7 @@
=item bytes_from_utf8
-Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
the newly-created string, and updates C<len> to contain the new
length. Returns the original string if no conversion occurs, C<len>
@@ -4756,11 +4821,11 @@
=item bytes_to_utf8
-Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
+Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
Returns a pointer to the newly-created string, and sets C<len> to
reflect the new length.
-If you want to convert to UTF8 from other encodings than ASCII,
+If you want to convert to UTF-8 from other encodings than ASCII,
see sv_recode_to_utf8().
NOTE: this function is experimental and may change or be
@@ -4814,15 +4879,25 @@
=item is_utf8_string
Returns true if first C<len> bytes of the given string form a valid
-UTF8 string, false otherwise. Note that 'a valid UTF8 string' does
-not mean 'a string that contains code points above 0x7F encoded in
-UTF8' because a valid ASCII string is a valid UTF8 string.
+UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
+not mean 'a string that contains code points above 0x7F encoded in UTF-8'
+because a valid ASCII string is a valid UTF-8 string.
bool is_utf8_string(U8 *s, STRLEN len)
=for hackers
Found in file utf8.c
+=item is_utf8_string_loc
+
+Like is_ut8_string but store the location of the failure in
+the last argument.
+
+ bool is_utf8_string_loc(U8 *s, STRLEN len, U8 **p)
+
+=for hackers
+Found in file utf8.c
+
=item pv_uni_display
Build to the scalar dsv a displayable version of the string spv,
@@ -4987,7 +5062,7 @@
=item utf8n_to_uvchr
Returns the native character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
Allows length and flags to be passed to low level routine.
@@ -5001,10 +5076,10 @@
Bottom level UTF-8 decode routine.
Returns the unicode code point value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding and no longer than C<curlen>;
+which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
C<retlen> will be set to the length, in bytes, of that character.
-If C<s> does not point to a well-formed UTF8 character, the behaviour
+If C<s> does not point to a well-formed UTF-8 character, the behaviour
is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
it is assumed that the caller will raise a warning, and this function
will silently just set C<retlen> to C<-1> and return zero. If the
@@ -5024,7 +5099,7 @@
=item utf8_distance
-Returns the number of UTF8 characters between the UTF-8 pointers C<a>
+Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
and C<b>.
WARNING: use only if you *know* that the pointers point inside the
@@ -5062,7 +5137,7 @@
=item utf8_to_bytes
-Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
Unlike C<bytes_to_utf8>, this over-writes the original string, and
updates len to contain the new length.
Returns zero on failure, setting C<len> to -1.
@@ -5078,10 +5153,10 @@
=item utf8_to_uvchr
Returns the native character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
-If C<s> does not point to a well-formed UTF8 character, zero is
+If C<s> does not point to a well-formed UTF-8 character, zero is
returned and retlen is set, if possible, to -1.
UV utf8_to_uvchr(U8 *s, STRLEN* retlen)
@@ -5092,13 +5167,13 @@
=item utf8_to_uvuni
Returns the Unicode code point of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
This function should only be used when returned UV is considered
an index into the Unicode semantic tables (e.g. swashes).
-If C<s> does not point to a well-formed UTF8 character, zero is
+If C<s> does not point to a well-formed UTF-8 character, zero is
returned and retlen is set, if possible, to -1.
UV utf8_to_uvuni(U8 *s, STRLEN* retlen)
@@ -5108,7 +5183,7 @@
=item uvchr_to_utf8
-Adds the UTF8 representation of the Native codepoint C<uv> to the end
+Adds the UTF-8 representation of the Native codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
@@ -5126,7 +5201,7 @@
=item uvuni_to_utf8_flags
-Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
+Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
@@ -5325,8 +5400,9 @@
=item croak
This is the XSUB-writer's interface to Perl's C<die> function.
-Normally use this function the same way you use the C C<printf>
-function. See C<warn>.
+Normally call this function the same way you call the C C<printf>
+function. Calling C<croak> returns control directly to Perl,
+sidestepping the normal C order of execution. See C<warn>.
If you want to throw an exception object, assign the object to
C<$@> and then pass C<Nullch> to croak():
@@ -5342,9 +5418,8 @@
=item warn
-This is the XSUB-writer's interface to Perl's C<warn> function. Use this
-function the same way you use the C C<printf> function. See
-C<croak>.
+This is the XSUB-writer's interface to Perl's C<warn> function. Call this
+function the same way you call the C C<printf> function. See C<croak>.
void warn(const char* pat, ...)
1.2 +269 -21 ponie/perl/pod/perldelta.pod
Index: perldelta.pod
===================================================================
RCS file: /cvs/public/ponie/perl/pod/perldelta.pod,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- perldelta.pod 9 Sep 2003 11:59:43 -0000 1.1
+++ perldelta.pod 7 Apr 2004 10:37:30 -0000 1.2
@@ -1,60 +1,308 @@
=head1 NAME
-perldelta - what is new for perl v5.9.0
+perldelta - what is new for perl v5.9.1
=head1 DESCRIPTION
-This document describes differences between the 5.8.0 release and
-the 5.9.0 release.
+This document describes differences between the 5.9.0 and the 5.9.1
+developement releases. See L<perl590delta> for the differences between
+5.8.0 and 5.9.0.
=head1 Incompatible Changes
-=head2 The C<$*> variable has been removed
+=head2 substr() lvalues are no longer fixed-length
-C<$*>, which was deprecated in favor of the C</s> and C</m> regexp
-modifiers, has been removed.
+The lvalues returned by the three argument form of substr() used to be a
+"fixed length window" on the original string. In some cases this could
+cause surprising action at distance or other undefined behaviour. Now the
+length of the window adjusts iself to the length of the string assigned to
+it.
+
+=head2 The C<:unique> attribute is only meaningful for globals
+
+Now applying C<:unique> to lexical variables and to subroutines will
+result in a compilation error.
=head1 Core Enhancements
-=head2 Tied Arrays with Negative Array Indices
+=head2 Lexical C<$_>
+
+The default variable C<$_> can now be lexicalized, by declaring it like
+any other lexical variable, with a simple
+
+ my $_;
+
+The operations that default on C<$_> will use the lexically-scoped
+version of C<$_> when it exists, instead of the global C<$_>.
+
+In a C<map> or a C<grep> block, if C<$_> was previously my'ed, then the
+C<$_> inside the block is lexical as well (and scoped to the block).
+
+In a scope where C<$_> has been lexicalized, you can still have access to
+the global version of C<$_> by using C<$::_>, or, more simply, by
+overriding the lexical declaration with C<our $_>.
+
+=head2 Tied hashes in scalar context
+
+As of perl 5.8.2/5.9.0, tied hashes did not return anything useful in
+scalar context, for example when used as boolean tests:
+
+ if (%tied_hash) { ... }
+
+The old nonsensical behaviour was always to return false,
+regardless of whether the hash is empty or has elements.
-Formerly, the indices passed to C<FETCH>, C<STORE>, C<EXISTS>, and
-C<DELETE> methods in tied array class were always non-negative. If
-the actual argument was negative, Perl would call FETCHSIZE implicitly
-and add the result to the index before passing the result to the tied
-array method. This behavior is now optional. If the tied array class
-contains a package variable named C<$NEGATIVE_INDICES> which is set to
-a true value, negative values will be passed to C<FETCH>, C<STORE>,
-C<EXISTS>, and C<DELETE> unchanged.
+There is now an interface for the implementors of tied hashes to implement
+the behaviour of a hash in scalar context, via the SCALAR method (see
+L<perltie>). Without a SCALAR method, perl will try to guess whether
+the hash is empty, by testing if it's inside an iteration (in this case
+it can't be empty) or by calling FIRSTKEY.
+
+=head2 Formats
+
+Formats were improved in several ways. A new field, C<^*>, can be used for
+variable-width, one-line-at-a-time text. Null characters are now handled
+correctly in picture lines. Using C<@#> and C<~~> together will now
+produce a compile-time error, as those format fields are incompatible.
+L<perlform> has been improved, and miscellaneous bugs fixed.
+
+=head2 Stacked filetest operators
+
+As a new form of syntactic sugar, it's now possible to stack up filetest
+operators. You can now write C<-f -w -x $file> in a row to mean
+C<-x $file && -w _ && -f _>. See L<perlfunc/-X>.
=head1 Modules and Pragmata
+=over 4
+
+=item Benchmark
+
+In C<Benchmark>, cmpthese() and timestr() now use the time statistics of
+children instead of parent when the selected style is 'nop'.
+
+=item Carp
+
+The error messages produced by C<Carp> now include spaces between the
+arguments in function argument lists: this makes long error messages
+appear more nicely in browsers and other tools.
+
+=item Exporter
+
+C<Exporter> will now recognize grouping tags (such as C<:name>) anywhere
+in the import list, not only at the beginning.
+
+=item FindBin
+
+A function C<again> is provided to resolve problems where modules in different
+directories wish to use FindBin.
+
+=item List::Util
+
+You can now weaken references to read only values.
+
+=item threads::shared
+
+C<cond_wait> has a new two argument form. C<cond_timedwait> has been added.
+
+=back
+
=head1 Utility Changes
-=head1 New Documentation
+C<find2perl> now assumes C<-print> as a default action. Previously, it
+needed to be specified explicitly.
+
+A new utility, C<prove>, makes it easy to run an individual regression test
+at the command line. C<prove> is part of Test::Harness, which users of earlier
+Perl versions can install from CPAN.
+
+The perl debugger now supports a C<save> command, to save the current
+history to a file, and an C<i> command, which prints the inheritance tree
+of its argument (if the C<Class::ISA> module is installed.)
+
+=head1 Documentation
+
+The documentation has been revised in places to produce more standard manpages.
+
+The long-existing feature of C</(?{...})/> regexps setting C<$_> and pos()
+is now documented.
=head1 Performance Enhancements
-=head1 Installation and Configuration Improvements
+Sorting arrays in place (C<@a = sort @a>) is now optimized to avoid
+making a temporary copy of the array.
+
+The operations involving case mapping on UTF-8 strings (uc(), lc(),
+C<//i>, etc.) have been greatly speeded up.
+
+Access to elements of lexical arrays via a numeric constant between 0 and
+255 is now faster. (This used to be only the case for global arrays.)
=head1 Selected Bug Fixes
+=head2 UTF-8 bugs
+
+Using substr() on a UTF-8 string could cause subsequent accesses on that
+string to return garbage. This was due to incorrect UTF-8 offsets being
+cached, and is now fixed.
+
+join() could return garbage when the same join() statement was used to
+process 8 bit data having earlier processed UTF-8 data, due to the flags
+on that statement's temporary workspace not being reset correctly. This
+is now fixed.
+
+Using Unicode keys with tied hashes should now work correctly.
+
+chop() and chomp() used to mangle UTF-8 strings. This has been fixed.
+
+sprintf() used to misbehave when the format string was in UTF-8. This is
+now fixed.
+
+=head2 Threading bugs
+
+Hashes with the C<:unique> attribute weren't made read-only in new
+threads. They are now.
+
+=head2 More bugs
+
+C<$a .. $b> will now work as expected when either $a or $b is C<undef>.
+
+Reading $^E now preserves $!. Previously, the C code implementing $^E
+did not preserve C<errno>, so reading $^E could cause C<errno> and therefore
+C<$!> to change unexpectedly.
+
+C<strict> wasn't in effect in regexp-eval blocks (C</(?{...})/>).
+
=head1 New or Changed Diagnostics
+A new deprecation warning, I<Deprecated use of my() in false conditional>,
+has been added, to warn against the use of the dubious and deprecated
+construct
+
+ my $x if 0;
+
+See L<perldiag>.
+
+The fatal error I<DESTROY created new reference to dead object> is now
+documented in L<perldiag>.
+
+A new error, I<%ENV is aliased to %s>, is produced when taint checks are
+enabled and when C<*ENV> has been aliased (and thus doesn't reflect the
+program's environment anymore.)
+
=head1 Changed Internals
-=head1 New Tests
+These news matter to you only if you either write XS code or like to
+know about or hack Perl internals (using Devel::Peek or any of the
+C<B::> modules counts), or like to run Perl with the C<-D> option.
+
+=head2 Reordering of SVt_* constants
+
+The relative ordering of constants that define the various types of C<SV>
+have changed; in particular, C<SVt_PVGV> has been moved before C<SVt_PVLV>,
+C<SVt_PVAV>, C<SVt_PVHV> and C<SVt_PVCV>. This is unlikely to make any
+difference unless you have code that explicitly makes assumptions about that
+ordering. (The inheritance hierarchy of C<B::*> objects has been changed
+to reflect this.)
+
+=head2 Removal of CPP symbols
+
+The C preprocessor symbols C<PERL_PM_APIVERSION> and
+C<PERL_XS_APIVERSION>, which were supposed to give the version number of
+the oldest perl binary-compatible (resp. source-compatible) with the
+present one, were not used, and sometimes had misleading values. They have
+been removed.
+
+=head2 Less space is used by ops
+
+The C<BASEOP> structure now uses less space. The C<op_seq> field has been
+removed and replaced by two one-bit fields, C<op_opt> and C<op_static>.
+C<opt_type> is now 9 bits long. (Consequently, the C<B::OP> class doesn't
+provide an C<seq> method anymore.)
+
+=head2 New parser
+
+perl's parser is now generated by bison (it used to be generated by
+byacc.) As a result, it seems to be a bit more robust.
+
+=head1 Configuration and Building
+
+C<Configure> now invokes callbacks regardless of the value of the variable
+they are called for. Previously callbacks were only invoked in the
+C<case $variable $define)> branch. This change should only affect platform
+maintainers writing configuration hints files.
+
+The portability and cleanliness of the Win32 makefiles has been improved.
=head1 Known Problems
-=head1 Platform Specific Problems
+There are still a couple of problems in the implementation of the lexical
+C<$_>: it doesn't work inside C</(?{...})/> blocks and with regard to the
+reverse() built-in used without arguments. (See the TODO tests in
+F<t/op/mydef.t>.)
+
+=head2 Platform Specific Problems
+
+The test F<ext/IPC/SysV/t/ipcsysv.t> may fail on OpenBSD. This hasn't been
+diagnosed yet.
+
+On some configurations on AIX 5, one test in F<lib/Time/Local.t> fails.
+When configured with long doubles, perl may fail tests 224-236 in
+F<t/op/pow.t> on the same platform.
+
+For threaded builds, F<ext/threads/shared/t/wait.t> has been reported to
+fail some tests on HP-UX 10.20.
+
+=head1 To-do for perl 5.10.0
+
+This is a non-exhaustive, non-ordered, non-contractual and non-definitive
+list of things to do (or nice to have) for perl 5.10.0 :
+
+Clean up and finish support for assertions. See L<assertions>.
+
+Reimplement the mechanism of lexical pragmas to be more extensible. Fix
+current pragmas that don't work well (or at all) with lexical scopes or in
+run-time eval(STRING) (C<sort>, C<re>, C<encoding> for example). MJD has a
+preliminary patch that implements this.
+
+Fix (or rewrite) the implementation of the C</(?{...})/> closures.
+
+Conversions from byte strings to UTF-8 currently map high bit characters
+to Unicode without translation (or, depending on how you look at it, by
+implicitly assuming that the byte strings are in Latin-1). As perl assumes
+the C locale by default, upgrading a string to UTF-8 may change the
+meaning of its contents regarding character classes, case mapping, etc.
+This should probably emit a warning (at least).
+
+Introduce a new special block, UNITCHECK, which is run at the end of a
+compilation unit (module, file, eval(STRING) block). This will correspond to
+the Perl 6 CHECK. Perl 5's CHECK cannot be changed or removed because the
+O.pm/B.pm backend framework depends on it.
+
+Study the possibility of adding a new prototype character, C<_>, meaning
+"this argument defaults to $_".
+
+Make the peephole optimizer optional.
+
+Allow lexical aliases (maybe via the syntax C<my \$alias = \$foo>.
+
+Fix the bugs revealed by running the test suite with the C<-t> switch (via
+C<make test.taintwarn>).
+
+Make threads more robust.
+
+Make C<no 6> and C<no v6> work (opposite of C<use 5.005>, etc.).
+
+A test suite for the B module would be nice.
+
+A ponie.
=head1 Reporting Bugs
If you find what you think is a bug, you might check the articles
recently posted to the comp.lang.perl.misc newsgroup and the perl
-bug database at F<http://bugs.perl.org/>. There may also be
-information at F<http://www.perl.com/>, the Perl Home Page.
+bug database at http://bugs.perl.org/ . There may also be
+information at http://www.perl.org/ , the Perl Home Page.
If you believe you have an unreported bug, please run the B<perlbug>
program included with your release. Be sure to trim your bug down
1.3 +20 -1 ponie/perl/t/op/grep.t
Index: grep.t
===================================================================
RCS file: /cvs/public/ponie/perl/t/op/grep.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- grep.t 2 Mar 2004 17:29:59 -0000 1.2
+++ grep.t 7 Apr 2004 10:37:30 -0000 1.3
@@ -4,7 +4,7 @@
# grep() and map() tests
#
-print "1..34\n";
+print "1..37\n";
$test = 1;
@@ -140,6 +140,25 @@
map {"${_}x"} @_;
};
ok join("-",add_an_x(1,2,3,4)), "1x-2x-3x-4x";
+ $test++;
+}
+
+{
+ my $gimme;
+
+ sub gimme {
+ my $want = wantarray();
+ if (defined $want) {
+ $gimme = $want ? 'list' : 'scalar';
+ } else {
+ $gimme = 'void';
+ }
}
+ my @list = 0..9;
+
+ undef $gimme; gimme for @list; ok($gimme, 'void'); $test++;
+ undef $gimme; grep { gimme } @list; ok($gimme, 'scalar'); $test++;
+ undef $gimme; map { gimme } @list; ok($gimme, 'list'); $test++;
+}
1.3 +26 -19 ponie/perl/t/op/magic.t
Index: magic.t
===================================================================
RCS file: /cvs/public/ponie/perl/t/op/magic.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- magic.t 12 Mar 2004 12:23:14 -0000 1.2
+++ magic.t 7 Apr 2004 10:37:30 -0000 1.3
@@ -46,6 +46,7 @@
$Is_Cygwin = $^O eq 'cygwin';
$Is_MacOS = $^O eq 'MacOS';
$Is_MPE = $^O eq 'mpeix';
+$Is_miniperl = $ENV{PERL_CORE_MINITEST};
$PERL = ($Is_NetWare ? 'perl' :
($Is_MacOS || $Is_VMS) ? $^X :
@@ -125,7 +126,8 @@
END
close CMDPIPE;
$? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
- print $? & 0xFF ? "ok 6\n" : "not ok 6\n";
+ my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
+ print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n";
$test += 4;
}
@@ -346,7 +348,9 @@
skip('no caseless %ENV support') for 1..4;
}
-{
+if ($Is_miniperl) {
+ skip ("miniperl can't rely on loading %Errno");
+} else {
no warnings 'void';
# Make sure Errno hasn't been prematurely autoloaded
@@ -361,7 +365,9 @@
}, $@;
}
-
+if ($Is_miniperl) {
+ skip ("miniperl can't rely on loading %Errno");
+} else {
# Make sure that Errno loading doesn't clobber $!
undef %Errno::;
@@ -370,6 +376,7 @@
open(FOO, "nonesuch"); # Generate ENOENT
my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
ok ${"!"}{ENOENT};
+}
ok $^S == 0 && defined $^S;
eval { ok $^S == 1 };
1.3 +3 -2 ponie/perl/t/run/switches.t
Index: switches.t
===================================================================
RCS file: /cvs/public/ponie/perl/t/run/switches.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- switches.t 10 Mar 2004 18:12:12 -0000 1.2
+++ switches.t 7 Apr 2004 10:37:30 -0000 1.3
@@ -13,6 +13,8 @@
plan(tests => 26);
+use Config;
+
# due to a bug in VMS's piping which makes it impossible for runperl()
# to emulate echo -n (ie. stdin always winds up with a newline), these
# tests almost totally fail.
@@ -218,7 +220,6 @@
local $TODO = ''; # these ones should work on VMS
my $v = sprintf "%vd", $^V;
- use Config;
like( runperl( switches => ['-v'] ),
qr/This is ponie, v$v built for $Config{archname}.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s,
'-v looks okay' );
@@ -231,7 +232,7 @@
local $TODO = ''; # these ones should work on VMS
like( runperl( switches => ['-h'] ),
- qr/Usage: .+perl.+switches.+programfile.+arguments/,
+ qr/Usage: .+(?i:perl(?:$Config{_exe})?).+switches.+programfile.+arguments/,
'-h looks okay' );
}